package AUBBC;
use warnings;
use strict;
use vars qw(%Build_AUBBC %AUBBC %AUBBC_TAGS);

our $VERSION = '2.20';
our $BAD_MESSAGE = 'Error';
our $DEBUG_AUBBC = 0;
our %SMILEYS = ();

sub new {
 my $self = {};
 bless($self);
 set_settings();
 settings_prep();
 if ($DEBUG_AUBBC) {
  warn "CREATING $self";
  my $uabbc_settings = '';
  foreach (keys %AUBBC) {
   $uabbc_settings .= $_ . ' =>' . $AUBBC{$_} . ', ';
  }
  warn "AUBBC Settings: $uabbc_settings";
 }
 return $self;
}

sub DESTROY {
 if ($DEBUG_AUBBC) {
  my $self = shift;
  warn "DESTROY $self";
 }
}

sub set_settings {
 %Build_AUBBC = ();
 %AUBBC = (aubbc => 1,utf => 1,smileys => 1,highlight => 1,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 => 1,href_target => 0,images_url => '',html_type => 'xhtml',fix_amp => 1,line_break => 1,code_class => '',code_extra => '',href_class => '',quote_class => '',quote_extra => '',script_escape => 1,protect_email => 0,email_message => '&#67;&#111;&#110;&#116;&#97;&#99;&#116;&#32;&#69;&#109;&#97;&#105;&#108;',highlight_class1 => '',highlight_class2 => '',highlight_class3 => '',highlight_class4 => '',highlight_class5 => '',highlight_class6 => '',highlight_class7 => '',);
 %AUBBC_TAGS = ('b' => 1,'br' => 2,'hr' => 2,'i' => 1,'sub' => 1,'sup' => 1,'pre' => 1,'ul' => 1, 'ol' => 1, 'small' => 1, 'big' => 1, 'li' => 1, 'p' => 1, 'h1' => 1, 'h2' => 1, 'h3' => 1, 'h4' => 1, 'h5' => 1,'h6' => 1, 'div' => 1, 'strong' => 1,);
}

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) = @_;
 if (keys %s_hash) {
  foreach (keys %s_hash) {
   $AUBBC{$_} = $s_hash{$_} if exists $AUBBC{$_};
  }
 }
 settings_prep();
 if ($DEBUG_AUBBC) {
  my $uabbc_settings = '';
  foreach (keys %AUBBC) {
   $uabbc_settings .= $_ . ' =>' . $AUBBC{$_} . ', ';
  }
 warn "AUBBC Settings Change: $uabbc_settings";
 }
}

sub get_setting {
 my ($self,$name) = @_;
 return $AUBBC{$name} if exists $AUBBC{$name};
}

