AUBBC
view release on metacpan or search on metacpan
package AUBBC;
use strict;
use warnings;
our $VERSION = '4.06';
our $BAD_MESSAGE = 'Unathorized';
our $DEBUG_AUBBC = 0;
our $MEMOIZE = 1;
my $msg = '';
my $aubbc_error = '';
my $long_regex = '[\w\.\/\-\~\@\:\;\=]+(?:\?[\w\~\.\;\:\,\$\-\+\!\*\?\/\=\&\@\#\%]+?)?';
my @do_f = (1,1,1,1,1,0,0,0,time.$$.'000','',1);
my @key64 = ('A'..'Z','a'..'z',0..9,'+','/');
my %SMILEYS = ();
my %Build_AUBBC = ();
my %AUBBC = (
aubbc => 1,
utf => 1,
smileys => 1,
highlight => 1,
highlight_function => \&code_highlight,
no_bypass => 0,
for_links => 0,
aubbc_escape => 1,
no_img => 0,
icon_image => 1,
image_hight => '60',
image_width => '90',
image_border => '0',
image_wrap => ' ',
href_target => ' target="_blank"',
images_url => '',
html_type => ' /',
fix_amp => 1,
line_break => '1',
code_class => '',
code_extra => '',
code_download => '^Download above code^',
href_class => '',
quote_class => '',
quote_extra => '',
script_escape => 1,
protect_email => '0',
email_message => 'Contact Email',
highlight_class1 => '',
highlight_class2 => '',
highlight_class3 => '',
highlight_class4 => '',
highlight_class5 => '',
highlight_class6 => '',
highlight_class7 => '',
highlight_class8 => '',
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;
}
$i++;
}
}
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;
var TheCode = document.getElementById(input).innerHTML;
TheCode = TheCode.replace(/<([^br<]+|\/?[puib])>/ig, "");
codewin = window.open("", input, "width=800,height=600,resizable=yes,menubar=yes,scrollbars=yes");
top.codewin.document.write("<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n"+
"<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 {
my @pat_split = ();
my %is_pat = ('l' => 'a-z', 'n' => '\d', '_' => '\_', ':' => '\:', 's' => '\s', '-' => '\-');
@pat_split = split /\,/, $NewTag{pattern};
$NewTag{pattern} = '';
$NewTag{pattern} .= $is_pat{$_} || '' foreach @pat_split;
}
$Build_AUBBC{$NewTag{name}} = [$NewTag{pattern}, $NewTag{type}, $NewTag{function}];
$NewTag{level} ||= 0;
$NewTag{error} ||= $BAD_MESSAGE;
$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_f[0] = 0 if $msg =~ s/\A\#noubbc//;
$do_f[1] = 0 if $msg =~ s/\A\#nobuild//;
$do_f[2] = 0 if $msg =~ s/\A\#noutf//;
$do_f[3] = 0 if $msg =~ s/\A\#nosmileys//;
}
warn 'START no_bypass' if $DEBUG_AUBBC && !$do_f[4];
}
if ($do_f[4]) {
escape_aubbc() if $AUBBC{aubbc_escape};
if (!$AUBBC{for_links}) {
do_ubbc($msg) if $do_f[0] && $AUBBC{aubbc};
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};
}
}
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;
$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/(/\(/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__
=pod
=head1 COPYLEFT
AUBBC.pm, v4.06 4/12/2011 By: N.K.A.
Advanced Universal Bulletin Board Code a Perl BBcode API
shakaflex [at] gmail.com
http://search.cpan.org/~sflex/
http://aubbc.googlecode.com/
Development Notes: Highlighting functions list and tags/commands for more
language highlighters. Ideas make some new tags like [perl] or have a command in the code
tag like [code]perl:print 'perl';[/code] with a default highlighting method if
a command was not used. Then highlighting of many types of code could be allowed
even markup like HTML.
Notes: This code has a lot of settings and works good
with most default settings see the POD and example files
in the archive for usage.
=head1 NAME
AUBBC
=head1 SYNOPSIS
use AUBBC;
my $aubbc = AUBBC->new();
my $message = 'Lets [b]Bold in HTML[/b]';
print $aubbc->do_all_ubbc($message);
=head1 ABSTRACT
Advanced Universal Bulletin Board Code a Perl BBcode API
=head1 DESCRIPTION
AUBBC is a object oriented BBcode API designed as a developers tool for themes, wiki's, forums and other BBcode to HTML Parser needs.
Features:
1) Massive amount of supported tags.
2) Build your own tags to add custom made tags.
3) Full XSS Security for supported tags.
4) High Speed Parser
( run in 0.522 second using v1.01-cache-2.11-cpan-39bf76dae61 )