site/cgi-bin/modules/BSE/EmailBlacklist.pm
site/cgi-bin/modules/BSE/EmailRequest.pm
site/cgi-bin/modules/BSE/EmailRequests.pm
+site/cgi-bin/modules/BSE/Formatter.pm
# site/cgi-bin/modules/BSE/FileEditor.pm
site/cgi-bin/modules/BSE/Mail.pm
site/cgi-bin/modules/BSE/Mail/SMTP.pm
site/cgi-bin/modules/BSE/Util/Valid.pm
site/cgi-bin/modules/BSE/Version.pm
site/cgi-bin/modules/Constants.pm
+site/cgi-bin/modules/DevHelp/Formatter.pm
site/cgi-bin/modules/DevHelp/HTML.pm
site/cgi-bin/modules/DevHelp/Report.pm
site/cgi-bin/modules/DevHelp/Tags.pm
site/templates/admin/subs/delete.tmpl
site/templates/admin/subs/edit.tmpl
site/templates/admin/subs/list.tmpl
+site/templates/admin/subs/sending.tmpl
site/templates/admin/subs/send_form.tmpl
site/templates/admin/subs/start_send.tmpl
site/templates/admin/userlist.tmpl
site/util/upgrade_mysql.pl
t/BSE/Test.pm
t/t00smoke.t
+t/t050format.t
t/t10edit.t
t/t20gen.t
t/t30rules.t Check for use strict and warnings
-VERSION=0.13
+VERSION=0.13_01
DISTNAME=bse-$(VERSION)
DISTBUILD=$(DISTNAME)
DISTTAR=../$(DISTNAME).tar
perl -MExtUtils::Command -e rm_rf $(DISTBUILD)
test: testinst
- perl -MTest::Harness=runtests -It -e 'runtests glob q!t/*.t!'
+ perl -MTest::Harness=runtests -Isite/cgi-bin/modules -It -e 'runtests glob q!t/*.t!'
manicheck:
perl -MExtUtils::Manifest=manicheck -e 'manicheck()'
height smallint(5) unsigned,
url varchar(255),
displayOrder integer not null default 0,
+ name varchar(255) default '' not null,
PRIMARY KEY (id)
);
refresh_to($req->url('logon'));
}
+sub tag_recipient_count {
+ my ($subs, $subindex) = @_;
+
+ $$subindex >= 0 && $$subindex < @$subs
+ or return '** subscriber_count only valid inside subscriptions iterator **';
+
+ $subs->[$$subindex]->recipient_count;
+}
+
sub list {
my ($q, $req, $cfg, $message) = @_;
\$subindex),
BSE::Util::Tags->secure($req),
message => sub { CGI::escapeHTML($message) },
+ recipient_count => [ \&tag_recipient_count, \@subs, \$subindex ],
);
BSE::Template->show_page('admin/subs/list', $cfg, \%acts);
}
my $msgs = BSE::Message->new(cfg=>$cfg, section=>'subs');
my $id = $q->param('id')
- or return _refresh_list($q, $cfg, $msgs->(startnoid=>"No id supplied to be edited"));
+ or return _refresh_list($q, $cfg, $msgs->(startnoid=>"No id supplied to be sent"));
my $sub = BSE::SubscriptionTypes->getByPkey($id)
or return _refresh_list($q, $cfg, $msgs->(startnosub=>"Cannot find record $id"));
or delete $opts{parentId};
}
- print "Content-Type: text/html\n\n";
- print "<html><head><title>Send Subscription - BSE</title></head>";
- print "<body><h2>Send Subscription</h2>\n";
+ my $template = BSE::Template->get_source('admin/subs/sending', $cfg);
+
+ my ($prefix, $permessage, $suffix) =
+ split /<:\s*iterator\s+(?:begin|end)\s+messages\s*:>/, $template;
+ my $acts_message;
+ my $acts_user;
+ my $is_error;
+ my %acts;
+ %acts =
+ (
+ BSE::Util::Tags->basic(\%acts, $q, $cfg),
+ BSE::Util::Tags->admin(\%acts, $cfg),
+ subscription => sub { escape_html($sub->{$_[0]}) },
+ message => sub { $acts_message },
+ user => sub { $acts_user ? escape_html($acts_user->{$_[0]}) : '' },
+ ifUser => sub { $acts_user },
+ ifError => sub { $is_error },
+ );
+ BSE::Template->show_replaced($prefix, $cfg, \%acts);
$sub->send($cfg, \%opts,
sub {
- print "<div>",CGI::escapeHTML($_[0]),"</div>\n";
+ my ($type, $user, $msg) = @_;
+ $acts_message = defined($msg) ? $msg : '';
+ $acts_user = $user;
+ $is_error = $type eq 'error';
+ print BSE::Template->replace($permessage, $cfg, \%acts);
});
- print qq!<p><a target="_top" href="/cgi-bin/admin/menu.pl">Back to Admin Menu</a></p>\n!;
- print "</body></html>\n";
+ print BSE::Template->replace($suffix, $cfg, \%acts);
}
sub req_delconfirm {
Images => 'select * from image',
replaceImage =>
- 'replace image values (?,?,?,?,?,?,?,?)',
- addImage => 'insert image values(null, ?, ?, ?, ?, ?, ?, ?)',
+ 'replace image values (?,?,?,?,?,?,?,?,?)',
+ addImage => 'insert image values(null, ?, ?, ?, ?, ?, ?, ?, ?)',
deleteImage => 'delete from image where id = ?',
getImageByArticleId => 'select * from image where articleId = ? order by displayOrder',
'select * from subscription_types where id = ? order by name',
deleteSubscriptionType =>
'delete from subscription_types where id = ?',
+ subRecipientCount => <<EOS,
+select count(*) as "count" from site_users si, subscribed_users su
+ where confirmed <> 0 and si.id = su.userId and su.subId = ?
+EOS
addSubscribedUser=>
'insert subscribed_users values(null,?,?)',
$article->save;
}
my @images = $article->images;
+
+ @images or
+ return $self->refresh($article, $cgi, undef, 'No images to save information for');
my $changed;
my @alt = $cgi->param('alt');
$images[$index]{url} = $urls[$index];
}
}
+ my %errors;
+ my @names = map scalar($cgi->param('name'.$_)), 0..$#images;
+ if (@names) {
+ # make sure there aren't any dups
+ my %used;
+ my $index = 0;
+ for my $name (@names) {
+ defined $name or $name = '';
+ if ($name ne '') {
+ if ($name =~ /^[a-z_]\w*$/i) {
+ if ($used{lc $name}++) {
+ $errors{"name$index"} = 'Names must be empty, or alphanumeric and unique to the article';
+ }
+ }
+ else {
+ $errors{"name$index"} = 'Image identifiers must be unique to the article';
+ }
+ }
+ ++$index;
+ }
+ }
+ keys %errors
+ and return $self->edit_form($req, $article, $articles, undef,
+ \%errors);
+ for my $index (0..$#images) {
+ $images[$index]{name} = $names[$index];
+ }
if ($changed) {
for my $image (@images) {
$image->save;
use Util 'generate_article';
generate_article($articles, $article) if $Constants::AUTO_GENERATE;
-
return $self->refresh($article, $cgi, undef, 'Image information saved');
}
my $cgi = $req->cgi;
+ my %errors;
+ my $msg;
+ my $imageref = $cgi->param('name');
+ if (defined $imageref) {
+ if ($imageref =~ /^[a-z_]\w+$/i) {
+ # make sure it's unique
+ my @images = $article->images;
+ for my $img (@images) {
+ if (defined $img->{name} && lc $img->{name} eq lc $imageref) {
+ $errors{name} = 'Duplicate image name';
+ last;
+ }
+ }
+ }
+ else {
+ $errors{name} = 'Name must be empty or alphanumeric';
+ }
+ }
+ else {
+ $imageref = '';
+ }
+
my $image = $cgi->param('image');
- unless ($image) {
- return $self->edit_form($req, $article, $articles,
- 'Enter or select the name of an image file on your machine',
- { image => 'Please enter an image filename' });
+ if ($image) {
+ if (-z $image) {
+ $errors{image} = 'Image file is empty';
+ }
}
- if (-z $image) {
- return $self->edit_form($req, $article, $articles,
- 'Image file is empty',
- { image => 'Image file is empty' });
+ else {
+ $msg = 'Enter or select the name of an image file on your machine';
+ $errors{image} = 'Please enter an image filename';
+ }
+ if ($msg || keys %errors) {
+ return $self->edit_form($req, $article, $articles, $msg, \%errors);
}
+
my $imagename = $image;
$imagename .= ''; # force it into a string
my $basename = '';
height => $height,
url => $url,
displayOrder=>time,
+ name => $imageref,
);
require Images;
my @cols = Image->columns;
--- /dev/null
+package BSE::Formatter;
+use strict;
+
+use base 'DevHelp::Formatter';
+
+sub new {
+ my ($class, $gen, $acts, $articles, $rauto_images, $images) = @_;
+
+ my $self = $class->SUPER::new;
+
+ $self->{gen} = $gen;
+ $self->{acts} = $acts;
+ $self->{articles} = $articles;
+ $self->{auto_images} = $rauto_images;
+ $self->{images} = $images;
+ #$self->{level} = $level;
+
+ $self;
+}
+
+sub image {
+ my ($self, $args) = @_;
+
+ my $images = $self->{images};
+ my ($index, $align, $url) = split /\|/, $args, 3;
+ my $text = '';
+ my $im;
+ if ($index =~ /^\d+$/) {
+ if ($index >=1 && $index <= @$images) {
+ $im = $images->[$index-1];
+ }
+ }
+ elsif ($index =~ /^[a-z]\w*$/i){
+ # scan the names
+ for my $image (@$images) {
+ if ($image->{name} && lc $image->{name} eq lc $index) {
+ $im = $image;
+ last;
+ }
+ }
+ }
+ if ($im) {
+ $text = qq!<img src="/images/$im->{image}" width="$im->{width}"!
+ . qq! height="$im->{height}" alt="! . escape_html($im->{alt}).'"'
+ . qq! border="0"!;
+ $text .= qq! align="$align"! if $align && $align ne 'center';
+ $text .= qq! />!;
+ $text = qq!<div align="center">$text</div>!
+ if $align && $align eq 'center';
+ if (!$url && $im->{url}) {
+ $url = $im->{url};
+ }
+ if ($url) {
+ $text = qq!<a href="! . escape_html($url) . qq!">$text</a>!;
+ }
+ }
+ return $text;
+}
+
+sub embed {
+ my ($self, $name, $templateid, $maxdepth) = @_;
+
+ $self->{gen}->_embed_low($self->{acts}, $self->{articles}, $name,
+ $templateid, $maxdepth);
+}
+
+1;
id=>-1,
parentid=>0,
title=>'The site',
+ level => 0,
};
return $self->{sitearticle};
}
return $gen->generate(\%article, 'Articles');
}
+sub recipients {
+ my ($sub) = @_;
+
+ require 'SiteUsers.pm';
+ SiteUsers->getSpecial('subRecipients', $sub->{id});
+}
+
+sub recipient_count {
+ my ($sub) = @_;
+
+ my @rows = BSE::DB->query(subRecipientCount => $sub->{id});
+ $rows[0]{count};
+}
+
sub send {
my ($sub, $cfg, $opts, $callback) = @_;
- require 'SiteUsers.pm';
- my @recipients = SiteUsers->getSpecial('subRecipients', $sub->{id});
- $callback->(scalar(@recipients)." recipients to process");
+ my @recipients = $sub->recipients;
+ $callback->('general', undef, scalar(@recipients)." recipients to process");
require 'BSE/Mail.pm';
my $mailer = BSE::Mail->new(cfg=>$cfg);
my %article;
my $charset = $cfg->entry('basic', 'charset') || 'iso-8859-1';
my $index = 0;
for my $user (@recipients) {
- $callback->($user->{email}) if $callback;
+ $callback->('user', $user) if $callback;
my $text = $sub->_text_format_low($cfg, $user, $opts, \%article);
my $html;
if ($gen && !$user->{textOnlyMail}) {
subject =>$article{title},
headers =>join("\n", @headers, ""),
body =>$content)) {
- $callback->("Error: ".$mailer->errstr);
+ $callback->('error', $user, scalar($mailer->errstr));
}
++$index;
}
if (exists $opts->{archive} && $opts->{archive}
|| $sub->{archive}) {
- $callback->("Archiving article");
+ $callback->('general', undef, "Archiving article");
require 'Articles.pm';
$article{template} = $opts->{article_template} || $sub->{article_template};
$article{generator} = 'Generate::Article';
$article->save;
require 'Util.pm';
- $callback->("Generating article");
+ $callback->('general', undef, "Generating article");
Util::generate_article('Articles', $article, $cfg);
}
use BSE::Util::SQL qw/now_datetime/;
}
sub tag_error_img {
- my ($cfg, $errors, $args) = @_;
+ my ($cfg, $errors, $args, $acts, $func, $templater) = @_;
- return '' unless $errors->{$args};
+ my ($arg) = DevHelp::Tags->get_parms($args, $acts, $templater);
+ #print STDERR "name $arg\n";
+ return '' unless $errors->{$arg};
my $images_uri = $cfg->entry('uri', 'images', '/images');
- my $encoded = escape_html($errors->{$args});
+ my $encoded = escape_html($errors->{$arg});
return qq!<img src="$images_uri/admin/error.gif" alt="$encoded" title="$encoded" border="0" align="top" />!;
}
--- /dev/null
+package DevHelp::Formatter;
+use strict;
+use DevHelp::HTML;
+
+sub new {
+ my ($class) = @_;
+
+ return bless {}, $class;
+}
+
+sub embed {
+ '';
+}
+
+sub image {
+ my ($self, $imagename, $align) = @_;
+
+ return '';
+}
+
+sub replace {
+}
+
+sub _make_hr {
+ my ($width, $height) = @_;
+ my $tag = "<hr";
+ $tag .= qq! width="$width"! if length $width;
+ $tag .= qq! height="$height"! if length $height;
+ $tag .= " />";
+ return $tag;
+}
+
+# produces a table, possibly with options for the <table> and <tr> tags
+sub _make_table {
+ my ($options, $text) = @_;
+ my $tag = "<table";
+ my $cellend = '';
+ my $cellstart = '';
+ if ($options =~ /=/) {
+ $tag .= " " . $options;
+ }
+ elsif ($options =~ /\S/) {
+ $options =~ s/\s+$//;
+ my ($width, $bg, $pad, $fontsz, $fontface) = split /\|/, $options;
+ for ($width, $bg, $pad, $fontsz, $fontface) {
+ $_ = '' unless defined;
+ }
+ $tag .= qq! width="$width"! if length $width;
+ $tag .= qq! bgcolor="$bg"! if length $bg;
+ $tag .= qq! cellpadding="$pad"! if length $pad;
+ if (length $fontsz || length $fontface) {
+ $cellstart = qq!<font!;
+ $cellstart .= qq! size="$fontsz"! if length $fontsz;
+ $cellstart .= qq! face="$fontface"! if length $fontface;
+ $cellstart .= qq!>!;
+ $cellend = "</font>";
+ }
+ }
+ $tag .= ">";
+ my @rows = split '\n', $text;
+ my $maxwidth = 0;
+ for my $row (@rows) {
+ my ($opts, @cols) = split /\|/, $row;
+ $tag .= "<tr";
+ if ($opts =~ /=/) {
+ $tag .= " ".unescape_html($opts);
+ }
+ $tag .= "><td>$cellstart".join("$cellend</td><td>$cellstart", @cols)
+ ."$cellend</td></tr>";
+ }
+ $tag .= "</table>";
+ return $tag;
+}
+
+# make a UL
+sub _format_bullets {
+ my ($text) = @_;
+
+ $text =~ s/^\s+|\s+$//g;
+ my @points = split /(?:\r?\n)?\*\*\s*/, $text;
+ shift @points if @points and $points[0] eq '';
+ return '' unless @points;
+ for my $point (@points) {
+ $point =~ s!\n$!<br /><br />!;
+ }
+ return "<ul><li>".join("</li><li>", @points)."</li></ul>";
+}
+
+# make a OL
+sub _format_ol {
+ my ($text) = @_;
+ $text =~ s/^\s+|\s+$//g;
+ my @points = split /(?:\r?\n)?##\s*/, $text;
+ shift @points if @points and $points[0] eq '';
+ return '' unless @points;
+ for my $point (@points) {
+ $point =~ s!\n$!<br /><br />!;
+ }
+ return "<ol><li>".join("</li><li>", @points)."</li></ol>";
+}
+
+# raw html - this has some limitations
+# the input text has already been escaped, so we need to unescape it
+# too bad if you want [] in your html (but you can use entities)
+sub _make_html {
+ return unescape_html($_[0]);
+}
+
+sub _fix_spanned {
+ my ($start, $end, $text) = @_;
+
+ $text =~ s!(\n(?:[ \r]*\n)+)!$end$1$start!g;
+
+ "$start$text$end";
+}
+
+sub replace_char {
+ my ($self, $rpart) = @_;
+
+ $$rpart =~ s#link\[([^|\]\[]+)\|([^\]\[]+)\]#<a href="$1">$2</a>#ig
+ and return 1;
+ $$rpart =~ s#b\[([^\]\[]+)\]#_fix_spanned("<b>", "</b>", $1)#egi
+ and return 1;
+ $$rpart =~ s#i\[([^\]\[]+)\]#_fix_spanned("<i>", "</i>", $1)#egi
+ and return 1;
+ $$rpart =~ s#tt\[([^\]\[]+)\]#_fix_spanned("<tt>", "</tt>", $1)#egi
+ and return 1;
+ $$rpart =~ s#font\[([^|\]\[]+)\|([^\]\[]+)\]#
+ _fix_spanned(qq/<font size="$1">/, "</font>", $2)#egi
+ and return 1;
+ $$rpart =~ s#anchor\[([^|\]\[]*)\]#<a name="$1"></a>#ig
+ and return 1;
+ $$rpart =~ s#fontcolor\[([^|\]\[]+)\|([^\]\[]+)\|([^\]\[]+)\]#
+ _fix_spanned(qq/<font size="$1" color="$2">/, "</font>", $3)#egi
+ and return 1;
+
+ return 0;
+}
+
+sub format {
+ my ($self, $body) = @_;
+
+ $body = escape_html($body);
+ my $out = '';
+ for my $part (split /((?:html\[(?:[^\[\]]*(?:(?:\[[^\[\]]*\])[^\[\]]*)*)\])
+ |embed\[(?:[^,\[\]]*)(?:,(?:[^,\[\]]*)){0,2}\]
+ |pre\[(?:[^\[\]]*(?:(?:\[[^\[\]]*\])[^\[\]]*)*)\])/ix, $body) {
+ #print STDERR "Part is $part\n";
+ if ($part =~ /^html\[([^\[\]]*(?:(?:\[[^\[\]]*\])[^\[\]]*)*)\]$/i) {
+ $out .= _make_html($1);
+ }
+ elsif ($part =~ /^embed\[([^,\[\]]*),([^,\[\]]*),([^,\[\]]*)\]$/i) {
+ $out .= $self->embed($1, $2, $3);
+ }
+ elsif ($part =~ /^embed\[([^,\[\]]*),([^,\[\]]*)\]$/i) {
+ $out .= $self->embed($1, $2);
+ }
+ elsif ($part =~ /^embed\[([^,\[\]]*)\]$/i) {
+ $out .= $self->embed($1)
+ }
+ elsif ($part =~ /^pre\[([^\[\]]*(?:(?:\[[^\[\]]*\])[^\[\]]*)*)\]$/i) {
+ my $work = $1;
+ 1 while $self->replace_char(\$work);
+ $out .= $work;
+ }
+ else {
+ TRY: while (1) {
+ $self->replace(\$part)
+ and next TRY;
+ $self->replace_char(\$part)
+ and next TRY;
+ $part =~ s#pre\[([^\]\[]+)\]#<pre>$1</pre>#ig
+ and next TRY;
+ $part =~ s#h([1-6])\[\|([^\[\]]+)\](?:\r?\n)?#<h$1>$2</h$1>#ig
+ and next TRY;
+ $part =~ s#h([1-6])\[([^\[\]\|]+)\|([^\[\]]+)\](?:\r?\n)?#<h$1 class="$2">$3</h$1>#ig
+ and next TRY;
+ $part =~ s#align\[([^|\]\[]+)\|([^\]\[]+)\]#<div align="$1">$2</div>#ig
+ and next TRY;
+ $part =~ s#hr\[([^|\]\[]*)\|([^\]\[]*)\]#_make_hr($1, $2)#ieg
+ and next TRY;
+ $part =~ s#hr\[([^|\]\[]*)\]#_make_hr($1, '')#ieg
+ and next TRY;
+ $part =~ s#table\[([^\n\[\]]*)\n([^\[\]]+)\n\s*\]#_make_table($1, $2)#ieg
+ and next TRY;
+ $part =~ s#table\[([^\]\[]+)\|([^\]\[|]+)\]#_make_table($1, "|$2")#ieg
+ and next TRY;
+ $part =~ s#\n{0,2}((?:\*\*[^\n]+(?:\n|$)\n?[^\S\n]*)+)\n?#_format_bullets($1)#eg
+ and next TRY;
+ $part =~ s!\n{0,2}((?:##[^\n]+(?:\n|$)\n?[^\S\n]*)+)\n?!_format_ol($1)!eg
+ and next TRY;
+ $part =~ s#indent\[([^\]\[]+)\]#<ul>$1</ul>#ig
+ and next TRY;
+ $part =~ s#center\[([^\]\[]+)\]#<center>$1</center>#ig
+ and next TRY;
+ $part =~ s#hrcolor\[([^|\]\[]+)\|([^\]\[]+)\|([^\]\[]+)\]#<table width="$1" height="$2" border="0" bgcolor="$3" cellpadding="0" cellspacing="0"><tr><td><img src="/images/trans_pixel.gif" width="1" height="1" /></td></tr></table>#ig
+ and next TRY;
+ $part =~ s#image\[([^\]\[]+)\]# $self->image($1) #ige
+ and next TRY;
+ last;
+ }
+ $part =~ s!(\n([ \r]*\n)*)!$1 eq "\n" ? "<br />\n" : "</p>\n<p>"!eg;
+ #$part =~ s!\n!<br />!g;
+ $out .= $part;
+ }
+ }
+
+ return $out;
+}
+
+sub remove_format {
+ my ($self, $body) = @_;
+
+ if ($body =~ /^<html>/i) {
+ return _strip_html(substr($body, 6));
+ }
+
+ my $out = '';
+ for my $part (split /((?:html\[(?:[^\[\]]*(?:(?:\[[^\[\]]*\])[^\[\]]*)*)\])
+ |embed\[(?:[^,\[\]]*)(?:,(?:[^,\[\]]*)){0,2}\])/ix, $body) {
+ #print STDERR "Part is $part\n";
+ if ($part =~ /^html\[([^\[\]]*(?:(?:\[[^\[\]]*\])[^\[\]]*)*)\]$/i) {
+ $out .= _strip_html($1);
+ }
+ elsif ($part =~ /^embed\[([^,\[\]]*),([^,\[\]]*)\]$/i) {
+ $out .= ""; # what would you do here?
+ }
+ elsif ($part =~ /^embed\[([^,\[\]]*)\]$/i) {
+ $out .= "";
+ }
+ else {
+ TRY: while (1) {
+ $self->remove(\$part)
+ and next TRY;
+ $part =~ s#link\[([^|\]\[]+)\|([^\]\[]+)\]#$2#ig
+ and next TRY;
+ $part =~ s#([bi])\[([^\]\[]+)\]#$2#ig
+ and next TRY;
+ $part =~ s#align\[([^|\]\[]+)\|([^\]\[]+)\]#$2#ig
+ and next TRY;
+ $part =~ s#font\[([^|\]\[]+)\|([^\]\[]+)\]#$2#ig
+ and next TRY;
+ $part =~ s#hr\[([^|\]\[]*)\|([^\]\[]*)\]##ig
+ and next TRY;
+ $part =~ s#hr\[([^|\]\[]*)\]##ig
+ and next TRY;
+ $part =~ s#anchor\[([^|\]\[]*)\]##ig
+ and next TRY;
+ $part =~ s#table\[([^\n\[\]]*)\n([^\[\]]+)\n\s*\]#_cleanup_table($1, $2)#ieg
+ and next TRY;
+ $part =~ s#table\[([^\]\[]+)\|([^\]\[|]+)\]#_cleanup_table($1, "|$2")#ieg
+ and next TRY;
+ $part =~ s#\*\*([^\n]+)#$1#g
+ and next TRY;
+ $part =~ s!##([^\n]+)!$1!g
+ and next TRY;
+ $part =~ s#fontcolor\[([^|\]\[]+)\|([^\]\[]+)\|([^\]\[]+)\]#$3#ig
+ and next TRY;
+ $part =~ s#(?:indent|center)\[([^\]\[]*)\]#$1#ig
+ and next TRY;
+ $part =~ s#hrcolor\[([^|\]\[]+)\|([^\]\[]+)\|([^\]\[]+)\]##ig
+ and next TRY;
+ $part =~ s#image\[([^\]\[]+)\]##ig
+ and next TRY;
+
+ last TRY;
+ }
+ $out .= $part;
+ }
+ }
+
+ return $out;
+}
+
+sub remove {
+ 0;
+}
+
+# removes any html tags from the supplied text
+sub _strip_html {
+ my ($text) = @_;
+
+ my $out = '';
+ require HTML::Parser;
+
+ # this may need to detect and skip <script></script> and stylesheets
+ my $ignore_text = 0; # non-zero in a <script></script> or <style></style>
+ my $start_h =
+ sub {
+ ++$ignore_text if $_[0] eq 'script' or $_[0] eq 'style';
+ if ($_[0] eq 'img' && $_[1]{alt} && !$ignore_text) {
+ $out .= $_[1]{alt};
+ }
+ };
+ my $end_h =
+ sub {
+ --$ignore_text if $_[0] eq 'script' or $_[0] eq 'style';
+ };
+ my $text_h =
+ sub {
+ $out .= $_[0] unless $ignore_text
+ };
+ my $p = HTML::Parser->new( text_h => [ $text_h, "dtext" ],
+ start_h => [ $start_h, "tagname, attr" ],
+ end_h => [ $end_h, "tagname" ]);
+ $p->parse($text);
+ $p->eof();
+
+ $text = $out;
+
+ return $text;
+}
+
+# this takes the same inputs as _make_table(), but eliminates any
+# markup instead
+sub _cleanup_table {
+ my ($opts, $data) = @_;
+ my @lines = split /\n/, $data;
+ for (@lines) {
+ s/^[^|]*\|//;
+ tr/|/ /s;
+ }
+ return join(' ', @lines);
+}
+
+1;
print STDERR "** Entered get_parms -$args-\n" if DEBUG_GET_PARMS;
my @out;
while ($args) {
- if ($args =~ s/^\s*\[\s*(\w+)(?:\s+(\S[^\]]*))?\]\s*//) {
+ if ($args =~ s/^\s*\[\s*(\w+)
+ (
+ (?:\s+
+ (?:
+ [^\s\[\]]\S*
+ |
+ \[[^\]\[]+?\]
+ )
+ )*
+ )
+ \s*\]\s*//x) {
my ($func, $subargs) = ($1, $2);
$subargs = '' unless defined $subargs;
if ($acts->{$func}) {
return substr($body, 6) if $body =~ /^<html>/i;
- # clean up any possible existing markup
- $body = escape_html($body);
-
- # I considered replacing these with single character codes and replacing
- # them later with the tags, to avoid having to check for the middle of
- # tag in the image tag insertion code
- #
- # This wouldn't work because we still need to do the entity substitution
- # before
-
+ require BSE::Formatter;
- # originally the following was just one big loop of replacements, but
- # some tags are a little more complex
- # This needs a real parser
+ my $formatter = BSE::Formatter->new($self, $acts, $articles, \$auto_images,
+ \@images);
- my $out = '';
- for my $part (split /((?:html\[(?:[^\[\]]*(?:(?:\[[^\[\]]*\])[^\[\]]*)*)\])
- |embed\[(?:[^,\[\]]*)(?:,(?:[^,\[\]]*)){0,2}\])/ix, $body) {
- #print STDERR "Part is $part\n";
- if ($part =~ /^html\[([^\[\]]*(?:(?:\[[^\[\]]*\])[^\[\]]*)*)\]$/i) {
- $out .= _make_html($1);
- }
- elsif ($part =~ /^embed\[([^,\[\]]*),([^,\[\]]*),([^,\[\]]*)\]$/i) {
- $out .= $self->_body_embed($acts, $articles, $1, $2, $3);
- }
- elsif ($part =~ /^embed\[([^,\[\]]*),([^,\[\]]*)\]$/i) {
- $out .= $self->_body_embed($acts, $articles, $1, $2);
- }
- elsif ($part =~ /^embed\[([^,\[\]]*)\]$/i) {
- $out .= $self->_body_embed($acts, $articles, $1, "")
- }
- else {
- my $match;
- TRY: while (1) {
- $match = 0;
- $LOCAL_FORMAT and $LOCAL_FORMAT->body(\$part)
- and next TRY;
- $part =~ s#a\[([^,\]\[]+),([^\]\[]+)\]#<a href="$1">$2</a>#ig
- and next TRY;
- $part =~ s#link\[([^|\]\[]+)\|([^\]\[]+)\]#<a href="$1">$2</a>#ig
- and next TRY;
- $part =~ s#b\[([^\]\[]+)\]#<b>$1</b>#ig
- and next TRY;
- $part =~ s#i\[([^\]\[]+)\]#<i>$1</i>#ig
- and next TRY;
- $part =~ s#tt\[([^\]\[]+)\]#<tt>$1</tt>#ig
- and next TRY;
- $part =~ s#pre\[([^\]\[]+)\]#<pre>$1</pre>#ig
- and next TRY;
- $part =~ s#h([1-6])\[\|([^\[\]]+)\](?:\r?\n)?#<h$1>$2</h$1>#ig
- and next TRY;
- $part =~ s#h([1-6])\[([^\[\]\|]+)\|([^\[\]]+)\](?:\r?\n)?#<h$1 class="$2">$3</h$1>#ig
- and next TRY;
- $part =~ s#align\[([^|\]\[]+)\|([^\]\[]+)\]#<div align="$1">$2</div>#ig
- and next TRY;
- $part =~ s#font\[([^|\]\[]+)\|([^\]\[]+)\]#<font size="$1">$2</font>#ig
- and next TRY;
- $part =~ s#hr\[([^|\]\[]*)\|([^\]\[]*)\]#_make_hr($1, $2)#ieg
- and next TRY;
- $part =~ s#hr\[([^|\]\[]*)\]#_make_hr($1, '')#ieg
- and next TRY;
- $part =~ s#anchor\[([^|\]\[]*)\]#<a name="$1"></a>#ig
- and next TRY;
- $part =~ s#table\[([^\n\[\]]*)\n([^\[\]]+)\n\s*\]#_make_table($1, $2)#ieg
- and next TRY;
- $part =~ s#table\[([^\]\[]+)\|([^\]\[|]+)\]#_make_table($1, "|$2")#ieg
- and next TRY;
- $part =~ s#\n{0,2}((?:\*\*[^\n]+(?:\n|$)\n?[^\S\n]*)+)\n?#_format_bullets($1)#eg
- and next TRY;
- $part =~ s!\n{0,2}((?:##[^\n]+(?:\n|$)\n?[^\S\n]*)+)\n?!_format_ol($1)!eg
- and next TRY;
- $part =~ s#fontcolor\[([^|\]\[]+)\|([^\]\[]+)\|([^\]\[]+)\]#<font size="$1" color="$2">$3</font>#ig
- and next TRY;
- $part =~ s#indent\[([^\]\[]+)\]#<ul>$1</ul>#ig
- and next TRY;
- $part =~ s#center\[([^\]\[]+)\]#<center>$1</center>#ig
- and next TRY;
- $part =~ s#hrcolor\[([^|\]\[]+)\|([^\]\[]+)\|([^\]\[]+)\]#<table width="$1" height="$2" border="0" bgcolor="$3" cellpadding="0" cellspacing="0"><tr><td><img src="/images/trans_pixel.gif" width="1" height="1" /></td></tr></table>#ig
- and next TRY;
- $part =~ s#image\[([^\]\[]+)\]#($auto_images = 0), _make_img($1, \$imagePos, \@images)#ige
- and next TRY;
- $part =~ s#class\[([^\]\[\|]+)\|([^\]\[]+)\]#<span class="$1">$2</span>#ig
- and next TRY;
-
- last;
- }
- $part =~ s!\n([ \r]*\n)+!</p><p>!g;
- $part =~ s/\n/<br \/>/g;
- $out .= $part;
- }
- }
- $body = $out;
+ $body = $formatter->format($body);
if ($auto_images && @images) {
# the first image simply goes where we're told to put it
substr($body, $workpos, 0) = <<IMG;
<img src="/images/$image->{image}" width="$image->{width}" height="$image->{height}"
-border="0" alt="$image->{alt}" align="$align" hspace="10" vspace="10">
+border="0" alt="$image->{alt}" align="$align" hspace="10" vspace="10" />
IMG
$pos -= $incr;
$align = $align eq 'right' ? 'left' : 'right';
return BSE::Template->replace($template, $self->{cfg}, \%acts);
}
+sub _format_image {
+ my ($im, $align, $rest) = @_;
+
+ if ($align && exists $im->{$align}) {
+ return escape_html($im->{$align});
+ }
+ else {
+ my $html = qq!<img src="/images/$im->{image}" width="$im->{width}"!
+ . qq! height="$im->{height}" alt="! . escape_html($im->{alt})
+ . qq!"!;
+ $html .= qq! align="$align"! if $align && $align ne '-';
+ unless (defined($rest) && $rest =~ /\bborder=/i) {
+ $html .= ' border="0"';
+ }
+ $html .= " $rest" if defined $rest;
+ $html .= qq! />!;
+ if ($im->{url}) {
+ $html = qq!<a href="$im->{url}">$html</a>!;
+ }
+ return $html;
+ }
+}
+
+sub tag_title {
+ my ($article, $images, $args, $acts, $funcname, $templater) = @_;
+
+ my $which = $args || 'article';
+
+ exists $acts->{$which}
+ or return "** no such object $which **";
+
+ my $title = $acts->{$which}->('title');
+ my $imagename = $which eq 'article' ? $article->{titleImage} :
+ $acts->{$which}->('titleImage');
+ $imagename and
+ return qq!<img src="/images/titles/$imagename"!
+ .qq! border="0" alt="$title" />! ;
+ my $im;
+ if ($which eq 'article') {
+ ($im) = grep lc $_->{name} eq 'bse_title', @$images;
+ }
+ else {
+ my $id = $acts->{$which}->('id');
+ require Images;
+ my @images = Images->getBy(articleId=>$id);
+ ($im) = grep lc $_->{name} eq 'bse_title', @$images;
+ }
+
+ if ($im) {
+ return qq!<img src="/images/$im->{image}" width="$im->{width}"!
+ . qq! height="$im->{height}" alt="$title" />!;
+ }
+ else {
+ return $title;
+ }
+}
+
sub baseActs {
my ($self, $articles, $acts, $article, $embedded) = @_;
# used to generate a navigation list for the article
# generate a list of ancester articles/sections
- # jason calls these breadcrumbs
+ # Jason calls these breadcrumbs
my @crumbs;
my @ancestors;
my $temp = $article;
my $which = shift || 'article';
return $acts->{$which} && $acts->{$which}->('titleImage')
},
- title =>
- sub {
- my $which = shift || 'article';
- $acts->{$which} && $acts->{$which}->('titleImage')
- ? qq!<img src="/images/titles/!.$acts->{$which}->('titleImage')
- .qq!" border="0" />!
- : $acts->{$which}->('title');
- },
+ title => [ \&tag_title, $article, \@images ],
thumbnail =>
sub {
my ($which, $class) = split ' ', $_[0];
else {
$im = $images[$image_index];
}
- my $html;
- if ($align && exists $im->{$align}) {
- $html = escape_html($im->{$align});
- }
- else {
- $html = qq!<img src="/images/$im->{image}" width="$im->{width}"!
- . qq! height="$im->{height}" alt="! . escape_html($im->{alt})
- . qq!"!;
- $html .= qq! align="$align"! if $align && $align ne '-';
- unless (defined($rest) && $rest =~ /\bborder=/i) {
- $html .= ' border="0"';
- }
- $html .= " $rest" if defined $rest;
- $html .= qq! />!;
- if ($im->{url}) {
- $html = qq!<a href="$im->{url}">$html</a>!;
- }
- }
- return $html;
+
+ return _format_image($im, $align, $rest);
+ },
+ imagen =>
+ sub {
+ my ($name, $align, $rest) = split ' ', $_[0], 3;
+
+ $had_image_tags = 1;
+ my ($im) = grep lc $name eq lc $_->{name}, @images
+ or return '';
+
+ _format_image($im, $align, $rest);
},
ifImage => sub { $_[0] >= 1 && $_[0] <= @images },
ifImages => sub { @images },
@ISA = qw/Squirrel::Row/;
sub columns {
- return qw/id articleId image alt width height url displayOrder/;
+ return qw/id articleId image alt width height url displayOrder name/;
}
1;
=head1 CHANGES
+=head2 0.13_01
+
+Time to get a little adventurous.
+
+=over
+
+=item *
+
+images can now have an identifier associated with them. This can be
+used by the body text image[] tag to reference an image by name.
+
+=item *
+
+the C<< <:imagen >> I<imagename> I<alignment> I<rest> C<< :> >> tag
+can be used to insert images by name.
+
+=item *
+
+body text formatting is now based on the DevHelp::Formatter module.
+
+=item *
+
+b[], i[], tt[], font[], fontcolor[] over paragraph breaks are now
+closed properly at the paragraph breaks.
+
+=item *
+
+newlines within pre[] are no-longer converted to paragraph or line
+breaks. As a consequence of this you can't nest character formatting
+within each other within pre[text], ie pre[b[foo]] is ok, but
+pre[b[i[foo]]] won't work.
+
+=item *
+
+the width and height parameters to the hr[] markup weren't handled
+correctly.
+
+=item *
+
+the row options to the table[] tag were inserted HTML escaped, so:
+
+ tr[...
+ bgcolor="black"|col|...
+ ]
+
+produced a tr tag like:
+
+ <tr bgcolor="black">...
+
+=item *
+
+list items in ** or ## lists are now closed with </li>
+
+=item *
+
+we now put newlines between lines and paragraphs in the output of
+formatted text, hopefully this will make it easier to read the source.
+
+=item *
+
+<:error_img:> now accepts a [...] format expression to get the field
+name
+
+=item *
+
+the <:recipient_count:> tag is now available on the subscription
+listing page. This is used for display, and to hide the Send option
+if the subscription has no recipients.
+
+=item *
+
+it's now possible to format the output of the subscription send
+process by changing the C<admin/subs/sending.tmpl> template
+
+=item *
+
+if an article has an image with an identifier of C<bse_title> then it
+will be used as the title image for the article.
+
+=item *
+
+you should be able to use one level of nested [] inside [] expressions
+in tags now
+
+=back
+
=head2 0.13
No changes since 0.12_31.
</div>
+<div>
+ <h2><a name="name"></a>Identifier</h2>
+
+<p>This can be used to retrieve an article image by name with either
+body markup or in templatess. This can be either empty, or start with
+a letter and contain only letters and number. Each image name for an
+article must be unique to that article.</p>
+
+<p>The special identifier <code>bse_title</code> will treat the image
+as an article title image, ie. the image will be displayed instead of
+the title of the image.</p>
+
+</div>
+
<div>
<h2><a name="position"></a>First image position</h2>
"image[<i>index</i>]".</p>
</div>
-
</body></html>
\ No newline at end of file
</td>
<td nowrap bgcolor="#FFFFFF"><:help image url:> <:error_img url:></td>
</tr>
+ <tr>
+ <th bgcolor="#FFFFFF" align="left">Identifier for image:</th>
+ <td bgcolor="#FFFFFF">
+ <input type="text" name="name" value="<:old name:>">
+ </td>
+ <td nowrap bgcolor="#FFFFFF"><:help image name:> <:error_img name:></td>
+ </tr>
<tr>
<td bgcolor="#FFFFFF" colspan="3" align="right">
<input type="submit" name="addimg" value="Add Image">
<td>
<table width="100%" border="0" cellpadding="6" cellspacing="1">
<:if Images:><tr>
- <th valign="top" bgcolor="#FFFFFF" colspan="4">First Image Position</th>
+ <th valign="top" bgcolor="#FFFFFF" colspan="5">First Image Position</th>
</tr>
<tr>
- <td bgcolor="#FFFFFF" colspan="4">
+ <td bgcolor="#FFFFFF" colspan="5">
<table width="100%" border="0" cellspacing="0" cellpadding="0">
<tr>
<td width="100%" align="center"><input type="radio" name="imagePos" value="tl" <: ifEq [article imagePos] "tl":>checked<:or:><:eif:>
</td>
</tr>
<tr bgcolor="#FFFFFF">
- <th colspan="4">Image</th>
+ <th colspan="5">Image</th>
</tr>
<: iterator begin images :>
<tr bgcolor="#FFFFFF">
- <td align="center" colspan="
4"> <img src="/images/<: image image :>" alt="<: image alt :>" width="<:
+ <td align="center" colspan="
5"> <img src="/images/<: image image :>" alt="<: image alt :>" width="<:
image width :>" height="<: image height :>"></td>
</tr>
<tr bgcolor="#FFFFFF">
<th> Alt Text</th>
<th width="50%"> URL</th>
+ <th> Identifier</th>
<th nowrap> Modify</th>
<th nowrap> Move</th>
</tr>
<td valign="top" width="50%">
<:ifUserCan edit_images_save:article:><input type="text" name="url" value="<: image url :>" size="32"><:or:><: image url :><:eif:>
</td>
+ <td valign="top" nowrap>
+ <:ifUserCan edit_images_save:article:><input type="text" name="name<:image_index:>" value="<: image name :>" size="32"> <:error_img [concatenate "name" [image_index] ]:><:or:><: image name :><:eif:>
+ </td>
<td valign="bottom" nowrap>
<:ifUserCan edit_images_delete:article:><b><a href="<:script:>?id=<:article id:>&removeimg_<: image id :>=1&_t=img" onClick="return window.confirm('Are you sure you want to delete this Image')">Delete</a></b><:or:><:eif:></td>
<td><:imgmove:></td>
</tr>
<: iterator separator images :>
<tr bgcolor="#FFFFFF">
- <td colspan="4"> </td>
+ <td colspan="5"> </td>
</tr>
<: iterator end images :>
<:ifUserCan edit_images_save:article:>
<tr>
- <td align="right" bgcolor="#FFFFFF" colspan="4">
+ <td align="right" bgcolor="#FFFFFF" colspan="5">
<input type="submit" name="process" value="Save changes">
</td>
</tr>
<:or:><:eif:>
- <:or Images:><tr><td colspan="4" align="center" bgcolor="#FFFFFF">No images
+ <:or Images:><tr><td colspan="5" align="center" bgcolor="#FFFFFF">No images
are attached to this article</td>
</tr><:eif Images:>
</table>
<:ifMessage:><p><b><:message:></b></p><:or:><:eif:>
-<p>| <a href="/admin/">Admin menu</a> |</p>
+<p>| <a href="/cgi-bin/admin/menu.pl">Admin menu</a> |</p>
<table border="0" cellspacing="0" cellpadding="0" bgcolor="#000000" class="table">
<tr>
<th>Frequency</th>
<th>Visible</th>
<th>Last published</th>
+ <th># Recipients</th>
<th>Modify</th>
</tr>
<:if Subscriptions:>
<td><:subscription frequency:></td>
<td align="center"><:ifSubscription visible:>Yes<:or:>No<:eif:></td>
<td align="center"><:ifMatch [subscription lastSent] "0000-00-00":>Never<:or:><:date subscription lastSent:><:eif:></td>
+ <td align="center"><:recipient_count:></td>
<td nowrap> <:ifUserCan subs_edit:><a href="<:script:>?edit=1&id=<:subscription id:>"><b>Edit</b></a> <:or:><:eif:>
<:ifUserCan subs_delete:><a href="<:script:>?delconfirm=1&id=<:subscription id:>"><b>Delete</b></a> <:or:><:eif:>
- <:if
UserCan subs_send:><a href="<:script:>?start_send=1&id=<:subscription id:>"><b>Send</b></a> <:or:><:eif:>
+ <:if
And [ifUserCan subs_send] [recipient_count]:><a href="<:script:>?start_send=1&id=<:subscription id:>"><b>Send</b></a> <:or:><:eif:>
</td>
</tr>
<:iterator end subscriptions:>
<:or Subscriptions:>
<tr bgcolor="#FFFFFF">
- <td colspan="6" align="center">You don't have any subscriptions defined</td>
+ <td colspan="7" align="center">You don't have any subscriptions defined</td>
</tr>
<:eif Subscriptions:>
</table>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+
+ <title>Administration - Subscriptions Manager</title>
+
+ <link rel="stylesheet" type="text/css" href="/css/admin.css" />
+
+</head>
+
+<body>
+
+<h1>Sending Subscription <:subscription name:></h1>
+
+<p>Hitting Stop, your browser Back button, or Refresh on this page may
+result in incomplete, or duplicate transmissions.</p>
+
+<ul>
+<:iterator begin messages:>
+<:if Error:>
+<li><b><:message:> sending to <:user email:></b></li>
+<:or Error:>
+<:if User:>
+<li>Sending to: <:user email:></li>
+<:or User:>
+<li><:message:></li>
+<:eif User:>
+<:eif Error:>
+<:iterator end messages:>
+</ul>
+
+<p>| <a href="/cgi-bin/admin/menu.pl">Admin menu</a> |</p>
+
+<p><font size="-1">BSE Release <:release:></font></p>
+</body>
+</html>
--- /dev/null
+#!perl -w
+use strict;
+use Test::More tests => 36;
+
+sub format_test($$$;$);
+
+my $gotmodule = require_ok('DevHelp::Formatter');
+
+SKIP: {
+ skip "couldn't load module", 35 unless $gotmodule;
+
+ format_test <<IN, <<OUT, 'bold', 'both';
+b[hello]
+IN
+<b>hello</b>
+OUT
+ format_test 'i[hello]', '<i>hello</i>', 'italic';
+ format_test 'b[i[hello]]', '<b><i>hello</i></b>', 'bold/italic';
+ format_test <<IN, <<OUT, 'bold over lines', 'both';
+b[hello
+foo]
+IN
+<b>hello<br />
+foo</b>
+OUT
+ format_test <<IN, <<OUT, 'bold over paras', 'both';
+b[hello
+
+foo]
+IN
+<b>hello</b></p>
+<p><b>foo</b>
+OUT
+ format_test <<IN, <<OUT, 'combo over paras', 'both';
+i[b[hello
+
+foo
+
+bar]]
+IN
+<i><b>hello</b></i></p>
+<p><i><b>foo</b></i></p>
+<p><i><b>bar</b></i>
+OUT
+ format_test <<IN, <<OUT, 'link', 'both';
+link[http://foo/|bar]
+IN
+<a href="http://foo/">bar</a>
+OUT
+ format_test 'tt[hello]', '<tt>hello</tt>', 'tt';
+ format_test 'font[-1|text]', '<font size="-1">text</font>', 'fontsize';
+ format_test 'fontcolor[-1|black|text]', '<font size="-1" color="black">text</font>', 'fontsizecolor';
+ format_test 'anchor[somename]', '<a name="somename"></a>', 'anchor';
+ format_test <<IN, <<OUT, 'pre', 'both';
+pre[hello there
+Joe]
+IN
+hello there
+Joe
+OUT
+ format_test <<IN, <<OUT, 'pre with bold', 'both';
+pre[b[hello there
+
+Joe]]
+IN
+<b>hello there</b>
+
+<b>Joe</b>
+OUT
+ format_test <<IN, <<OUT, 'html', 'both';
+html[<object foo="bar" />]
+IN
+<object foo="bar" />
+OUT
+
+ format_test 'embed[foo]', '', 'embed1';
+ format_test 'embed[foo,bar]', '', 'embed2';
+ format_test 'embed[foo,bar,quux]', '', 'embed3';
+ format_test 'h1[|text]', '<h1>text</h1>', 'h1';
+ format_test 'h1[someclass|text]', '<h1 class="someclass">text</h1>', 'h1class';
+ format_test 'h6[|te>xt]', '<h6>te>xt</h6>', 'h6';
+ format_test 'align[left|some text]', '<div align="left">some text</div>', 'align';
+ format_test 'hr[]', '<hr />', 'hr0';
+ format_test 'hr[80%]', '<hr width="80%" />', 'hr1';
+ format_test 'hr[80%|10]', '<hr width="80%" height="10" />', 'hr2';
+ format_test <<IN, <<OUT, 'table1', 'both';
+table[80%
+bgcolor="black"|quux|blarg
+|hello|there
+]
+IN
+<table width="80%"><tr bgcolor="black"><td>quux</td><td>blarg</td></tr><tr><td>hello</td><td>there</td></tr></table>
+OUT
+ format_test <<IN, <<OUT, 'table2', 'both';
+table[80%|#808080|2|2|Arial
+bgcolor="black"|quux|blarg
+|hello|there
+]
+IN
+<table width="80%" bgcolor="#808080" cellpadding="2"><tr bgcolor="black"><td><font size="2" face="Arial">quux</font></td><td><font size="2" face="Arial">blarg</font></td></tr><tr><td><font size="2" face="Arial">hello</font></td><td><font size="2" face="Arial">there</font></td></tr></table>
+OUT
+ format_test <<IN, <<OUT, 'table3', 'both';
+table[80%|foo]
+IN
+<table width="80%"><tr><td>foo</td></tr></table>
+OUT
+ format_test <<IN, <<OUT, 'ol1', 'both';
+## one
+## two
+IN
+<ol><li>one</li><li>two</li></ol>
+OUT
+ format_test <<IN, <<OUT, 'ol2', 'both';
+## one
+
+## two
+IN
+<ol><li>one<br /><br /></li><li>two</li></ol>
+OUT
+ format_test <<IN, <<OUT, 'ul1', 'both';
+** one
+** two
+IN
+<ul><li>one</li><li>two</li></ul>
+OUT
+ format_test <<IN, <<OUT, 'ul2', 'both';
+** one
+
+** two
+IN
+<ul><li>one<br /><br /></li><li>two</li></ul>
+OUT
+
+ format_test 'indent[text]', '<ul>text</ul>', 'indent';
+ format_test 'center[text]', '<center>text</center>', 'center';
+ format_test 'hrcolor[80|10|#FF0000]', <<OUT, 'hrcolor', 'out';
+<table width="80" height="10" border="0" bgcolor="#FF0000" cellpadding="0" cellspacing="0"><tr><td><img src="/images/trans_pixel.gif" width="1" height="1" /></td></tr></table>
+OUT
+ format_test 'image[foo]', '', 'image';
+}
+
+sub format_test ($$$;$) {
+ my ($in, $out, $desc, $stripnl) = @_;
+
+ $stripnl ||= 'none';
+ $in =~ s/\n$// if $stripnl eq 'in' || $stripnl eq 'both';
+ $out =~ s/\n$// if $stripnl eq 'out' || $stripnl eq 'both';
+
+ my $formatter = DevHelp::Formatter->new;
+
+ my $result = $formatter->format($in);
+
+ is($result, $out, $desc);
+}
<:concatenate one two:>
<:concatenate one "two " three:>
<:concatenate one [concatenate "two " three]:>
+<:concatenate [concatenate "one" [concatenate "two" "three"]]:>
TEMPLATE
onetwo
onetwo three
onetwo three
+onetwothree
EXPECTED
template_test "match", $top, <<'TEMPLATE', <<EXPECTED;
projects / bse.git / commitdiff