sub code_highlight {
 my $text_code = shift;
 warn "START code_highlight" if $DEBUG_AUBBC;
 $text_code =~ s{:}{&#58;}go;
 $text_code =~ s{\[}{&#91;}go;
 $text_code =~ s{\]}{&#93;}go;
 $text_code =~ s{\{}{&#123;}go;
 $text_code =~ s{\}}{&#125;}go;
 $text_code =~ s{%}{&#37;}go;
 $text_code =~ s{\s{1};}{ &#59;}go;
 $text_code =~ s{&lt;}{&#60;}go;
 $text_code =~ s{&gt;}{&#62;}go;
 $text_code =~ s{&quot;}{&#34;}go;
 if ($AUBBC{highlight}) {
  warn "START block highlight" if $DEBUG_AUBBC;
  $text_code =~ s{\z}{<br$AUBBC{html_type}>}go if $text_code !~ m/<br$AUBBC{html_type}>\z/io;
  $text_code =~ s{(&#60;&#60;(\w+);(?s).*?\b\2\b)}{<span$AUBBC{highlight_class1}>$1</span>}go;
  $text_code =~ s{(?<![\&\$])(\#.*?(?:<br$AUBBC{html_type}>))}{<span$AUBBC{highlight_class2}>$1</span>}igo;
  $text_code =~ s{(&#39;(?s).*?(?<!&#92;)&#39;)}{<span$AUBBC{highlight_class3}>$1</span>}go;
  $text_code =~ s{(&#34;(?s).*?(?<!&#92;)&#34;)}{<span$AUBBC{highlight_class4}>$1</span>}go;
  $text_code =~ s{(?<![\#|\w|\d])(\d+)(?!\w)}{<span$AUBBC{highlight_class5}>$1</span>}go;
  $text_code =~ 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>}go;
  $text_code =~ s{(?<!&#92;)((?:&#37;|\$|\@)\w+(?:(?:&#91;.+?&#93;|&#123;.+?&#125;)+|))}{<span$AUBBC{highlight_class7}>$1</span>}go;
  warn "END block highlight" if $DEBUG_AUBBC;
 }
 warn "END code_highlight" if $DEBUG_AUBBC;
 return $text_code;
}

sub do_ubbc {
 my ($self,$message) = @_;
 warn "ENTER do_ubbc $self" if $DEBUG_AUBBC;
 $message =~ s{\[(?:c|code)\](?s)(.+?)\[/(?:c|code)\]} {
<div$AUBBC{code_class}><code>
${\code_highlight($1)}
</code></div>$AUBBC{code_extra}
}isg;
 $message =~ s{\[(?:c|code)=(.+?)\](?s)(.+?)\[/(?:c|code)\]} {
# $1:<br$AUBBC{html_type}><div$AUBBC{code_class}><code>
${\code_highlight($2)}
</code></div>$AUBBC{code_extra}
}isg;

 if (!$AUBBC{no_img}) {
  while ($message =~ s{\[(img|right_img|left_img)\](.+?)\[/img\]} {
   my $tmp = $2;
   my $tmp2 = $1;
   if ($tmp !~ m/\A\w+:\/\/|\//i || $tmp =~ m/\?|\#|\.\bjs\b/i) {
    $tmp = "[<font color=red>$BAD_MESSAGE</font>]$tmp2";
   }
    else {
     if ($AUBBC{icon_image}) {
     if($tmp2 eq 'img') { $tmp = "<a href=\"$tmp\"$AUBBC{href_target}$AUBBC{href_class}><img src=\"$tmp\" width=\"$AUBBC{image_width}\" height=\"$AUBBC{image_hight}\" alt=\"\" border=\"$AUBBC{image_border}\"$AUBBC{html_type}></a>$AUBBC{image_wrap}"; }
     elsif($tmp2 eq 'right_img') { $tmp = "<a href=\"$tmp\"$AUBBC{href_target}$AUBBC{href_class}><img align=\"right\" src=\"$tmp\" border=\"$AUBBC{image_border}\" width=\"$AUBBC{image_width}\" height=\"$AUBBC{image_hight}\" alt=\"\"$AUBBC{html_type}></a>$AUBBC{image_wrap}"; }
     elsif($tmp2 eq 'left_img') { $tmp = "<a href=\"$tmp\"$AUBBC{href_target}$AUBBC{href_class}><img align=\"left\" src=\"$tmp\" border=\"$AUBBC{image_border}\" width=\"$AUBBC{image_width}\" height=\"$AUBBC{image_hight}\" alt=\"\"$AUBBC{html_type}></a>$AUBBC{image_wrap}"; }
   }
    else {
     if($tmp2 eq 'img') { $tmp = "<img src=\"$tmp\" alt=\"\" border=\"$AUBBC{image_border}\"$AUBBC{html_type}>$AUBBC{image_wrap}"; }
     elsif($tmp2 eq 'right_img') { $tmp = "<img align=\"right\" src=\"$tmp\" border=\"$AUBBC{image_border}\" alt=\"\"$AUBBC{html_type}>$AUBBC{image_wrap}"; }
     elsif($tmp2 eq 'left_img') { $tmp = "<img align=\"left\" src=\"$tmp\" border=\"$AUBBC{image_border}\" alt=\"\"$AUBBC{html_type}>$AUBBC{image_wrap}"; }
   }
  }
 }exisog) {}
}

 $message =~ s{\[email\](?![\w\.\-\&\+]+\@[\w\.\-]+).+?\[/email\]}{\[<font color=red>$BAD_MESSAGE<\/font>\]email}isgo;
 if ($AUBBC{protect_email}) {
  $message =~ s/\[email\]([\w\.\-\&\+]+\@[\w\.\-]+)\[\/email\]/
   $self->protect_email($1, $AUBBC{protect_email});
  /exig;
 }
  else {
  $message =~ s{\[email\]([\w\.\-\&\+]+\@[\w\.\-]+)\[/email\]}{<A href="mailto:$1"$AUBBC{href_class}>$1</a>}isgo;
 }

 $message =~ s{\[color=([\w#]+)\](.*?)\[/color\]}{<span style="color:$1;">$2</span>}isgo;
 $message =~ s{\[quote=([\w\s]+)\]}{<span$AUBBC{quote_class}><small><strong>$1:</strong></small><br$AUBBC{html_type}>}isgo;
 $message =~ s{\[/quote\]}{</span>$AUBBC{quote_extra}}isgo;
 $message =~ s{\[quote\]}{<span$AUBBC{quote_class}>}isgo;
 $message =~ s{\[(left|right|center)\]}{<div style=\"text-align: $1;\">}isgo;
 $message =~ s{\[\/(?:left|right|center)\]}{</div>}isgo;
 $message =~ s{\[li=(\d+)\]}{<li value="$1">}isgo;
 $message =~ s{\[u\](.*?)\[/u\]}{<span style="text-decoration: underline;">$1</span>}isgo;
 $message =~ s{\[strike\](.*?)\[/strike\]}{<span style="text-decoration: line-through;">$1</span>}isgo;

 foreach (keys %AUBBC_TAGS) {
  if ($AUBBC_TAGS{$_} eq 1) {
   $message =~ s{\[$_\]}{<$_>}isg;
   $message =~ s{\[\/$_\]}{<\/$_>}isg;
  }
   elsif ($AUBBC_TAGS{$_} eq 2) {
   $message =~ s{\[$_\]}{<$_$AUBBC{html_type}>}isg;
  }
 }

 my $long_regex = '[\w\.\/\-\~\@\:\;\=]+(?:\?[\w\~\.\;\:\,\$\-\+\!\*\?/\=\&\@\#\%]+?)?';
 while ($message =~ s{\[url=(\w+\://$long_regex)\](.+?)\[/url\]} {
  my $tmp = $2;
  my $tmp2 = $1;
  $tmp =~ s/\./&#46;/gs;
  $tmp =~ s/\:/&#58;/gs;
  $tmp = "<a href=\"$tmp2\"$AUBBC{href_target}$AUBBC{href_class}>$tmp</a>";
 }exisog) {}

 $message =~
 s{(?<!["=\./\'\[\{\;])((?:\b\w+\b\://)$long_regex)}{<a href="$1"$AUBBC{href_target}$AUBBC{href_class}>$1</a>}isgo;

 warn "END do_ubbc $self" if $DEBUG_AUBBC;
 return $message;
}

sub protect_email {
 my ($self, $email, $option) = @_;
 my @key64 = ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z','0','1','2','3','4','5','6','7','8','9','+','/');
 my ($email1, $email2, $ran_num, $protect_email, @letters) = ('', '', '', '', split (//, $email));
 $protect_email = '[' if $option eq 3 || $option eq 4;
 foreach my $character (@letters) {
  $protect_email .= '&#' . ord($character) . ';' if ($option eq 1 || $option eq 2);
  $protect_email .= ord($character) . ',' if $option eq 3;
  $ran_num = int(rand(64)) || 0 if $option eq 4;
  $protect_email .= '\'' . (ord($key64[$ran_num]) ^ ord($character)) . '\',\'' . $key64[$ran_num] . '\',' if $option eq 4;
 }
 return "<a href=\"&#109;&#97;&#105;&#108;&#116;&#111;&#58;$protect_email\"$AUBBC{href_class}>$protect_email</a>" if $option eq 1;
 ($email1, $email2) = split ("&#64;", $protect_email) if $option eq 2;
 $protect_email = "'$email1' + '&#64;' + '$email2'" if $option eq 2;
 $protect_email =~ s/\,\z/]/g if $option eq 3 || $option eq 4;
 return <<JS if $option eq 2 || $option eq 3 || $option eq 4;
<a href="javascript:MyEmCode('$option',$protect_email);"$AUBBC{href_class}>$AUBBC{email_message}</a>
JS
}

sub js_print {
my $self = shift;
print <<JS;
Content-type: text/javascript

/*
AUBBC v$VERSION
Fully supports dynamic view in XHTML.
*/
function MyEmCode (type, content) {
 var returner = false;
 if (type == 4) {
 var farray= new Array(content.length,1);
  for(farray[1];farray[1]<farray[0];farray[1]++) {
   returner+=String.fromCharCode(content[farray[1]].charCodeAt(0)^content[farray[1]-1]);farray[1]++;
  }
 } else if (type == 3) {
  for (i = 0; i < content.length; i++) { returner+=String.fromCharCode(content[i]); }
 } else if (type == 2) { returner=content; }
 if (returner) { window.location='mailto:'+returner; }
}
JS
exit(0);
}

sub do_build_tag {
 my ($self,$message) = @_;
 if ($DEBUG_AUBBC) {
  warn "ENTER do_build_tag $self";
  my $uabbc_settings = '';
  foreach (keys %Build_AUBBC) {
   $uabbc_settings .= $_ . ' =>' . $Build_AUBBC{$_} . ', ';
  }
 warn "Build tags $uabbc_settings";
 }

 foreach (keys %Build_AUBBC) {
  warn "ENTER foreach do_build_tag $self" if $DEBUG_AUBBC;
  $message =~ s/(\[$_\:\/\/([$Build_AUBBC{$_}[0]]+)\])/
   my $ret = $self->do_sub( $_, $2 , $Build_AUBBC{$_}[2] ) || '';
   $ret ? $ret : $1;
  /exig if ($Build_AUBBC{$_}[1] eq 1);

  $message =~ s/(\[$_\](?s)([$Build_AUBBC{$_}[0]]+)\[\/$_\])/
   my $ret = $self->do_sub( $_, $2 , $Build_AUBBC{$_}[2] ) || '';
   $ret ? $ret : $1;
  /exig if ($Build_AUBBC{$_}[1] eq 2);

  $message =~ s/(\[$_\])/
   my $ret = $self->do_sub( $_, '' , $Build_AUBBC{$_}[2] ) || '';
   $ret ? $ret : $1;
  /exig if ($Build_AUBBC{$_}[1] eq 3);

  $message =~ s/\[$_\]/$Build_AUBBC{$_}[2]/isg if ($Build_AUBBC{$_}[1] eq 4);
 }
 warn "END do_build_tag $self" if $DEBUG_AUBBC;
 return $message;
}

sub do_sub {
 my ($self, $key, $term, $fun) = @_;
 warn "ENTER check_build_tag" if $DEBUG_AUBBC;
 $fun = \&{$fun};
 warn "END check_build_tag" if $DEBUG_AUBBC;
 return $fun->($key, $term) || '';
}

sub add_build_tag {
 my ($self,%NewTag) = @_;
 warn "ENTER add_build_tag $self" if $DEBUG_AUBBC;
 if ($NewTag{type} ne 4) {
  unless (exists $NewTag{function} && exists &{$NewTag{function}} && (ref $NewTag{function} eq 'CODE' || ref $NewTag{function} eq '')) {
   die "Usage: add_build_tag - function 'Undefined subroutine' => '$NewTag{function}'";
  }
 }
 $NewTag{pattern} = 'l' if ($NewTag{type} eq 3 || $NewTag{type} eq 4);
 if ($NewTag{name} =~ m/\A[\w\-]+\z/i && ($NewTag{pattern} =~ m/\A[lns_:\-,]+\z/i || $NewTag{pattern} eq 'all')) {
  if ($NewTag{name} && $NewTag{pattern} && $NewTag{type}) {
   if ($NewTag{pattern} eq 'all') {
    $NewTag{pattern} = '\w\:\s\/\.\;\&\=\?\-\+\#\%\~\,';
   }
    else {
    my ($p_ct,@pat_split) = ( 0, () );
    my %is_pat = ('l' => 'a-z', 'n' => '\d', '_' => '\_', ':' => '\:', 's' => '\s', '-' => '\-');
    @pat_split = split (/\,/, $NewTag{pattern});
    $NewTag{pattern} = '';
    foreach (@pat_split) {
     last if $p_ct == 6;
     $p_ct++;
     $NewTag{pattern} .= $is_pat{$_} if exists $is_pat{$_};
    }
   }
   $Build_AUBBC{$NewTag{name}} = [$NewTag{pattern}, $NewTag{type}, $NewTag{function}];
  }
  warn "Added Build_AUBBC Tag ".$Build_AUBBC{$NewTag{name}} if $DEBUG_AUBBC && $Build_AUBBC{$NewTag{name}};
 }
  else {
   die "Usage: add_build_tag - Bad name or pattern format";
 }
 warn "END add_build_tag $self" if $DEBUG_AUBBC;
}

sub remove_build_tag {
 my ($self,$name,$type) = @_;
 warn "ENTER remove_build_tag $self" if $DEBUG_AUBBC;
 delete $Build_AUBBC{$name} if exists $Build_AUBBC{$name} && !$type; # clear one
 %Build_AUBBC = () if $type && !$name; # clear all
 warn "END remove_build_tag $self" if $DEBUG_AUBBC;
}

sub do_unicode {
 my ($self,$message) = @_;
 warn "ENTER do_unicode $self" if $DEBUG_AUBBC;
 $message =~ s{\[utf://(\#?[0-9a-z]+)\]}{&$1;}igso;
 $message =~ s{&amp;(\#?[0-9a-z]+);}{&$1;}igso;
 warn "END do_unicode $self" if $DEBUG_AUBBC;
 return $message;
}

sub do_smileys {
 my ($self,$message) = @_;
 warn "ENTER do_smileys $self" if $DEBUG_AUBBC;
 foreach (keys %SMILEYS) {
  $message =~ s{\[$_\]}{<img src="$AUBBC{images_url}/smilies/$SMILEYS{$_}" alt="$_" border="$AUBBC{image_border}"$AUBBC{html_type}>$AUBBC{image_wrap}}isg if $_ && exists $SMILEYS{$_};
 }
 warn "END do_smileys $self" if $DEBUG_AUBBC;
 return $message;
}

sub smiley_hash {
 my ($self,%s_hash) = @_;
 warn "ENTER smiley_hash $self" if $DEBUG_AUBBC;
 %SMILEYS = %s_hash;
 $AUBBC{smileys} = ($AUBBC{smileys} && %SMILEYS && $AUBBC{images_url} =~ m/\A\w+:\/\//)
  ? '1'
  : '';
 warn "END smiley_hash $self" if $DEBUG_AUBBC;
}

sub do_all_ubbc {
 my ($self,$message) = @_;
 warn "ENTER do_all_ubbc $self" if $DEBUG_AUBBC;
 $message = '' unless defined $message && $message;
 $message = $self->script_escape($message) if $AUBBC{script_escape} && $message;
 $message =~ s{&(?!\#?[0-9a-z]+;)}{&amp;}gsio if $AUBBC{fix_amp} && $message;
 if ($message && !$AUBBC{no_bypass} && $message =~ s/\A\#none//go) {
  warn "START&END no_bypass $self" if $DEBUG_AUBBC;
 }
  elsif ($message) {
  $message = $self->escape_aubbc($message) if $AUBBC{aubbc_escape};
  $message = (!$AUBBC{no_bypass} && $message =~ s/\A\#noubbc//go)
   ? $message
   : $self->do_ubbc($message) if !$AUBBC{for_links} && $AUBBC{aubbc};
  $message = (!$AUBBC{no_bypass} && $message =~ s/\A\#nobuild//go)
   ? $message
   : $self->do_build_tag($message) if !$AUBBC{for_links} && keys %Build_AUBBC;
  $message = (!$AUBBC{no_bypass} && $message =~ s/\A\#noutf//go)
   ? $message
   : $self->do_unicode($message) if $AUBBC{utf};
  $message = (!$AUBBC{no_bypass} && $message =~ s/\A\#nosmileys//go)
   ? $message
   : $self->do_smileys($message) if $AUBBC{smileys};
 }
 warn "END do_all_ubbc $self" if $DEBUG_AUBBC;
 return $message;
}

sub escape_aubbc {
 my ($self, $message) = @_;
 warn "ENTER escape_aubbc $self" if $DEBUG_AUBBC;
 $message =~ s{\[\[}{\&#91;}go;
 $message =~ s{\]\]}{\&#93;}go;
 warn "END escape_aubbc $self" if $DEBUG_AUBBC;
 return $message;
}

sub script_escape {
 my ($self, $text, $option) = @_;
 warn "ENTER html_escape $self" if $DEBUG_AUBBC;
 return '' unless defined $text && $text;
 if (!$option) {
  $text =~ s{&}{&amp;}gsio;
  $text =~ s{\t}{ \&nbsp; \&nbsp; \&nbsp;}gso;
  $text =~ s{  }{ \&nbsp;}gso;
 }
 if ($option || !$option) {
  $text =~ s{"}{&#34;}gso;
  $text =~ s{<}{&#60;}gso;
  $text =~ s{>}{&#62;}gso;
  $text =~ s{'}{&#39;}gso;
  $text =~ s{\)}{&#41;}gso;
  $text =~ s{\(}{&#40;}gso;
  $text =~ s{\\}{&#92;}gso;
  $text =~ s{\|}{&#124;}gso;
 }
 $text =~ s{\n}{<br$AUBBC{html_type}>\n}go if !$option && $AUBBC{line_break};
 warn "END html_escape $self" if $DEBUG_AUBBC;
 return $text;
}

sub html_to_text {
 my ($self, $html, $option) = @_;
 warn "ENTER html_to_text $self" if $DEBUG_AUBBC;
 return '' unless defined $html && $html;
 if (!$option) {
  $html =~ s{&amp;}{&}gso;
  $html =~ s{ \&nbsp; \&nbsp; \&nbsp;}{\t}gso;
  $html =~ s{ \&nbsp;}{  }gso;
 }
 if ($option || !$option) {
  $html =~ s{&#34;}{"}gso;
  $html =~ s{&#60;}{<}gso;
  $html =~ s{&#62;}{>}gso;
  $html =~ s{&#39;}{'}gso;
  $html =~ s{&#41;}{\)}gso;
  $html =~ s{&#40;}{\(}gso;
  $html =~ s{&#92;}{\\}gso;
  $html =~ s{&#124;}{\|}gso;
 }
 $html =~ s{<br(?:\s?\/)?>\n?}{\n}gso if !$option && $AUBBC{line_break};
 warn "END html_to_text $self" if $DEBUG_AUBBC;
 return $html;
}

sub version {
 my ($self) = @_;
 return $VERSION;
}

1;

__END__

=pod

=head1 COPYLEFT

AUBBC.pm, v2.20 09/08/2010 By: N.K.A.

Advanced Universal Bulletin Board Code a Perl BBcode API

shakaflex@gmail.com
http://search.cpan.org/~sflex/

Note: 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, Massive Speed improvement version.

=cut
