AUBBC
view release on metacpan or search on metacpan
highlight_class9 => '',
);
my @security_levels = ('Guest', 'User', 'Moderator','Administrator');
my ($user_level, $high_level, $user_key) = ('Guest', 3, 0);
my %Tag_SecLVL = (
code => { level => 0, text => $BAD_MESSAGE, },
img => { level => 0, text => $BAD_MESSAGE, },
url => { level => 0, text => $BAD_MESSAGE, },
);
sub security_levels {
my ($self,@s_levels) = @_;
$do_f[10] = 0;
@s_levels
? @security_levels = @s_levels
: return @security_levels;
}
sub user_level {
my ($self,$u_level) = @_;
$do_f[10] = 0;
defined $u_level
? $user_level = $u_level
: return $user_level;
}
sub tag_security {
my ($self,%s_tags) = @_;
%s_tags
? %Tag_SecLVL = %s_tags
: return %Tag_SecLVL;
}
sub check_access {
my $tag = shift;
unless ($do_f[10]) {
$do_f[10] = 1;
($high_level, $user_key) = (scalar(@security_levels), 0);
for(my $i = 0; $i < $high_level;) {
if ($security_levels[$i] eq $user_level) {
$user_key = $i;
last;
}
}
}
if (defined $tag && $do_f[10]) {
$user_key >= $Tag_SecLVL{$tag}{level}
? return 1
: return '';
}
}
sub new {
warn 'CREATING AUBBC '.$VERSION if $DEBUG_AUBBC;
if ($MEMOIZE && ! $do_f[7]) {
$do_f[7] = 1;
eval 'use Memoize' if ! defined $Memoize::VERSION;
unless ($@ || ! defined $Memoize::VERSION) {
Memoize::memoize('AUBBC::settings');
Memoize::memoize('AUBBC::smiley_hash');
Memoize::memoize('AUBBC::add_build_tag');
Memoize::memoize('AUBBC::do_all_ubbc');
Memoize::memoize('AUBBC::script_escape');
Memoize::memoize('AUBBC::html_to_text');
}
$aubbc_error .= $@."\n" if $@;
}
return bless {};
}
sub DESTROY {
warn 'DESTROY AUBBC '.$VERSION if $DEBUG_AUBBC;
}
sub settings_prep {
$AUBBC{href_target} = $AUBBC{href_target} ? ' target="_blank"' : '';
$AUBBC{image_wrap} = $AUBBC{image_wrap} ? ' ' : '';
$AUBBC{image_border} = $AUBBC{image_border} ? '1' : '0';
$AUBBC{html_type} = $AUBBC{html_type} eq 'xhtml' || $AUBBC{html_type} eq ' /' ? ' /' : '';
}
sub settings {
my ($self,%s_hash) = @_;
foreach (keys %s_hash) {
if ('highlight_function' eq $_) {
$AUBBC{highlight} = 0;
$s_hash{$_} = check_subroutine($s_hash{$_},'');
$AUBBC{highlight_function} = $s_hash{$_} unless ! $s_hash{$_};
} else {
$AUBBC{$_} = $s_hash{$_};
}
}
&settings_prep;
if ($DEBUG_AUBBC) {
my $uabbc_settings = '';
$uabbc_settings .= $_ . ' =>' . $AUBBC{$_} . ', ' foreach keys %AUBBC;
warn 'AUBBC Settings Change: '.$uabbc_settings;
}
}
sub get_setting {
my ($self,$name) = @_;
return $AUBBC{$name} if exists $AUBBC{$name};
}
sub code_highlight {
my $txt = shift;
warn 'ENTER code_highlight' if $DEBUG_AUBBC;
$txt =~ s/:/:/g;
$txt =~ s/\[/[/g;
$txt =~ s/\]/]/g;
$txt =~ s/\000[/[[/g;
$txt =~ s/\000]/]]/g;
$txt =~ s/\{/{/g;
$txt =~ s/\}/}/g;
$txt =~ s/%/%/g;
$txt =~ s/('(?s).*?(?<!\)')/<span$AUBBC{highlight_class3}>$1<\/span>/g;
$txt =~ s/("(?s).*?(?<!\)")/<span$AUBBC{highlight_class4}>$1<\/span>/g;
$txt =~ s/(?<![\#|\w])(\d+)(?!\w)/<span$AUBBC{highlight_class5}>$1<\/span>/g;
$txt =~
s/(|||&&|\b(?:strict|package|return|require|for|my|sub|if|eq|ne|lt|ge|le|gt|or|xor|use|while|foreach|next|last|unless|elsif|else|not|and|until|continue|do|goto)\b)/<span$AUBBC{highlight_class6}>$1<\/span>/g;
$txt =~ s/(?<!\)((?:%|\$|\@)\w+(?:(?:[.+?]|{.+?})+|))/<span$AUBBC{highlight_class7}>$1<\/span>/g;
}
return $txt;
}
sub code_download {
if ($AUBBC{code_download}) {
$do_f[8]++;
$do_f[9] =
make_link('javascript:void(0)',$AUBBC{code_download}, "javascript:MyCodePrint('aubbcode$do_f[8]');",'');
return " id=\"aubbcode$do_f[8]\"";
} else { return ''; }
}
sub code_tag {
my ($code,$name) = @_;
if (check_access('code')) {
$name = "# $name:<br$AUBBC{html_type}>\n" if $name;
return "$name<div$AUBBC{code_class}".&code_download."><code>\n".
$AUBBC{highlight_function}->($code).
"\n</code></div>".$AUBBC{code_extra}.$do_f[9];
}
else {
return $Tag_SecLVL{code}{text};
}
}
sub make_image {
my ($align,$src,$width,$height,$alt) = @_;
my $img = "<img$align src=\"$src\"";
$img .= " width=\"$width\"" if $width;
$img .= " height=\"$height\"" if $height;
return $img." alt=\"$alt\" border=\"$AUBBC{image_border}\"$AUBBC{html_type}>";
}
sub make_link {
my ($link,$name,$javas,$targ) = @_;
my $linkd = "<a href=\"$link\"";
$linkd .= " onclick=\"$javas\"" if $javas;
$linkd .= $AUBBC{href_target} if $targ;
$linkd .= $AUBBC{href_class}.'>';
$linkd .= $name ? $name : $link;
return $linkd.'</a>';
}
sub do_ubbc {
warn 'ENTER do_ubbc' if $DEBUG_AUBBC;
$msg =~ s/\[(?:c|code)\](?s)(.+?)\[\/(?:c|code)\]/code_tag($1, '')/ge;
$msg =~ s/\[(?:c|code)=(.+?)\](?s)(.+?)\[\/(?:c|code)\]/code_tag($2, $1)/ge;
$do_f[9] = '' if $do_f[9];
$msg =~ s/\[(img|right_img|left_img)\](.+?)\[\/img\]/fix_image($1, $2)/ge if ! $AUBBC{no_img};
$msg =~ s/\[email\](?![\w\.\-\&\+]+\@[\w\.\-]+).+?\[\/email\]/\[<font color=red>$BAD_MESSAGE<\/font>\]email/g;
$AUBBC{protect_email}
? $msg =~ s/\[email\]([\w\.\-\&\+]+\@[\w\.\-]+)\[\/email\]/protect_email($1)/ge
1 while $msg =~
s/\[(blockquote|big|h[123456]|[ou]l|li|em|pre|s(?:mall|trong|u[bp])|[bip])\](?s)(.+?)\[\/\1\]/<$1>$2<\/$1>/g;
$msg =~ s/(<\/?(?:ol|ul|li|hr)\s?\/?>)\r?\n?<br(?:\s?\/)?>/$1/g;
$msg =~ s/\[url=(\w+\:\/\/$long_regex)\](.+?)\[\/url\]/link_check($1,fix_message($2),'',1)/ge;
$msg =~ s/(?<!["=\.\/\'\[\{\;])((?:\b\w+\b\:\/\/)$long_regex)/link_check($1,$1,'',1)/ge;
}
sub link_check {
my ($link,$name,$javas,$targ) = @_;
check_access('url')
? make_link($link,$name,$javas,$targ)
: return $Tag_SecLVL{url}{text};
}
sub fix_list {
my $list = shift;
if ($list =~ m/\[\*/) {
$list =~ s/<br$AUBBC{html_type}>//g;
my $type = 'ul';
$type = 'ol' if $list =~ s/\[\*=(\d+)\]/\[\*\]$1\|/g;
my @clean = split('\[\*\]', $list);
$list = "<$type>\n";
foreach (@clean) {
if ($_ && $_ =~ s/\A(\d+)\|(?s)(.+?)/$2/) {
$list .= "<li value=\"$1\">$_<\/li>\n" if $_ !~ m/\A\r?\n?\z/;
} elsif ($_ && $_ !~ m/\A\s+|\d+\|\r?\n?\z/) {
$list .= "<li>$_<\/li>\n";
}
}
$list .= "<\/$type>";
}
return $list;
}
sub fix_image {
my ($tmp2, $tmp) = @_;
if (check_access('img')) {
if ($tmp !~ m/\A\w+:\/\/|\// || $tmp =~ m/\?|\#|\.\bjs\b\z/i) {
$tmp = "[<font color=red>$BAD_MESSAGE</font>]$tmp2";
}
else {
$tmp2 = '' if $tmp2 eq 'img';
$tmp2 = ' align="right"' if $tmp2 eq 'right_img';
$tmp2 = ' align="left"' if $tmp2 eq 'left_img';
$tmp = $AUBBC{icon_image}
$AUBBC{image_hight},''),'',1).$AUBBC{image_wrap}
: make_image($tmp2,$tmp,'','','').$AUBBC{image_wrap};
}
return $tmp;
}
else {
return $Tag_SecLVL{img}{text};
}
}
sub protect_email {
my $em = shift;
if (check_access('url')) {
my ($email1, $email2, $ran_num, $protect_email, @letters) =
('', '', '', '', split (//, $em));
$protect_email = '[' if $AUBBC{protect_email} eq 3 || $AUBBC{protect_email} eq 4;
foreach my $character (@letters) {
$protect_email .= '&#' . ord($character) . ';' if $AUBBC{protect_email} eq 1 || $AUBBC{protect_email} eq 2;
$protect_email .= ord($character) . ',' if $AUBBC{protect_email} eq 3;
$ran_num = int(rand(64)) || 0 if $AUBBC{protect_email} eq 4;
$protect_email =~ s/\,\z/]/g if $AUBBC{protect_email} eq 3 || $AUBBC{protect_email} eq 4;
return make_link('javascript:void(0)',$AUBBC{email_message},"javascript:MyEmCode('$AUBBC{protect_email}',$protect_email);",'')
if $AUBBC{protect_email} eq '2' || $AUBBC{protect_email} eq '3' || $AUBBC{protect_email} eq '4';
}
else {
return $Tag_SecLVL{url}{text};
}
}
sub js_print {
my $self = shift;
print <<JS;
Content-type: text/javascript
/*
AUBBC v$VERSION
JS
print <<'JS';
Fully supports dynamic view in XHTML.
"<html>\n<head>\n<title>MyCodePrint</title>\n"+
"<meta http-equiv=\"Content-Type\" content=\"text/html; charset=iso-8859-1\">\n"+
"</head>\n<body>\n<code>"+TheCode+"</code>\n</body>\n</html>\n");
top.codewin.document.close();
}
}
JS
exit(0);
}
sub do_build_tag {
warn 'ENTER do_build_tag' if $DEBUG_AUBBC;
foreach (keys %Build_AUBBC) {
warn 'ENTER foreach do_build_tag' if $DEBUG_AUBBC;
$msg =~ s/(\[$_\:\/\/([$Build_AUBBC{$_}[0]]+)\])/
do_sub( $_, $2 , $Build_AUBBC{$_}[2] ) || $1;
/eg if $Build_AUBBC{$_}[1] eq '1';
$msg =~ s/(\[$_\](?s)([$Build_AUBBC{$_}[0]]+)\[\/$_\])/
do_sub( $_, $2 , $Build_AUBBC{$_}[2] ) || $1;
$msg =~ s/(\[$_\])/
do_sub( $_, '' , $Build_AUBBC{$_}[2] ) || $1;
/eg if $Build_AUBBC{$_}[1] eq '3';
$msg =~ s/\[$_\]/
check_access($_) ? $Build_AUBBC{$_}[2] : $Tag_SecLVL{$_}{text};
/eg if $Build_AUBBC{$_}[1] eq '4';
}
}
sub do_sub {
my ($key, $term, $fun) = @_;
warn 'ENTER do_sub' if $DEBUG_AUBBC;
check_access($key)
? return $fun->($key, $term) || ''
: return $Tag_SecLVL{$key}{text};
}
sub check_subroutine {
my $name = shift;
defined $name && exists &{$name} && (ref $name eq 'CODE' || ref $name eq '')
? return \&{$name}
: return '';
}
sub add_build_tag {
my ($self,%NewTag) = @_;
warn 'ENTER add_build_tag' if $DEBUG_AUBBC;
$NewTag{function2} = $NewTag{function} || 'undefined!';
$NewTag{function} = check_subroutine($NewTag{function},'')
if $NewTag{type} ne '4';
$self->aubbc_error("Usage: add_build_tag - function 'Undefined subroutine' => $NewTag{function2}")
if ! $NewTag{function};
$Tag_SecLVL{$NewTag{name}} = {level => $NewTag{level}, text => $NewTag{error},};
$do_f[5] = 1 if !$do_f[5];
warn 'Added Build_AUBBC Tag '.$Build_AUBBC{$NewTag{name}} if $DEBUG_AUBBC && $Build_AUBBC{$NewTag{name}};
}
else {
$self->aubbc_error('Usage: add_build_tag - Bad name or pattern format');
}
}
}
sub remove_build_tag {
my ($self,$name,$type) = @_;
warn 'ENTER remove_build_tag' if $DEBUG_AUBBC;
delete $Build_AUBBC{$name} if exists $Build_AUBBC{$name} && !$type; # clear one
%Build_AUBBC = () if $type && !$name; # clear all
}
sub do_unicode{
warn 'ENTER do_unicode' if $DEBUG_AUBBC;
$msg =~ s/\[utf:\/\/(\#?\w+)\]/&$1;/g;
}
sub do_smileys {
warn 'ENTER do_smileys' if $DEBUG_AUBBC;
$msg =~
s/\[$_\]/make_image('',"$AUBBC{images_url}\/smilies\/$SMILEYS{$_}",'','',$_).$AUBBC{image_wrap}/ge
foreach keys %SMILEYS;
}
sub smiley_hash {
my ($self,%s_hash) = @_;
warn 'ENTER smiley_hash' if $DEBUG_AUBBC;
if (keys %s_hash) {
%SMILEYS = %s_hash;
$do_f[6] = 1;
}
}
sub do_all_ubbc {
my ($self,$message) = @_;
warn 'ENTER do_all_ubbc' if $DEBUG_AUBBC;
$msg = defined $message ? $message : '';
if ($msg) {
check_access();
$msg = $self->script_escape($msg,'') if $AUBBC{script_escape};
$msg =~ s/&(?!\#?\w+;)/&/g if $AUBBC{fix_amp};
if (!$AUBBC{no_bypass} && $msg =~ m/\A\#no/) {
$do_f[4] = 0 if $msg =~ s/\A\#none//;
if ($do_f[4]) {
do_build_tag() if $do_f[5] && $do_f[1];
}
do_unicode() if $do_f[2] && $AUBBC{utf};
do_smileys() if $do_f[6] && $do_f[3] && $AUBBC{smileys};
}
}
$msg =~ tr/\000//d if $AUBBC{aubbc_escape};
return $msg;
}
sub fix_message {
my $txt = shift;
$txt =~ s/\././g;
$txt =~ s/\:/:/g;
return $txt;
}
sub escape_aubbc {
warn 'ENTER escape_aubbc' if $DEBUG_AUBBC;
$msg =~ s/\[\[/\000[/g;
$msg =~ s/\]\]/\000]/g;
}
sub script_escape {
my ($self, $text, $option) = @_;
warn 'ENTER html_escape' if $DEBUG_AUBBC;
$text = '' unless defined $text;
if ($text) {
$text =~ s/(&|;)/$1 eq '&' ? '&' : ';'/ge;
if (!$option) {
$text =~ s/\t/ \ \ \ /g;
$text =~ s/ / \ /g;
}
$text =~ s/"/"/g;
$text =~ s/\(/(/g;
$text =~ s/\\/\/g;
$text =~ s/\|/|/g;
! $option && $AUBBC{line_break} eq '2'
? $text =~ s/\n/<br$AUBBC{html_type}>/g
: $text =~ s/\n/<br$AUBBC{html_type}>\n/g if !$option && $AUBBC{line_break} eq '1';
return $text;
}
}
sub html_to_text {
my ($self, $html, $option) = @_;
warn 'ENTER html_to_text' if $DEBUG_AUBBC;
$html = '' unless defined $html;
if ($html) {
$html =~ s/&/&/g;
$html =~ s/;/;/g;
if (!$option) {
$html =~ s/ \ \ \ /\t/g;
$html =~ s/ \ / /g;
}
$html =~ s/'/'/g;
$html =~ s/)/\)/g;
$html =~ s/(/\(/g;
$html =~ s/\/\\/g;
$html =~ s/|/\|/g;
$html =~ s/<br(?:\s?\/)?>\n?/\n/g if $AUBBC{line_break};
return $html;
}
}
sub version {
my $self = shift;
return $VERSION;
}
sub aubbc_error {
my ($self, $error) = @_;
defined $error && $error
? $aubbc_error .= $error . "\n"
: return $aubbc_error;
}
1;
__END__
pattern => '',
type => 4,
function => 'Hello World!',
);
my $message = '[ok://test me] [ok://test other] [ok://n0 w00rk] [ip] [agent] [hello]';
$message = $aubbc->do_all_ubbc($message);
print $message;
sub check_ok_tag {
my ($tag_name, $text_from_AUBBC) = @_;
if ($text_from_AUBBC eq 'test me') {
return 'Works Good 1';
}
else {
return 'Works Good 2';
}
}
sub get_some_tag {
my ($tag_name, $text_from_AUBBC) = @_;
$tag_name = lc($tag_name);
$text_from_AUBBC = $ENV{'REMOTE_ADDR'} if ($tag_name eq 'ip');
$text_from_AUBBC = $aubbc->script_escape($ENV{'HTTP_USER_AGENT'}) if ($tag_name eq 'agent');
return $text_from_AUBBC;
}
1;
=head2 $aubbc->remove_build_tag($name, $option);
pattern => '',
type => 4,
function => 'Hello World!',
);
my $message = '[ok://test me] [ok://test other] [ok://n0 w00rk] [ip] [agent] [hello]';
$message = $aubbc->do_all_ubbc($message);
print $message;
sub check_ok_tag {
my ($tag_name, $text_from_AUBBC) = @_;
if ($text_from_AUBBC eq 'test me') {
return 'Works Good 1';
}
else {
return 'Works Good 2';
}
}
sub get_some_tag {
my ($tag_name, $text_from_AUBBC) = @_;
$tag_name = lc($tag_name);
$text_from_AUBBC = $ENV{'REMOTE_ADDR'} if ($tag_name eq 'ip');
$text_from_AUBBC = $aubbc->script_escape($ENV{'HTTP_USER_AGENT'}) if ($tag_name eq 'agent');
return $text_from_AUBBC;
}
1;
=head2 $aubbc->remove_build_tag($name, $option);
examples/Database_Manipulation.cgi view on Meta::CPAN
# The message will have some characters that would normaly brake some database
# structures, cause risky errors or be html.
my $message = <<FORM;
[b]Work[/b]
<i>This will not work</i>
Brake the database |||| ''''''''''' """"""
FORM
sub saving_data {
# This is to show how to save the user input safely to your backend
# you will need to use a module like CGI or what ever is out there
# to recive the HTML form data lets say the data is in $message
# Befor the data can be saved you will have to use the script_escape method on $message
$message = $aubbc->script_escape($message);
# Then save $message to your database, extra security methods maybe required or desired
# depending on the type of backend used.......
}
sub editing_data {
# This will be a two part subroutine. This first one will get the message from
# the backend and display the data in a HTML form to be edited lets say its
# in variable $form_data
# Since this gets into sandboxing the html_to_text method you may want
# to play with settings for other view's or can skip the form feilds sandboxing
# the option 1 for html_to_text is needed to not convert &, spaces, tab's
$form_data = $aubbc->html_to_text( $form_data );
# Now $form_data can be printed in the form feild
# When the HTML form is submitted we fictitiously sent the edited data to editing_data2
# of this file to be saved
}
sub editing_data2 {
# Part 2 of editing data, you will need to use a module like CGI or what ever is out there
# to recive the HTML form data
# Before the HTML form data can be saved you will have to use the script_escape
# method on the variable that holds the HTML form data lets say its $message2
$message2 = $aubbc->script_escape($message2);
# Then save it to your database, extra security methods maybe required or desired
# depending on the type of backend used.......
}
sub display_data {
# Get the data from the backend lets say we did that and its in $message3
# use do_all_ubbc on $message3 and now $message3 is ready to be printed in HTML.
$message3 = $aubbc->do_all_ubbc($message3);
# Here you would want to print the propper HTML headers and elements with $message3 in it
# or return the variable, how ever you want to make it!!
}
examples/Mixing_HTML_and_BBcode.cgi view on Meta::CPAN
[email]safe\@email.com[/email]
<aubbc> [b]Full AUBBC support[/b]
<i>This will not work</i> [i]This will work[/i]
[b]Work[/b] <b>Not Work</b>
[email]safe\@email.com[/email]
</aubbc>
HTML
sub saving_data {
# This is to show how to save the user input safely to your backend
# you will need to use a module like CGI or what ever is out there
# to recive the HTML form data lets say the data is in $message
# Befor the data can be saved you will have to use the script_escape method on $message
# But not on the hole $message, so I use this filter to get the <aubbc> tag
$message =~ s/(<aubbc>(?s)(.*?)<\/aubbc>)/
my $ret = $aubbc->script_escape( $2 );
$ret ? '<aubbc>'.$ret."<\/aubbc>" : $1;
/exg;
# Then save $message to your database, extra security methods maybe required or desired
# depending on the type of backend used.......
}
sub editing_data {
# This will be a two part subroutine. This first one will get the message from
# the backend and display the data in a HTML form to be edited lets say its
# in variable $form_data
# Since this gets into sandboxing the script_escape method you may want
# to play with settings for other view's or can skip the form feilds sandboxing
# the option 1 for script_escape is needed to not convert spaces, tab's, new lines
$form_data =~ s/(<aubbc>(?s)(.*?)<\/aubbc>)/
my $ret = $aubbc->html_to_text( $2 );
$ret ? '<aubbc>'.$ret."<\/aubbc>" : $1;
/exg;
$form_data = $aubbc->script_escape( $form_data, 1 );
# Now $form_data can be printed in the form feild
# When the HTML form is submitted we fictitiously sent the edited data to editing_data2
# of this file to be saved
}
sub editing_data2 {
# Part 2 of editing data, you will need to use a module like CGI or what ever is out there
# to recive the HTML form data
# Before the HTML form data can be saved you will have to use the script_escape
# method with the regex on the variable that holds the HTML form data lets say its $message2
$message2 =~ s/(<aubbc>(?s)(.*?)<\/aubbc>)/
my $ret = $aubbc->script_escape( $2 );
$ret ? '<aubbc>'.$ret."<\/aubbc>" : $1;
/exg;
# Then save it to your database, extra security methods maybe required or desired
# depending on the type of backend used.......
}
sub display_data {
# Get the data from the backend lets say we did that and its in $message3
# use do_all_ubbc on $message3 and
$message3 = $aubbc->do_all_ubbc($message3);
# Before you print we want to remove the <aubbc> home made element
$message3 =~ s{\<\/?aubbc\>}{}g;
# now $message3 is ready to be printed in HTML.
# Here you would want to print the propper HTML headers and elements with $message3 in it
examples/bench.pl view on Meta::CPAN
[li].....[/li]
[/ol]
[b]Unicode Support[/b][br]
[utf://#x3A3]] = [utf://#x3A3][br]
[utf://#0931]] = [utf://#0931][br]
[utf://iquest]] = [utf://iquest][br]
EOM
sub create_pb {
use Parse::BBCode;
$loaded{'Parse::BBCode'} = Parse::BBCode->VERSION;
my $pb = Parse::BBCode->new();
return $pb;
}
sub create_hb {
use HTML::BBCode;
$loaded{'HTML::BBCode'} = HTML::BBCode->VERSION;
my $bbc = HTML::BBCode->new();
return $bbc;
}
sub create_bp {
use BBCode::Parser;
$loaded{'BBCode::Parser'} = BBCode::Parser->VERSION;
my $parser = BBCode::Parser->new(follow_links => 1);
return $parser;
}
sub create_bbr {
use HTML::BBReverse;
$loaded{'HTML::BBReverse'} = HTML::BBReverse->VERSION;
my $bbr = HTML::BBReverse->new();
return $bbr;
}
sub create_au {
use AUBBC;
#use Memoize;
$loaded{AUBBC} = AUBBC->VERSION;
#$AUBBC::MEMOIZE = 0;
my $au = AUBBC->new();
return $au;
}
my $pb = &create_pb;
my $bp = &create_bp;
examples/bench.pl view on Meta::CPAN
#my $rendered4 = $bbr->parse($code);
#print "BBR\t$loaded{'HTML::BBReverse'}\n$rendered4\n\n";
#my $rendered5 = $au->do_all_ubbc($code);
#print "AUBBC\t$loaded{AUBBC}\n$rendered5\n\n";
timethese($ARGV[0] || -1, {
$loaded{'Parse::BBCode'} ? (
'P::B::new' => \&create_pb,
'P::B::x' => sub { my $out = $pb->render($code) },
) : (),
$loaded{'HTML::BBCode'} ? (
'H::B::new' => \&create_hb,
'H::B::x' => sub { my $out = $hb->parse($code) },
) : (),
$loaded{'BBCode::Parser'} ? (
'B::P::new' => \&create_bp,
'B::P::x' => sub { my $tree = $bp->parse($code); my $out = $tree->toHTML(); },
) : (),
$loaded{'HTML::BBReverse'} ? (
'BBR::new' => \&create_bbr,
'BBR::x' => sub { my $out = $bbr->parse($code); },
) : (),
$loaded{'AUBBC'} ? (
'AU::new' => \&create_au,
'AU::x' => sub { my $out = $au->do_all_ubbc($code); },
) : (),
});
examples/tag_list.cgi view on Meta::CPAN
);
}
$aubbc->add_build_tag(
name => 'time',
pattern => '',
type => 3,
function => 'main::other_sites',
);
# This is so eather the print_list sub will run or the js_print
# if this file was ran on a web server
$ENV{'QUERY_STRING'}
? $aubbc->js_print()
: print_list->();
sub print_list {
# The list
my $message = <<'HTML';
[br][b]The Very common UBBC Tags[/b][br]
[[b]Bold[[/b] = [b]Bold[/b][br]
[[strong]Strong[[/strong] = [strong]Strong[/strong][br]
[[small]Small[[/small] = [small]Small[/small][br]
[[big]Big[[/big] = [big]Big[/big][br]
[[h1]Head 1[[/h1] = [h1]Head 1[/h1][br]
through.....[br]
[[h6]Head 6[[/h6] = [h6]Head 6[/h6][br]
examples/tag_list.cgi view on Meta::CPAN
font-family : Courier New, Latha, sans-serif;
}
</style>
$message
</body>
</html>
HTML
exit;
}
sub other_sites {
my ($tag_name, $text_from_AUBBC) = @_;
# cpan modules
$text_from_AUBBC = AUBBC::make_link("http://search.cpan.org/search?mode=module&query=$text_from_AUBBC",$text_from_AUBBC,'',1)
if $tag_name eq 'cpan';
# wikipedia Wiki
$text_from_AUBBC = AUBBC::make_link("http://wikipedia.org/wiki/Special:Search?search=$text_from_AUBBC",$text_from_AUBBC,'',1)
if ($tag_name eq 'wikipedia' || $tag_name eq 'wp');
( run in 0.784 second using v1.01-cache-2.11-cpan-4d50c553e7e )