^sub \w+\( results from the CPAN

^sub \w+\(

BBCode-Parser

view release on metacpan or search on metacpan

		}
		return $ret;
	},
);

my $p = BBCode::Parser->new();
my @output;
my @last = qw(html);
my $enc = undef;

sub doString($) {
	my $str = shift;
	$str = decode($enc, $str, 1) if defined $enc;

	my @o = @output;
	if(@o) {
		@last = @o;
	} else {
		@o = @last;
	}
	@output = ();

bbtest view on Meta::CPAN

	my $tree = $p->parse($str);
	foreach my $format (@o) {
		my $code = $FORMATS{$format};
		my $out = $code->($tree);
		$out .= "\n" unless $out =~ /\n$/;
		$out = encode($enc, $out, 1) if defined $enc;
		print $out;
	}
}

sub doFile($) {
	my $fn = shift;

	open(FILE, '<', $fn) or die qq(Failed to open "$fn": $!);
	binmode(FILE);
	my $text = join "", <FILE>;
	close(FILE);

	$text =~ tr/\x0D\x0A/\r\n/;
	$text =~ s/(?:\r\n|\r|\n)/\n/g;
	doString($text);

lib/BBCode/Body.pm view on Meta::CPAN

# $Id: Body.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Body;
use base qw(BBCode::Tag);
use BBCode::Tag::Block;
use BBCode::Util qw(multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub Tag($):method {
	return 'BODY';
}

sub BodyPermitted($):method {
	return 1;
}

sub BodyTags($):method {
	return qw(:ALL BODY);
}

sub bodyHTML($):method {
	return BBCode::Tag::Block::bodyHTML(shift);
}

sub toBBCode($):method {
	my $this = shift;
	my $ret = "";
	foreach($this->body) {
		$ret .= $_->toBBCode;
	}
	return multilineText $ret;
}

sub toHTML($):method {
	my $this = shift;
	my $pfx = $this->parser->css_prefix;
	my $body = $this->bodyHTML;
	return multilineText qq(<div class="${pfx}body">\n$body\n</div>\n);
}

1;

lib/BBCode/Parser.pm view on Meta::CPAN


Tags with the C<TEXT> class are plain text.  At the moment, the three tags
with the C<TEXT> class are C<[TEXT]>, C<[ENT]>, and C<[BR]>.

=back

=head1 METHODS

=cut

sub parseCSSPrefix($) {
	if(defined $_[0] and $_[0] =~ /^([\w-]*)$/) {
		return $1;
	} else {
		return undef;
	}
}

my @SETTINGS;
my %SETTINGS;

lib/BBCode/Parser.pm view on Meta::CPAN

			my $this = shift;
			if(@_) {
				return $this->set($attr, @_);
			} else {
				return $this->get($attr);
			}
		};
	}
}

sub _canonize($) {
	local $_ = $_[0];
	s/([[:upper:]]+)([[:upper:]][[:lower:]]+)/$1.'_'.lc($2)/eg;
	s/([[:lower:]])([[:upper:]]+)/$1.'_'.lc($2)/eg;
	s/([[:upper:]]+)/lc($1)/eg;
	return $_;
}

=head2 DEFAULT

	my $tree = BBCode::Parser->DEFAULT->parse($code);

C<DEFAULT> returns the default parser.  If you change the default parser, all
future parsers created with L<new()|/"new"> will incorporate your changes.
However, all existing parsers will be unaffected.

=cut

