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/(?<!>)\n/<br$AUBBC{html_type}>\n/g;
if ($AUBBC{highlight}) {
warn 'ENTER block highlight' if $DEBUG_AUBBC;
$txt =~ s/\z/<br$AUBBC{html_type}>/ if $txt !~ m/<br$AUBBC{html_type}>\z/;
$txt =~ s/(<<(?:')?(\w+)(?:')?;(?s)[^\2]+\b\2\b)/<span$AUBBC{highlight_class1}>$1<\/span>/g;
$txt =~ s/(?<![\&\$])(\#.*?(?:<br$AUBBC{html_type}>))/<span$AUBBC{highlight_class2}>$1<\/span>/g;
$txt =~ s/(\bsub\b(?:\s+))(\w+)/$1<span$AUBBC{highlight_class8}>$2<\/span>/g;
$txt =~ s/(\w+(?:\->)?(?:\w+)?((?:.+?)?)(?:;)?)/<span$AUBBC{highlight_class9}>$1<\/span>/g;
$txt =~ s/((?:&)\w+;)/<span$AUBBC{highlight_class9}>$1<\/span>/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;
/eg if $Build_AUBBC{$_}[1] eq '2';
$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};
if ($NewTag{function}) {
$NewTag{pattern} = 'l' if $NewTag{type} eq '3' || $NewTag{type} eq '4';
if ($NewTag{type} && $NewTag{name} =~ m/\A[\w\-]+\z/ && $NewTag{pattern} =~ m/\A[lns_:\-,]+|all\z/) {
if ($NewTag{pattern} eq 'all') {
$NewTag{pattern} = '^\[|\]';
}
else {
$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__
Enable or Disable Smiley Tags Default 1 is Enabled, 0 is Disable.
=head2 highlight
Enable or Disable Code Highlight Default 1 is Enabled, 0 is Disable.
=head2 highlight_function
This can replace the highlighter of AUBBC with a custome one
must provide the text name of the pre-defined subroutine that receives the code
tags text and returns the highlighted text.
=head2 no_bypass
Enable or Disable User Tags for bypassing hole tag sets Default 0 is Disable, 1 is Enabled.
Bypass tag must be at the very beginning of the message!!!!
Must also be in the order of the "Bypass Tag list:" but not on a new line \n
and if #none is used the other bypass tags will not be removed.
Bypass Tag list:
highlight_class3 = String quote
highlight_class4 = String quote
highlight_class5 = Number's
highlight_class6 = Operator, Function and other Name's
highlight_class7 = Variables
highlight_class8 = defining subroutine
highlight_class9 = using subroutine
=head1 Smilies Settings
These are the settings for using custom smilies.
Note: There are no Built-in smilies.
=head2 $aubbc->smiley_hash();
This is how you import your custom smilies hash.
'all' = anything but [ or ]
'l' = 'a-z'
'n' = '0-9'
's' = ' '
'-' = '-'
':' = ':'
'_' = '_'
type - 1 is style [name://pattern], 2 is style [name]pattern[/name], 3 is style [name],
the next setting for type the function will not be used to run Perl subroutines and
will replace the text with what text is defined in the function setting, the setting is
type 4 this will use style [name] but will work different then the other built settings
see function below on how type 4 works
function - a pre-defined subroutine that receives the matched pattern, tag name and returns what you want,
unless type is set to 4 then it will replace the tag with what text is in the function.
Note: if the function returns undefined, '' or 0 the tag will not be changed.
level - the array number of the security level
error - the text or HTML to show if user has no access
Note: For the build tags leaving the variables blank will default level to 0 and
error to the $AUBBC::BAD_MESSAGE string.
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);
print $aubbc->aubbc_error();
die $aubbc->aubbc_error() if $aubbc->aubbc_error();
=head1 Memoize
This setting can turn AUBBC's usage of Memoize on or off.
=head2 $AUBBC::MEMOIZE
Default setting 1 will check if it needs to load Memoize, if loaded then load the sub's that need the speed.
Setting 0 will not use Memoize.
Usage of this setting:
use Memoize;
# do other stuff...
use AUBBC;
# AUBBC will detect that Memoize was loaded
# and just load the sub's that need the speed.
my $aubbc = AUBBC->new();
# est...
=head1 Debug
The Debug setting will send a lot of messages to warn and is not recommended to leave on all the time.
=head2 $AUBBC::DEBUG_AUBBC
make_link method could be used outside of the module without the security access
in it, as intended.
Changed - forgot to say in version 4.05 that I changed the aubbc_error so a new line
will be added after each inserted error.
v4.05 - 04/05/2011
Addition - Assign security levels for links, images, built and code tags.
New subroutine names: security_levels, user_level, tag_security, check_access
Changed - The default value for $AUBBC::BAD_MESSAGE is now 'Unathorized'
v4.04 - 02/05/2011
Fixed - Bug with quote tag, needed to convert all its tags.
v4.03 - 02/03/2011
Addition - New Object method aubbc_error . Developers can now controle if or when
v4.01 - 11/08/2010
Fixed - Bug that converts the true text typed to the HTML code name.
All parts of the module where effected by this bug, in the code tag if the
author ment & #59 ; it would show ; . This also caused a long standing bug with
typing any HTML code name and saving it to a backend.
this fix removes the HTML code name regex in do_unicode and had to add/move two
filters in "script_escape to conver the & to an amp and ; to #59;" and
"html_to_text to conver amp to & and #59 to ;". This fix also helped in allowing
the regex's for highlighting subroutines to be made.
Fixed - had to add a null byte marker to escape_aubbc so the code tag's
highlighter can detect the escaped character and change it back. In do_all_ubbc
All markers get removed before the message is returned because FireFox can see
the null bytes as an error.
Addition - Perl subroutine highlighting for the code tag highlighter. Had a
problem making this till this version because a HTML code name can look like
&TheName; and a Perl subroutine looked the same till ; got converted.
Addition - AUBBC::make_image($align,$src,$width,$height,$alt) this is useful enough
to mention once.
v4.00 - 11/02/2010
Addition - New feature to the code tags aubbc_setting code_download.
the default setting for code_download is '^Download above code^' this message will
be the links name. the link will open a JavaScript pop-up window and write the
code in it to be copied or printed to a printer. A new JavaScript function was
added to the js_print method called MyCodePrint. JavaScript makes this feature
portable and dynamic. the link for code_download is added after the code_extra
setting so a disclaimer can be added before the code_download link
Addition - $AUBBC::MEMOIZE This setting can turn AUBBC's usage of Memoize on or off.
Default setting 1 will check if it needs to load Memoize, if loaded then load the sub's that need the speed.
Setting 0 will not use Memoize.
Addition - AUBBC::make_link($link,$name,$javascript,$target) this is useful enough
to mention once.
Improvement - After lots of testing I have removed all /o in the regex. One main
reason is Memoize provides enough speed.
v3.13 - 09/30/2010
Fixed - fixed a line break and new line sandbox bug
Improvement - Massive speed improvement to the hole module and no features lost.
changed new for faster loading, the module uses vars for some variables,
re-spaced the hole code.
v2.10 - 08/31/2010 11:17:13
Addition - adding type 4 to add_build_tag this will use style 3 but will work
different then the other built functions. Type 4 will print the text defined in
function and not point to a defined Perl subroutine.
Addition - added line_break setting to have control over the script_escape and
html_to_text methods converting html line break <br> and new line \n
Addition - added fix_amp this setting finds all the & that need to covert to the amp; html code name
so the w3c xhtml validation checks ok.
Addition - added no_img this setting will allow some control for using [img] tags
for security reasons
if used outside of the module. Made a new method to check link access now the
make_link method could be used outside of the module without the security access
in it, as intended.
Changed - forgot to say in version 4.05 that I changed the aubbc_error so a new line
will be added after each inserted error.
v4.05 - 04/05/2011
Addition - Assign security levels for links, images, built and code tags.
New subroutine names: security_levels, user_level, tag_security, check_access
Changed - The default value for $AUBBC::BAD_MESSAGE is now 'Unathorized'
v4.04 - 02/05/2011
Fixed - Bug with quote tag, needed to convert all its tags.
v4.03 - 02/03/2011
Addition - New Object method aubbc_error . Developers can now controle if or when
v4.01 - 11/08/2010
Fixed - Bug that converts the true text typed to the HTML code name.
All parts of the module where effected by this bug, in the code tag if the
author ment & #59 ; it would show ; . This also caused a long standing bug with
typing any HTML code name and saving it to a backend.
this fix removes the HTML code name regex in do_unicode and had to add/move two
filters in "script_escape to conver the & to an amp and ; to #59;" and
"html_to_text to conver amp to & and #59 to ;". This fix also helped in allowing
the regex's for highlighting subroutines to be made.
Fixed - had to add a null byte marker to escape_aubbc so the code tag's
highlighter can detect the escaped character and change it back. In do_all_ubbc
All markers get removed before the message is returned because FireFox can see
the null bytes as an error.
Addition - Perl subroutine highlighting for the code tag highlighter. Had a
problem making this till this version because a HTML code name can look like
&TheName; and a Perl subroutine looked the same till ; got converted.
Addition - AUBBC::make_image($align,$src,$width,$height,$alt) this is useful enough
to mention once.
v4.00 - 11/02/2010
Addition - New feature to the code tags aubbc_setting code_download.
the default setting for code_download is '^Download above code^' this message will
be the links name. the link will open a JavaScript pop-up window and write the
code in it to be copied or printed to a printer. A new JavaScript function was
added to the js_print method called MyCodePrint. JavaScript makes this feature
portable and dynamic. the link for code_download is added after the code_extra
setting so a disclaimer can be added before the code_download link
Addition - $AUBBC::MEMOIZE This setting can turn AUBBC's usage of Memoize on or off.
Default setting 1 will check if it needs to load Memoize, if loaded then load the sub's that need the speed.
Setting 0 will not use Memoize.
Addition - AUBBC::make_link($link,$name,$javascript,$target) this is useful enough
to mention once.
Improvement - After lots of testing I have removed all /o in the regex. One main
reason is Memoize provides enough speed.
v3.13 - 09/30/2010
Fixed - fixed a line break and new line sandbox bug
Improvement - Massive speed improvement to the hole module and no features lost.
changed new for faster loading, the module uses vars for some variables,
re-spaced the hole code.
v2.10 - 08/31/2010 11:17:13
Addition - adding type 4 to add_build_tag this will use style 3 but will work
different then the other built functions. Type 4 will print the text defined in
function and not point to a defined Perl subroutine.
Addition - added line_break setting to have control over the script_escape and
html_to_text methods converting html line break <br> and new line \n
Addition - added fix_amp this setting finds all the & that need to covert to the amp; html code name
so the w3c xhtml validation checks ok.
Addition - added no_img this setting will allow some control for using [img] tags
for security reasons
Enable or Disable Smiley Tags Default 1 is Enabled, 0 is Disable.
=head2 highlight
Enable or Disable Code Highlight Default 1 is Enabled, 0 is Disable.
=head2 highlight_function
This can replace the highlighter of AUBBC with a custome one
must provide the text name of the pre-defined subroutine that receives the code
tags text and returns the highlighted text.
=head2 no_bypass
Enable or Disable User Tags for bypassing hole tag sets Default 0 is Disable, 1 is Enabled.
Bypass tag must be at the very beginning of the message!!!!
Must also be in the order of the "Bypass Tag list:" but not on a new line \n
and if #none is used the other bypass tags will not be removed.
Bypass Tag list:
highlight_class3 = String quote
highlight_class4 = String quote
highlight_class5 = Number's
highlight_class6 = Operator, Function and other Name's
highlight_class7 = Variables
highlight_class8 = defining subroutine
highlight_class9 = using subroutine
=head1 Smilies Settings
These are the settings for using custom smilies.
Note: There are no Built-in smilies.
=head2 $aubbc->smiley_hash();
This is how you import your custom smilies hash.
'all' = anything but [ or ]
'l' = 'a-z'
'n' = '0-9'
's' = ' '
'-' = '-'
':' = ':'
'_' = '_'
type - 1 is style [name://pattern], 2 is style [name]pattern[/name], 3 is style [name],
the next setting for type the function will not be used to run Perl subroutines and
will replace the text with what text is defined in the function setting, the setting is
type 4 this will use style [name] but will work different then the other built settings
see function below on how type 4 works
function - a pre-defined subroutine that receives the matched pattern, tag name and returns what you want,
unless type is set to 4 then it will replace the tag with what text is in the function.
Note: if the function returns undefined, '' or 0 the tag will not be changed.
level - the array number of the security level
error - the text or HTML to show if user has no access
Note: For the build tags leaving the variables blank will default level to 0 and
error to the $AUBBC::BAD_MESSAGE string.
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);
print $aubbc->aubbc_error();
die $aubbc->aubbc_error() if $aubbc->aubbc_error();
=head1 Memoize
This setting can turn AUBBC's usage of Memoize on or off.
=head2 $AUBBC::MEMOIZE
Default setting 1 will check if it needs to load Memoize, if loaded then load the sub's that need the speed.
Setting 0 will not use Memoize.
Usage of this setting:
use Memoize;
# do other stuff...
use AUBBC;
# AUBBC will detect that Memoize was loaded
# and just load the sub's that need the speed.
my $aubbc = AUBBC->new();
# est...
=head1 Debug
The Debug setting will send a lot of messages to warn and is not recommended to leave on all the time.
=head2 $AUBBC::DEBUG_AUBBC
make_link method could be used outside of the module without the security access
in it, as intended.
Changed - forgot to say in version 4.05 that I changed the aubbc_error so a new line
will be added after each inserted error.
v4.05 - 04/05/2011
Addition - Assign security levels for links, images, built and code tags.
New subroutine names: security_levels, user_level, tag_security, check_access
Changed - The default value for $AUBBC::BAD_MESSAGE is now 'Unathorized'
v4.04 - 02/05/2011
Fixed - Bug with quote tag, needed to convert all its tags.
v4.03 - 02/03/2011
Addition - New Object method aubbc_error . Developers can now controle if or when
v4.01 - 11/08/2010
Fixed - Bug that converts the true text typed to the HTML code name.
All parts of the module where effected by this bug, in the code tag if the
author ment & #59 ; it would show ; . This also caused a long standing bug with
typing any HTML code name and saving it to a backend.
this fix removes the HTML code name regex in do_unicode and had to add/move two
filters in "script_escape to conver the & to an amp and ; to #59;" and
"html_to_text to conver amp to & and #59 to ;". This fix also helped in allowing
the regex's for highlighting subroutines to be made.
Fixed - had to add a null byte marker to escape_aubbc so the code tag's
highlighter can detect the escaped character and change it back. In do_all_ubbc
All markers get removed before the message is returned because FireFox can see
the null bytes as an error.
Addition - Perl subroutine highlighting for the code tag highlighter. Had a
problem making this till this version because a HTML code name can look like
&TheName; and a Perl subroutine looked the same till ; got converted.
Addition - AUBBC::make_image($align,$src,$width,$height,$alt) this is useful enough
to mention once.
v4.00 - 11/02/2010
Addition - New feature to the code tags aubbc_setting code_download.
the default setting for code_download is '^Download above code^' this message will
be the links name. the link will open a JavaScript pop-up window and write the
code in it to be copied or printed to a printer. A new JavaScript function was
added to the js_print method called MyCodePrint. JavaScript makes this feature
portable and dynamic. the link for code_download is added after the code_extra
setting so a disclaimer can be added before the code_download link
Addition - $AUBBC::MEMOIZE This setting can turn AUBBC's usage of Memoize on or off.
Default setting 1 will check if it needs to load Memoize, if loaded then load the sub's that need the speed.
Setting 0 will not use Memoize.
Addition - AUBBC::make_link($link,$name,$javascript,$target) this is useful enough
to mention once.
Improvement - After lots of testing I have removed all /o in the regex. One main
reason is Memoize provides enough speed.
v3.13 - 09/30/2010
Fixed - fixed a line break and new line sandbox bug
Improvement - Massive speed improvement to the hole module and no features lost.
changed new for faster loading, the module uses vars for some variables,
re-spaced the hole code.
v2.10 - 08/31/2010 11:17:13
Addition - adding type 4 to add_build_tag this will use style 3 but will work
different then the other built functions. Type 4 will print the text defined in
function and not point to a defined Perl subroutine.
Addition - added line_break setting to have control over the script_escape and
html_to_text methods converting html line break <br> and new line \n
Addition - added fix_amp this setting finds all the & that need to covert to the amp; html code name
so the w3c xhtml validation checks ok.
Addition - added no_img this setting will allow some control for using [img] tags
for security reasons
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
through.....[br]
[[h6]Head 6[[/h6] = [h6]Head 6[/h6][br]
[[i]Italic[[/i] = [i]Italic[/i][br]
[[u]Underline[[/u] = [u]Underline[/u][br]
[[strike]Strike[[/strike] = [strike]Strike[/strike][br]
[left]]Left Align[[/left] = [left]Left Align[/left][br]
[[center]Center Align[[/center] = [center]Center Align[/center][br]
[right]]Right Align[[/right] = [right]Right Align[/right][br]
[[em]Emotion[/em]] = [em]Emotion[/em]
[sup]Sup[/sup][br]
[sub]Sub[/sub][br]
[pre]]Pre[[/pre] = [pre]Pre[/pre][br]
[img]]http://www.google.com/intl/en/images/about_logo.gif[[/img] =
[img]http://www.google.com/intl/en/images/about_logo.gif[/img][br][br]
[url=URL]]Name[[/url] = [url=http://www.google.com]http://www.google.com[/url][br]
http[utf://#58]//google.com = http://google.com[br]
[email]]Email[/email] = [email]some@email.com[/email] Recommended Not to Post your email in a public area[br]
[code]]# Some Code ......
my %hash = ( stuff => { '1' => 1, '2' => 2 }, );
print $hash{stuff}{'1'};[[/code] =
[code]# Some Code ......
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]
[[i]Italic[[/i] = [i]Italic[/i][br]
[[u]Underline[[/u] = [u]Underline[/u][br]
[[strike]Strike[[/strike] = [strike]Strike[/strike][br]
[left]]Left Align[[/left] = [left]Left Align[/left][br]
[[center]Center Align[[/center] = [center]Center Align[/center][br]
[right]]Right Align[[/right] = [right]Right Align[/right][br]
[[em]Em[/em]] = [em]Em[/em][br]
[[sup]Sup[/sup]] = [sup]Sup[/sup][br]
[[sub]Sub[/sub]] = [sub]Sub[/sub][br]
[pre]]Pre[[/pre] = [pre]Pre[/pre][br]
[img]]http://www.google.com/intl/en/images/about_logo.gif[[/img] =
[img]http://www.google.com/intl/en/images/about_logo.gif[/img][br][br]
[url=URL]]Name[[/url] = [url=http://www.google.com]http://www.google.com[/url][br]
http[utf://#58]//google.com = http://google.com[br]
[email]]Email[/email] = [email]some@email.com[/email] Recommended Not to Post your email in a public area[br]
[code]]# Some Code ......
my %hash = ( stuff => { '1' => 1, '2' => 2 }, );
print $hash{stuff}{'1'};[[/code] =
[code]# Some Code ......
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');
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
my ($count, $message, $setting, $aubbc, $Current_version, %msg) =
(1, '[br][utf://#x23]', '', '', '', (1 => 'Test good ', 2 => 'Test error ',) );
BEGIN {
$| = 1;
print "Test's 1 to 4\n";
}
use AUBBC;
( run in 0.310 second using v1.01-cache-2.11-cpan-88abd93f124 )