view release on metacpan or  search on metacpan

AUBBC.pm  view on Meta::CPAN

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;
}

AUBBC.pm  view on Meta::CPAN

 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};
  }
 }
 $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 '&' ? '&' : '&#59;'/ge;
  if (!$option) {
   $text =~ s/\t/ \  \  \ /g;
   $text =~ s/  / \ /g;
  }
  $text =~ s/"/"/g;
  $text =~ s/</&#60;/g;
  $text =~ s/>/&#62;/g;
  $text =~ s/'/&#39;/g;
  $text =~ s/\)/&#41;/g;
  $text =~ s/\(/&#40;/g;
  $text =~ s/\\/&#92;/g;
  $text =~ s/\|/&#124;/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/&amp;/&/g;
  $html =~ s/&#59;/;/g;
  if (!$option) {
   $html =~ s/ \&nbsp; \&nbsp; \&nbsp;/\t/g;
   $html =~ s/ \&nbsp;/  /g;
  }
  $html =~ s/&#34;/"/g;
  $html =~ s/&#60;/</g;
  $html =~ s/&#62;/>/g;
  $html =~ s/&#39;/'/g;
  $html =~ s/&#41;/\)/g;