my $DEFAULT;
sub DEFAULT() {
	return $DEFAULT if defined $DEFAULT;

	$DEFAULT = bless {};

	foreach(@SETTINGS) {
		$DEFAULT->{$_->[0]} = $_->[2];
	}

	$DEFAULT->{_tags} = {};
	foreach(

lib/BBCode/Parser.pm view on Meta::CPAN

	# Prints "[IMG] is OK", since forbid('IMG') applies only to the clone.

C<clone> creates a new parser that copies the settings of an existing parser.
After cloning, the two parsers are completely independent; changing settings
in one does not affect the other.

If any arguments are given, they are handed off to L<the set() method|/"set">.

=cut

sub clone($%):method {
	my $this = shift;
	$this = $this->DEFAULT if not ref $this;
	my $that = bless {}, ref($this);
	%{$that->{_tags}} = %{$this->{_tags}};
	$that->{_permit} = $this->{_permit}->clone;
	$that->{_forbid} = $this->{_forbid}->clone;
	foreach(map { $_->[0] } @SETTINGS) {
		$that->{$_} = $this->get($_);
	}
	$that->set(@_) if @_;

lib/BBCode/Parser.pm view on Meta::CPAN


=head2 new

	my $parser = BBCode::Parser->new(%args);

C<new> creates a new C<BBCode::Parser>.  Any arguments
are handed off to L<the set() method|/"set">.

=cut

sub new($%):method {
	return shift->DEFAULT->clone(@_);
}

=head2 get

	if($parser->get('follow_override')) {
		# [URL FOLLOW] permitted
	} else {
		# [URL FOLLOW] forbidden
	}

C<get> fetches the current settings for the given parser.  See L</"SETTINGS">
for a list of available settings.

=cut

sub get($@):method {
	my $this = shift;
	my @ret;
	while(@_) {
		my $key = _canonize shift;
		croak qq(Unknown setting "$key") unless exists $SETTINGS{$key};
		warn qq(BUG: Setting $key does not exist) unless exists $this->{$key};
		push @ret, $this->{$key};
	}
	return @ret if wantarray;
	return $ret[0] if @ret == 1;

lib/BBCode/Parser.pm view on Meta::CPAN


=head2 set

	$parser->set(follow_override => 1);

C<set> alters the settings for the given parser. See L</"SETTINGS"> for a list
of available settings.

=cut

sub set($%):method {
	my $this = shift;
	while(@_) {
		my $key = _canonize shift;
		my $val = shift;
		croak qq(Unknown setting "$key") unless exists $SETTINGS{$key};
		$val = $SETTINGS{$key}->[1]->($val);
		$val = $SETTINGS{$key}->[2] if not defined $val;
		$this->{$key} = $val;
	}
	return $this;
}

=head2 addTag

TODO: Implement and document

=cut

sub addTag($$$):method {
	my($this, $tag, $class) = @_;
	return if $class eq "BBCode::Tag::$tag";
	die qq(Not implemented);
}

sub removeTag($$):method {
	die qq(Not implemented);
}

sub resolveTag($$):method {
	my($this, $tag) = @_;
	return tagLoadPackage($tag);
}

=head2 permit

	$parser->permit(qw(:INLINE !:LINK));

C<permit> adds TAGs and :CLASSes to the list of permitted tags.  Use '!' in
front of a tag or class to negate the meaning.

=cut

sub permit($@):method {
	my $this = shift;
	my $set = BBCode::TagSet->new(@_);
	$this->{_permit}->add($set);
	$this->{_forbid}->remove($set);
	return $this;
}

=head2 forbid

	$parser->forbid(qw(:ALL !:TEXT));

C<forbid> adds TAGs and :CLASSes to the list of forbidden tags.  Use '!' in
front of a tag or class to negate the meaning.

=cut

sub forbid($@):method {
	my $this = shift;
	my $set = BBCode::TagSet->new(@_);
	$this->{_forbid}->add($set);
	$this->{_permit}->remove($set);
	return $this;
}

=head2 isPermitted

	if($parser->isPermitted('IMG')) {
		# Yay, [IMG] tags
	} else {
		# Darn, no [IMG] tags
	}

C<isPermitted> checks if a tag is permitted by the current settings.

=cut

sub isPermitted($$):method {
	my($this,$tag) = @_;
	foreach(tagHierarchy($tag)) {
		return 0 if $this->{_forbid}->contains($_);
		return 1 if $this->{_permit}->contains($_);
	}
	return 0;
}

sub _args(\$) {
	my $ref = shift;
	my $ok = 0;
	my $arg = 0;
	my $k = undef;
	my $v = '';
	my @args;

	while(length $$ref > 0) {
		if($$ref =~ s/^\\//) {
			croak qq(Invalid BBCode: Backslash at end of text) unless $$ref =~ s/^(.)//s;

lib/BBCode/Parser.pm view on Meta::CPAN

		$$ref =~ s/^(.)//;
		$arg = 1;
		$v .= $1;
	}

	croak qq(Invalid BBCode: Unterminated tag) unless $ok;
	return @args if wantarray;
	return \@args;
}

sub _tokenize($$) {
	my($this,$ref) = @_;
	my(@tokens);

	while(length $$ref > 0) {
		if($$ref =~ s/^ ([^\[\]<&]+) //x) {
			push @tokens, [ 'TEXT', [ undef, $1 ] ];
			next;
		}

		if($$ref =~ s/^ \[ \s* \] //x) {

lib/BBCode/Parser.pm view on Meta::CPAN

			next;
		}

		$$ref =~ s/^ (.) //x;
		push @tokens, [ 'TEXT', [ undef, $1 ] ];
	}

	return \@tokens;
}

sub _top(\@) {
	my $stack = shift;
	return $$stack[$#$stack];
}

sub _parse($$$) {
	my($this,$root,$ref) = @_;
	my @st = ($root);

TOKEN:while(@$ref) {
		my $token = shift @$ref;

		# TODO: Add option to make "Illegal close tag" non-fatal
		if($token->[0] =~ s#^/##) {
			my @old = @st;
			while(@st) {

lib/BBCode/Parser.pm view on Meta::CPAN

	my $tree = $parser->parse('[b]BBCode[/b] text.');

C<parse> creates a parse tree for the given BBCode.  The result is a
tree of L<BBCode::Tag|BBCode::Tag> objects.  The most common use of the parse tree is
to convert it to HTML using L<BBCode::Tag-E<gt>toHTML()|BBCode::Tag/"toHTML">:

	my $html = $tree->toHTML;

=cut

sub parse($@):method {
	my $this = shift;
	$this = $this->new() unless ref $this;

	my $text = join "\n", @_;
	$text =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F\x7F-\x9F]+//;
	$text =~ s/(?:\r\n|\r|\n)/\n/g;

	my $tokens = $this->_tokenize(\$text);
	my $body = BBCode::Body->new($this);
	$this->_parse($body, $tokens);

lib/BBCode/Tag.pm view on Meta::CPAN

use warnings;
our $VERSION = '0.34';

# Note: Due to the huge differences between using BBCode::Tag and
#       subclassing BBCode::Tag, the POD is no longer interleaved
#       with the code.  It has been moved to the end of the file.


# Class methods meant for overriding

sub Tag($):method {
	my $class = shift;
	$class = ref($class) || $class;
	$class =~ s/'/::/g;
	$class =~ s/^.*:://;
	return $class;
}

sub Class($):method {
	return ();
}

sub BodyPermitted($):method {
	return 0;
}

sub BodyTags($):method {
	return ();
}

sub NamedParams($):method {
	return ();
}

sub RequiredParams($):method {
	return shift->NamedParams;
}

sub DefaultParam($):method {
	return undef;
}

sub OpenPre($):method {
	return "";
}

sub OpenPost($):method {
	return "";
}

sub ClosePre($):method {
	return "";
}

sub ClosePost($):method {
	return "";
}


# Instance methods meant for overriding

sub validateParam($$$):method {
	return $_[2];
}


# Methods meant to be inherited

sub new:method {
	my($pkg, $parser, $tag) = splice(@_, 0, 2);

	if($pkg eq __PACKAGE__) {

lib/BBCode/Tag.pm view on Meta::CPAN

		my($k,$v) = (undef,shift);
		($k,$v) = @$v if ref $v and UNIVERSAL::isa($v,'ARRAY');
		$k = $this->DefaultParam if not defined $k or $k eq '';
		croak "No default parameter for [".$this->Tag."]" if not defined $k;
		$this->param($k, $v);
	}

	return $this;
}

sub init($):method {
	my $this = shift;

	$this->{params} = {};
	foreach($this->NamedParams) {
		$this->{params}->{$_} = undef;
	}

	if($this->BodyPermitted) {
		$this->{body} = [];
		$this->{permit} = BBCode::TagSet->new;

lib/BBCode/Tag.pm view on Meta::CPAN

		if($this->BodyTags) {
			$this->{permit}->add($this->BodyTags);
		} else {
			$this->{permit}->add(':ALL');
		}
	}

	return $this;
}

sub parser($):method {
	return shift->{parser};
}

sub isPermitted($$):method {
	my($this,$child) = @_;
	if(exists $this->{body}) {
		foreach(tagHierarchy($child)) {
			return 0 if $this->{forbid}->contains($_);
			return 1 if $this->{permit}->contains($_);
		}
	}
	return 0;
}

sub forbidTags($@):method {
	my $this = shift;
	if(exists $this->{body}) {
		my $set;
		if(@_ == 1 and UNIVERSAL::isa($_[0],'BBCode::TagSet')) {
			$set = shift;
		} else {
			$set = BBCode::TagSet->new(@_);
		}
		$this->{permit}->remove($set);
		$this->{forbid}->add($set);
		foreach my $child ($this->body) {
			warn qq(Nested child is now forbidden) unless $this->isPermitted($child);
			$child->forbidTags($set);
		}
	}
	return $this;
}

sub body($):method {
	my $this = shift;
	if(exists $this->{body}) {
		return @{$this->{body}} if wantarray;
		return $this->{body};
	} else {
		return () if wantarray;
		return [];
	}
}

sub bodyHTML($):method {
	return multilineText map { scalar $_->toHTML } shift->body;
}

sub bodyText($):method {
	return multilineText map { scalar $_->toText } shift->body;
}

sub pushBody($@):method {
	my $this = shift;
	croak qq(Body contents not permitted) unless $this->BodyPermitted;
	while(@_) {
		my $tag = shift;
		if(ref $tag) {
			croak qq(Expected a BBCode::Tag) unless UNIVERSAL::isa($tag, 'BBCode::Tag');
		} else {
			$tag = BBCode::Tag->new($this->{parser}, 'TEXT', [ undef, $tag ]);
		}
		croak qq(Invalid tag nesting) if not $this->isPermitted($tag);
		$tag->forbidTags($this->{forbid});
		push @{$this->{body}}, $tag;
	}
	return $this;
}

sub param($$;$):method {
	my($this,$param) = splice @_, 0, 2;

	$param = $this->DefaultParam if not defined $param or $param eq '';
	croak qq(Missing parameter name) unless defined $param;
	$param = uc $param;
	croak qq(Invalid parameter name "$param") unless exists $this->{params}->{$param};

	if(@_) {
		$this->{params}->{$param} = $this->validateParam($param,@_);
	}

	return $this->{params}->{$param};
}

sub params($):method {
	my $this = shift;
	my @ret;
	foreach my $k ($this->NamedParams) {
		next unless exists $this->{params}->{$k};
		my $v = $this->{params}->{$k};
		push @ret, $k, $v if defined $v;
	}
	return @ret if wantarray;
	return { @ret };
}

sub replace($):method {
	return $_[0];
}

sub replaceBody($):method {
	my $this = shift->replace;
	my $body = $this->body;
	@$body = grep { defined } map { $_->replaceBody } @$body;
	return $this;
}

sub isFollowed($):method {
	my $this = shift;
	my $follow = $this->parser->follow_links;
	if($follow or $this->parser->follow_override) {
		eval {
			my $f = $this->param('FOLLOW');
			$follow = $f if defined $f;
		};
	}
	return $follow;
}

sub openInNewWindow($):method {
	my $this = shift;
	my($nw,$nwo) = $this->parser->get(qw(newwindow_links newwindow_override));
	if($nwo) {
		eval {
			my $user = $this->param('NEWWINDOW');
			$nw = $user if defined $user;
		};
	}
	return $nw;
}

sub toBBCode($):method {
	my $this = shift->replace;

	my $ret = $this->OpenPre.'['.$this->Tag;

	my @p = $this->params;

	if(@p) {
		my $def = $this->DefaultParam;
		my @params;

lib/BBCode/Tag.pm view on Meta::CPAN

	if($this->BodyPermitted) {
		foreach($this->body) {
			$ret .= $_->toBBCode;
		}
		$ret .= $this->ClosePre.'[/'.$this->Tag.']'.$this->ClosePost;
	}

	return multilineText $ret;
}

sub toHTML($):method {
	my $this = shift;
	my $that = $this->replace;
	if($this == $that) {
		croak qq(Not implemented);
	} else {
		return $that->toHTML;
	}
}

sub toText($):method {
	my $this = shift->replace;
	return $this->bodyText();
}

sub toLinkList($;$):method {
	my $this = shift->replace;
	my $ret = shift;
	$ret = [] if not defined $ret;
	foreach my $child ($this->body) {
		$child->toLinkList($ret);
	}
	return @$ret if wantarray;
	return $ret;
}

lib/BBCode/Tag/ABBR.pm view on Meta::CPAN

# $Id: ABBR.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::ABBR;
use base qw(BBCode::Tag::Inline);
use BBCode::Util qw(encodeHTML multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub NamedParams($):method {
	return qw(FULL);
}

sub RequiredParams($):method {
	return ();
}

sub DefaultParam($):method {
	return 'FULL';
}

sub toHTML($):method {
	my $this = shift;
	my $full = $this->param('FULL');
	my $ret = '<'.lc($this->Tag);
	if(defined $full) {
		$ret .= ' title="'.encodeHTML($full).'"';
	}
	$ret .= '>'.$this->bodyHTML.'</'.lc($this->Tag).'>';
	return multilineText $ret;
}

lib/BBCode/Tag/B.pm view on Meta::CPAN

# $Id: B.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::B;
use base qw(BBCode::Tag::Simple BBCode::Tag::Inline);
use BBCode::Util qw(multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub toText($):method {
	return multilineText '*'.shift->bodyText().'*';
}

1;

lib/BBCode/Tag/BR.pm view on Meta::CPAN

# $Id: BR.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::BR;
use base qw(BBCode::Tag);
use strict;
use warnings;
our $VERSION = '0.34';

sub Class($):method {
	return qw(TEXT INLINE);
}

sub toBBCode($):method {
	return "[BR]";
}

sub toHTML($):method {
	return "<br/>";
}

sub toText($):method {
	return "\n";
}

1;

lib/BBCode/Tag/Block.pm view on Meta::CPAN

# $Id: Block.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::Block;
use base qw(BBCode::Tag);
use strict;
use warnings;
our $VERSION = '0.34';

sub Class($):method {
	return qw(BLOCK);
}

sub BodyTags($):method {
	return qw(:BLOCK :INLINE);
}

sub bodyHTML($):method {
	local $_ = shift->SUPER::bodyHTML();
	s#^\s* (?: <br/> \s* )*  ##x;
	s# \s* (?: <br/> \s* )* $##x;
	return $_ unless wantarray;
	return split /(?<=\n)/, $_;
}

1;

lib/BBCode/Tag/CODE.pm view on Meta::CPAN

# $Id: CODE.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::CODE;
use base qw(BBCode::Tag::Block);
use BBCode::Util qw(encodeHTML multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub BodyTags($):method {
	return qw(:TEXT URL EMAIL);
}

sub NamedParams($):method {
	return qw(LANG);
}

sub RequiredParams($):method {
	return ();
}

sub validateParam($$$):method {
	my($this,$param,$val) = @_;
	if($param eq 'LANG') {
		$val =~ s/_/-/g;
		if($val =~ /^ \w+ (?: - \w+ )* $/x) {
			return $val;
		} else {
			die qq(Invalid value "$val" for [CODE LANG]);
		}
	}
	return $this->SUPER::validateParam($param,$val);
}

sub toHTML($):method {
	my $this = shift;
	my $pfx = $this->parser->css_prefix;

	my $lang = $this->param('LANG');
	my $body = $this->bodyHTML;
	$body =~ s#<br/>$##mg;
	$body =~ s#<br/>#\n#g;
	return multilineText
		qq(<div class="${pfx}code">\n),
		qq(<div class="${pfx}code-head">), (defined $lang ? encodeHTML(ucfirst "$lang ") : ""), qq(Code:</div>\n),

lib/BBCode/Tag/COLOR.pm view on Meta::CPAN

# $Id: COLOR.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::COLOR;
use base qw(BBCode::Tag::Inline);
use BBCode::Util qw(:parse encodeHTML);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub NamedParams($):method {
	return qw(VAL);
}

sub DefaultParam($):method {
	return 'VAL';
}

sub validateParam($$$):method {
	my($this,$param,$val) = @_;

	if($param eq 'VAL') {
		my $color = parseColor($val);
		if(defined $color) {
			return $color;
		} else {
			die qq(Invalid value "$val" for [COLOR]);
		}
	}
	return $this->SUPER::validateParam($param,$val);
}

sub replace($):method {
	my $this = shift;
	my $that = BBCode::Tag->new($this->parser, 'FONT', [ 'COLOR', $this->param('VAL') ]);
	@{$that->body} = @{$this->body};
	return $that;
}

1;

lib/BBCode/Tag/EMAIL.pm view on Meta::CPAN

# $Id: EMAIL.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::EMAIL;
use base qw(BBCode::Tag::URL);
use BBCode::Util qw(:parse encodeHTML);
use strict;
use warnings;
our $VERSION = '0.34';

sub validateParam($$$):method {
	my($this,$param,$val) = @_;

	if($param eq 'HREF') {
		my $url = parseMailURL($val);
		if(defined $url) {
			return $url->as_string;
		} else {
			die qq(Invalid value "$val" for [EMAIL]);
		}
	}
	return $this->SUPER::validateParam($param,$val);
}

sub replace($):method {
	my $this = shift;
	my $href = $this->param('HREF');
	if(not defined $href) {
		my $text = $this->bodyText;
		my $url = parseMailURL $text;
		if(not defined $url) {
			return BBCode::Tag->new($this->parser, 'TEXT', [ undef, $text ]);
		}
		$this->param(HREF => $url);
	}

lib/BBCode/Tag/ENT.pm view on Meta::CPAN

# $Id: ENT.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::ENT;
use base qw(BBCode::Tag);
use BBCode::Util qw(:parse decodeHTML);
use strict;
use warnings;
our $VERSION = '0.34';

sub Class($):method {
	return qw(TEXT INLINE);
}

sub NamedParams($):method {
	return qw(VAL);
}

sub DefaultParam($):method {
	return 'VAL';
}

sub validateParam($$$):method {
	my($this,$param,$val) = @_;
	if($param eq 'VAL') {
		my $ent = parseEntity($val);
		if(defined $ent) {
			return $ent;
		} else {
			die qq(Invalid value "$val" for [ENT]);
		}
	}
	return $this->SUPER::validateParam($param,$val);
}

sub toHTML($):method {
	my $this = shift;
	my $ent = $this->param('VAL');
	return "&$ent;" if defined $ent;
	return "";
}

sub toText($):method {
	my $this = shift;
	my $ent = $this->param('VAL');
	return decodeHTML("&$ent;") if defined $ent;
	return "";
}

1;

lib/BBCode/Tag/FONT.pm view on Meta::CPAN

# $Id: FONT.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::FONT;
use base qw(BBCode::Tag::Inline);
use BBCode::Util qw(:parse encodeHTML multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub NamedParams($):method {
	return qw(FACE SIZE COLOR);
}

sub RequiredParams($):method {
	return ();
}

sub DefaultParam($):method {
	return 'FACE';
}

sub validateParam($$$):method {
	my($this,$param,$val) = @_;

	if($param eq 'SIZE') {
		my $size = parseFontSize($val);
		if(defined $size) {
			return $size;
		} else {
			die qq(Invalid value [FONT SIZE="$val"]);
		}
	}

lib/BBCode/Tag/FONT.pm view on Meta::CPAN

		my $color = parseColor($val);
		if(defined $color) {
			return $color;
		} else {
			die qq(Invalid value [FONT COLOR="$val"]);
		}
	}
	return $this->SUPER::validateParam($param,$val);
}

sub toHTML($):method {
	my $this = shift->replace;
	my $ret = $this->bodyHTML;
	my $face = $this->param('FACE');
	my $size = $this->param('SIZE');
	my $color = $this->param('COLOR');
	my @css;
	push @css, sprintf "font-family: '%s'", encodeHTML($face)	if defined $face;
	push @css, sprintf "font-size: %s", encodeHTML($size)		if defined $size;
	push @css, sprintf "color: %s", encodeHTML($color)			if defined $color;
	return $ret unless @css;

lib/BBCode/Tag/HIDDEN.pm view on Meta::CPAN

# $Id: HIDDEN.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::HIDDEN;
use base qw(BBCode::Tag::Inline);
use BBCode::Util qw(multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub toHTML($):method {
	my $this = shift;
	my $pfx = $this->parser->css_prefix;
	my $css = $this->parser->css_direct_styles ? qq( style="color:#ddd;background-color:#ddd") : "";

	my $ret = qq(<span class="${pfx}hidden" title="Hidden text"$css>);
	foreach($this->body) {
		$ret .= $_->toHTML;
	}
	$ret .= '</span>';
	return multilineText $ret;

lib/BBCode/Tag/HR.pm view on Meta::CPAN

# $Id: HR.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::HR;
use base qw(BBCode::Tag::Block);
use strict;
use warnings;
our $VERSION = '0.34';

sub toBBCode($):method {
	return "[HR]";
}

sub toHTML($):method {
	return "<hr/>";
}

1;

lib/BBCode/Tag/HTML.pm view on Meta::CPAN

# $Id: HTML.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::HTML;
use base qw(BBCode::Tag);
use BBCode::Util qw(multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub NamedParams($):method {
	return qw(CODE);
}

sub DefaultParam($):method {
	return 'CODE';
}

sub toBBCode($):method {
	my $this = shift;
	return multilineText "[HTML]".$this->param('CODE')."[/HTML]";
}

sub toHTML($):method {
	my $this = shift;
	return multilineText $this->param('CODE');
}

1;

lib/BBCode/Tag/I.pm view on Meta::CPAN

# $Id: I.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::I;
use base qw(BBCode::Tag::Simple BBCode::Tag::Inline);
use BBCode::Util qw(multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub toText($):method {
	return multilineText '/'.shift->bodyText().'/';
}

1;

lib/BBCode/Tag/IMG.pm view on Meta::CPAN

# $Id: IMG.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::IMG;
use base qw(BBCode::Tag::Inline);
use BBCode::Util qw(:parse :text encodeHTML);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	my $this_or_class = shift;
	if(ref $this_or_class and defined $this_or_class->param('SRC')) {
		return 0;
	}
	return 1;
}

sub BodyTags($):method {
	return qw(:TEXT);
}

sub NamedParams($):method {
	return qw(SRC ALT W H TITLE);
}

sub RequiredParams($):method {
	return qw(SRC);
}

sub DefaultParam($):method {
	return 'SRC';
}

sub validateParam($$$):method {
	my($this,$param,$val) = @_;
	if($param eq 'SRC') {
		my $url = parseURL($val);
		if(defined $url) {
			if($url->scheme =~ /^(?:http|https|ftp|data)$/) {
				return $url->as_string;
			} else {
				die qq(Scheme "$url->scheme" not permitted for [IMG]);
			}
		} else {
			die qq(Invalid value "$val" for [IMG]);
		}
	}
	if($param eq 'W' or $param eq 'H') {
		return parseNum $val;
	}
	return $this->SUPER::validateParam($param,$val);
}

sub replace($):method {
	my $this = shift;
	my($src,$alt) = map { $this->param($_) } qw(SRC ALT);
	if(defined $src) {
		# [IMG SRC] has no body...
		delete $this->{body};
		delete $this->{permit};
		delete $this->{forbid};
	}
	return $this if defined $src and defined $alt;

lib/BBCode/Tag/IMG.pm view on Meta::CPAN

		$text = textALT $url;
		$this->param(SRC => $url);
	}
	$this->param(ALT => $text) if not defined $alt;
	return $this;

boom:
	return BBCode::Tag->new($this->parser, 'TEXT', [ undef, $text ]);
}

sub toHTML($):method {
	my $this = shift;
	my($src,$alt,$w,$h,$t) = map { $this->param($_) } qw(SRC ALT W H TITLE);

	if(defined $src and defined $alt) {
		if(not defined $t) {
			$t = $this->bodyText;
		}
		my $ret = '<img';
		$ret .= ' src="'.encodeHTML($src).'"';
		$ret .= ' alt="'.encodeHTML($alt).'"';
		$ret .= ' width="'.encodeHTML($w).'"' if defined $w;
		$ret .= ' height="'.encodeHTML($h).'"' if defined $h;
		$ret .= ' title="'.encodeHTML($t).'"' if defined $t;
		$ret .= ' />';
		return $ret;
	}
	return '';
}

sub toLinkList($;$):method {
	my $this = shift;
	my $ret = shift;
	$ret = [] if not defined $ret;

	my($src,$alt) = map { $this->param($_) } qw(SRC ALT);
	if(defined $src and defined $alt) {
		push @$ret, [ 1, $this->Tag, $src, $alt ];
	}
	return $this->SUPER::toLinkList($ret);
}

lib/BBCode/Tag/Inline.pm view on Meta::CPAN

# $Id: Inline.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::Inline;
use base qw(BBCode::Tag);
use strict;
use warnings;
our $VERSION = '0.34';

sub Class($):method {
	return qw(INLINE);
}

sub BodyTags($):method {
	return qw(:INLINE);
}

1;

lib/BBCode/Tag/LI.pm view on Meta::CPAN

# $Id: LI.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::LI;
use base qw(BBCode::Tag::Simple BBCode::Tag);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub BodyTags($):method {
	# Despite previous reports to the contrary, :BLOCK is fine here
	return qw(:BLOCK :INLINE);
}

sub toHTML($):method {
	return shift->SUPER::toHTML(@_)."\n";
}

1;

lib/BBCode/Tag/LIST.pm view on Meta::CPAN

# $Id: LIST.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::LIST;
use base qw(BBCode::Tag::Block);
use BBCode::Util qw(:parse encodeHTML multilineText createListSequence);
use BBCode::Tag::TEXT ();
use strict;
use warnings;
our $VERSION = '0.34';

sub Class($):method {
	return qw(LIST BLOCK);
}

sub BodyPermitted($):method {
	return 1;
}

sub BodyTags($):method {
	return qw(LI TEXT);
}

sub NamedParams($):method {
	return qw(TYPE START BULLET OUTSIDE);
}

sub RequiredParams($):method {
	return ();
}

sub DefaultParam($):method {
	return 'TYPE';
}

sub validateParam($$$):method {
	my($this,$param,$val) = @_;
	if($param eq 'TYPE') {
		return $val if parseListType($val) > 0;
		return '*';
	}
	if($param eq 'START') {
		return parseInt $val;
	}
	if($param eq 'BULLET') {
		my $url = parseURL($val);

lib/BBCode/Tag/LIST.pm view on Meta::CPAN

		} else {
			die qq(Invalid value "$val" for [LIST BULLET]);
		}
	}
	if($param eq 'OUTSIDE') {
		return parseBool $val;
	}
	return $this->SUPER::validateParam($param,$val);
}

sub _text($$):method {
	my $this = shift;
	my $text = shift;
	my $tag = BBCode::Tag->new($this->parser, 'TEXT', [ undef, $text ]);
	return $tag;
}

sub _li($$):method {
	my $this = shift;
	my $text = shift;
	my $tag = BBCode::Tag->new($this->parser, 'LI');
	$tag->pushBody($this->_text($text));
	return $tag;
}

sub pushBody($@):method {
	my $this = shift;
	my @tags;

	while(@_) {
		my $tag = shift;

		next if not defined $tag;

		if(not ref $tag) {
			unshift @_, $this->_text($tag);

lib/BBCode/Tag/LIST.pm view on Meta::CPAN

				next;
			}
		}

		push @tags, $tag;
	}

	return $this->SUPER::pushBody(@tags);
}

sub bodyHTML($):method {
	my $this = shift;
	my $html = '';
	foreach($this->body) {
		next unless UNIVERSAL::isa($_,'BBCode::Tag::LI');
		$html .= $_->toHTML;
#		die qq(\n> $html[$#html]\nOMGWTFBBQ?) if $html[$#html] =~ m#<br\s*/>#i;
	}
	return multilineText $html;
}

sub ListDefault($):method {
	return qw(ul);
}

sub toHTML($):method {
	my $this = shift;
	my @list = parseListType($this->param('TYPE'));
	@list = $this->ListDefault unless @list;

	my @css;
	if(@list > 1) {
		push @css, qq(list-style-type: $list[1]);
	}

	my $start = $this->param('START');

lib/BBCode/Tag/LIST.pm view on Meta::CPAN

	}

	my $css = @css ? qq( style=").join("; ", @css).qq(") : "";
	my $body = $this->bodyHTML;
	$body =~ s#(<li>)(<[uo]l>)#$1\n$2#g;
	$body =~ s/^/\t/mg;
	$body =~ s#^\t(?!</?li>)#\t\t#mg;
	return multilineText "<$list[0]$start$css>\n$body</$list[0]>\n";
}

sub toText($):method {
	my $this = shift;
	my @body = grep { $_->isa('BBCode::Tag::LI') } $this->body;
	my $seq = createListSequence($this->param('TYPE'), $this->param('START'), scalar(@body));

	my $text = "";
	foreach(@body) {
		$text .= $seq->()." ".$_->toText."\n";
	}
	return multilineText $text;
}

lib/BBCode/Tag/OL.pm view on Meta::CPAN

# $Id: OL.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::OL;
use base qw(BBCode::Tag::LIST);
use strict;
use warnings;
our $VERSION = '0.34';

sub ListDefault($):method {
	return qw(ol);
}

1;

lib/BBCode/Tag/Q.pm view on Meta::CPAN

# $Id: Q.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::Q;
use base qw(BBCode::Tag::Simple BBCode::Tag::Inline);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

1;

lib/BBCode/Tag/QUOTE.pm view on Meta::CPAN

# $Id: QUOTE.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::QUOTE;
use base qw(BBCode::Tag::Block);
use BBCode::Util qw(:parse encodeHTML multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub NamedParams($):method {
	return qw(SRC CITE FOLLOW);
}

sub RequiredParams($):method {
	return ();
}

sub DefaultParam($):method {
	return 'SRC';
}

sub validateParam($):method {
	my($this,$param,$val) = @_;
	if($param eq 'CITE') {
		my $url = parseURL($val);
		if(defined $url) {
			return $url->as_string;
		} else {
			die qq(Invalid value "$val" for [QUOTE CITE]);
		}
	}
	return $this->SUPER::validateParam($param,$val);
}

sub toHTML($):method {
	my $this = shift;
	my $pfx = $this->parser->css_prefix;

	my $who = $this->param('SRC');
	my $cite = $this->param('CITE');
	my $body = $this->bodyHTML;

	$who = (defined $who ? encodeHTML($who).' wrote' : 'Quote');
	if(defined $cite) {
		$who =

lib/BBCode/Tag/QUOTE.pm view on Meta::CPAN


	return multilineText
		qq(<div class="${pfx}quote">\n),
		qq(<div class="${pfx}quote-head">$who</div>\n),
		qq(<blockquote class="${pfx}quote-body"), (defined $cite ? ' cite="'.encodeHTML($cite).'"' : ''), qq(>\n),
		qq(<div>\n$body\n</div>\n),
		qq(</blockquote>\n),
		qq(</div>\n);
}

sub toText($):method {
	my $this = shift;

	my $who = $this->param('SRC');
	my $cite = $this->param('CITE');
	my $body = $this->bodyText;
	$body =~ s/^/\t/m;
	$body =~ s/^\t$//m;

	my $ret = '';
	$ret .= (defined $who ? "$who wrote" : 'Quote').":\n";
	$ret .= "Source: <URL:$cite>\n" if defined $cite;
	$ret .= $body;
	$ret .= "\n";
	return multilineText $ret;
}

sub toLinkList($;$):method {
	my $this = shift;
	my $ret = shift;
	$ret = [] if not defined $ret;

	my $src = $this->param('SRC');
	my $cite = $this->param('CITE');
	if(defined $cite) {
		push @$ret, [ $this->isFollowed, $this->Tag, $cite, $src ];
	}
	return $this->SUPER::toLinkList($ret);

lib/BBCode/Tag/S.pm view on Meta::CPAN

# $Id: S.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::S;
use base qw(BBCode::Tag::Inline);
use BBCode::Util qw(multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub toHTML($):method {
	my $this = shift;
	my $pfx = $this->parser->css_prefix;
	my $css = $this->parser->css_direct_styles ? qq( style="text-decoration: line-through") : "";

	my $ret = qq(<span class="${pfx}s"$css>);
	$ret .= $this->bodyHTML;
	$ret .= '</span>';
	return multilineText $ret;
}

sub toText($):method {
	return multilineText '~'.shift->bodyText().'~';
}

1;

lib/BBCode/Tag/SIZE.pm view on Meta::CPAN

# $Id: SIZE.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::SIZE;
use base qw(BBCode::Tag::Inline);
use BBCode::Util qw(:parse);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

sub NamedParams($):method {
	return qw(VAL);
}

sub DefaultParam($):method {
	return 'VAL';
}

sub validateParam($$$):method {
	my($this,$param,$val) = @_;

	if($param eq 'VAL') {
		my $size = parseFontSize($val);
		if(defined $size) {
			return $size;
		} else {
			die qq(Invalid value "$val" for [SIZE]);
		}
	}
	return $this->SUPER::validateParam($param,$val);
}

sub replace($):method {
	my $this = shift;
	my $that = BBCode::Tag->new($this->parser, 'FONT', [ 'SIZE', $this->param('VAL') ]);
	@{$that->body} = @{$this->body};
	return $that;
}

1;

lib/BBCode/Tag/SUB.pm view on Meta::CPAN

# $Id: SUB.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::SUB;
use base qw(BBCode::Tag::Simple BBCode::Tag::Inline);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

1;

lib/BBCode/Tag/SUP.pm view on Meta::CPAN

# $Id: SUP.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::SUP;
use base qw(BBCode::Tag::Simple BBCode::Tag::Inline);
use strict;
use warnings;
our $VERSION = '0.34';

sub BodyPermitted($):method {
	return 1;
}

1;

lib/BBCode/Tag/Simple.pm view on Meta::CPAN

# $Id: Simple.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::Simple;
use BBCode::Util qw(encodeHTML multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub toHTML($):method {
	my $this = shift;
	my $ret = "<".lc($this->Tag);

	my @p = $this->params;
	while(@p) {
		my($k,$v) = splice @p, 0, 2;
		$ret .= sprintf ' %s="%s"', lc($k), encodeHTML($v);
	}
	if($this->BodyPermitted) {
		$ret .= '>'.$this->bodyHTML.'</'.lc($this->Tag).'>';

lib/BBCode/Tag/TEXT.pm view on Meta::CPAN

# $Id: TEXT.pm 284 2006-12-01 07:51:49Z chronos $
package BBCode::Tag::TEXT;
use base qw(BBCode::Tag);
use BBCode::Util qw(encodeHTML multilineText);
use strict;
use warnings;
our $VERSION = '0.34';

sub Class($):method {
	return qw(TEXT INLINE);
}

sub NamedParams($):method {
	return qw(STR);
}

sub DefaultParam($):method {
	return 'STR';
}

sub toBBCode($):method {
	my $this = shift;
	local $_ = $this->param('STR');
	s/\[/[[/g;
	s/\]/]]/g;
	s/&/[ENT=amp]/g;
	s/<(?=UR[IL]:)/[ENT=lt]/gi;
	return multilineText $_;
}

sub toHTML($):method {
	my $this = shift;
	my $html = encodeHTML($this->param('STR'));
	$html =~ s/&#xA;/\n/g;
	$html =~ s#(?=\n)#<br/>#g;
	return multilineText $html;
}

sub toText($):method {
	return multilineText shift->param('STR');
}

1;

( run in 0.477 second using v1.01-cache-2.11-cpan-65fba6d93b7 )