diff options
Diffstat (limited to 'lib/VNDB/BBCode.pm')
-rw-r--r-- | lib/VNDB/BBCode.pm | 190 |
1 files changed, 103 insertions, 87 deletions
diff --git a/lib/VNDB/BBCode.pm b/lib/VNDB/BBCode.pm index d11171c5..950dcb8b 100644 --- a/lib/VNDB/BBCode.pm +++ b/lib/VNDB/BBCode.pm @@ -5,9 +5,13 @@ use warnings; use Exporter 'import'; use TUWF::XML 'xml_escape'; -our @EXPORT = qw/bb2html bb2text bb_subst_links/; +our @EXPORT = qw/bb_format bb_subst_links/; # Supported BBCode: +# [b] .. [/b] +# [i] .. [/i] +# [u] .. [/u] +# [s] .. [/s] # [spoiler] .. [/spoiler] # [quote] .. [/quote] # [code] .. [/code] @@ -17,7 +21,8 @@ our @EXPORT = qw/bb2html bb2text bb_subst_links/; # dblink: v+, v+.+, d+#+, d+#+.+ # # Permitted nesting of formatting codes: -# spoiler -> url, raw, link, dblink +# inline = b,i,u,s,spoiler +# inline -> inline, url, raw, link, dblink # quote -> anything # code -> nothing # url -> raw @@ -29,10 +34,18 @@ our @EXPORT = qw/bb2html bb2text bb_subst_links/; # Returns: ($token, @arg) on successful parse, () otherwise. # Trivial open and close actions +sub _b_start { if(lc$_[1] eq '[b]') { push @{$_[0]}, 'b'; ('b_start') } else { () } } +sub _i_start { if(lc$_[1] eq '[i]') { push @{$_[0]}, 'i'; ('i_start') } else { () } } +sub _u_start { if(lc$_[1] eq '[u]') { push @{$_[0]}, 'u'; ('u_start') } else { () } } +sub _s_start { if(lc$_[1] eq '[s]') { push @{$_[0]}, 's'; ('s_start') } else { () } } sub _spoiler_start { if(lc$_[1] eq '[spoiler]') { push @{$_[0]}, 'spoiler'; ('spoiler_start') } else { () } } sub _quote_start { if(lc$_[1] eq '[quote]') { push @{$_[0]}, 'quote'; ('quote_start') } else { () } } sub _code_start { if(lc$_[1] eq '[code]') { push @{$_[0]}, 'code'; ('code_start') } else { () } } sub _raw_start { if(lc$_[1] eq '[raw]') { push @{$_[0]}, 'raw'; ('raw_start') } else { () } } +sub _b_end { if(lc$_[1] eq '[/b]') { pop @{$_[0]}; ('b_end' ) } else { () } } +sub _i_end { if(lc$_[1] eq '[/i]') { pop @{$_[0]}; ('i_end' ) } else { () } } +sub _u_end { if(lc$_[1] eq '[/u]') { pop @{$_[0]}; ('u_end' ) } else { () } } +sub _s_end { if(lc$_[1] eq '[/s]') { pop @{$_[0]}; ('s_end' ) } else { () } } sub _spoiler_end { if(lc$_[1] eq '[/spoiler]') { pop @{$_[0]}; ('spoiler_end') } else { () } } sub _quote_end { if(lc$_[1] eq '[/quote]' ) { pop @{$_[0]}; ('quote_end' ) } else { () } } sub _code_end { if(lc$_[1] eq '[/code]' ) { pop @{$_[0]}; ('code_end' ) } else { () } } @@ -65,10 +78,15 @@ sub _link { # Permitted actions to take in each state. The actions are run in order, if # none succeed then the token is passed through as text. # The "current state" is the most recent tag in the stack, or '' if no tags are open. +my @INLINE = (\&_link, \&_url_start, \&_raw_start, \&_b_start, \&_i_start, \&_u_start, \&_s_start, \&_spoiler_start); my %STATE = ( - '' => [ \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start], - spoiler => [\&_spoiler_end, \&_link, \&_url_start, \&_raw_start], - quote => [\&_quote_end, \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start], + '' => [ @INLINE, \&_quote_start, \&_code_start], + b => [\&_b_end, @INLINE], + i => [\&_i_end, @INLINE], + u => [\&_u_end, @INLINE], + s => [\&_s_end, @INLINE], + spoiler => [\&_spoiler_end, @INLINE], + quote => [\&_quote_end, @INLINE, \&_quote_start, \&_code_start], code => [\&_code_end ], url => [\&_url_end, \&_raw_start], raw => [\&_raw_end ], @@ -88,6 +106,14 @@ my %STATE = ( # # Tags: # text -> literal text, $raw is the text to display +# b_start -> start bold +# b_end -> end +# i_start -> start italic +# i_end -> end +# u_start -> start underline +# u_end -> end +# s_start -> start strike +# s_end -> end # spoiler_start -> start a spoiler # spoiler_end -> end # quote_start -> start a quote @@ -111,11 +137,11 @@ sub parse { my @stack; while($raw =~ m{(?: - \[ \/? (?i: spoiler|quote|code|url|raw ) [^\s\]]* \] | # tag - d[1-9][0-9]* \# [1-9][0-9]* (?: \.[1-9][0-9]* )? | # d+#+[.+] - [tdvprcs][1-9][0-9]*\.[1-9][0-9]* | # v+.+ - [tdvprcsugi][1-9][0-9]* | # v+ - (?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-] # link + \[ \/? (?i: b|i|u|s|spoiler|quote|code|url|raw ) [^\s\]]* \] | # tag + d[1-9][0-9]* \# [1-9][0-9]* (?: \.[1-9][0-9]* )? | # d+#+[.+] + [tdvprcswgi][1-9][0-9]*\.[1-9][0-9]* | # v+.+ + [tdvprcsugiw][1-9][0-9]* | # v+ + (?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-] # link )}xg) { my $token = $&; my $pre = substr $raw, $last, $-[0]-$last; @@ -147,110 +173,111 @@ FINAL: } -# charspoil: -# 0/undef/missing: Output <b class="spoiler">.. -# 1: Output 'charspoil_*' classes -# 2: Just output 'hidden by spoiler setting' message -# 3: Just output the spoilers, unmarked -sub bb2html { - my($input, $maxlength, $charspoil) = @_; +# Options: +# maxlength => 0/$n - truncate after $n visible characters +# inline => 0/1 - don't insert line breaks and don't format block elements +# +# One of: +# text => 0/1 - format as plain text, no tags +# onlyids => 0/1 - format as HTML, but only convert VNDBIDs, leave the rest alone (including [spoiler]s) +# default: format all to HTML. +# +# One of: +# delspoil => 0/1 - delete [spoiler] tags and its contents +# replacespoil => 0/1 - replace [spoiler] tags with a "hidden by spoiler settings" message +# keepsoil => 0/1 - keep the contents of spoiler tags without any special formatting +# default: format as <span class="spoiler">.. +sub bb_format { + my($input, %opt) = @_; + $opt{delspoil} = 1 if $opt{text} && !$opt{keepspoil}; my $incode = 0; + my $inspoil = 0; my $rmnewline = 0; my $length = 0; my $ret = ''; # escapes, returns string, and takes care of $length and $maxlength; also # takes care to remove newlines and double spaces when necessary - my $e = sub { + my sub e { local $_ = shift; s/^\n// if $rmnewline && $rmnewline--; s/\n{5,}/\n\n/g if !$incode; s/ +/ /g if !$incode; $length += length $_; - if($maxlength && $length > $maxlength) { - $_ = substr($_, 0, $maxlength-$length); + if($opt{maxlength} && $length > $opt{maxlength}) { + $_ = substr($_, 0, $opt{maxlength}-$length); s/\W+\w*$//; # cleanly cut off on word boundary } - s/&/&/g; - s/>/>/g; - s/</</g; - s/\n/<br>/g if !$maxlength; - s/\n/ /g if $maxlength; + if(!$opt{text}) { + s/&/&/g; + s/>/>/g; + s/</</g; + s/\n/<br>/g if !$opt{inline}; + } + s/\n/ /g if $opt{inline}; $_; }; parse $input, sub { my($raw, $tag, @arg) = @_; - #$ret .= "$tag {$raw}\n"; - #return 1; + return 1 if $inspoil && $tag ne 'spoiler_end' && ($opt{delspoil} || $opt{replacespoil}); if($tag eq 'text') { - $ret .= $e->($raw); - - } elsif($tag eq 'spoiler_start') { - $ret .= !$charspoil ? '<b class="spoiler">' : - $charspoil == 1 ? '<b class="grayedout charspoil charspoil_-1"><hidden by spoiler settings></b><span class="charspoil charspoil_2">' : - $charspoil == 2 ? '<b class="grayedout charspoil charspoil_-1"><hidden by spoiler settings></b><!--' : ''; - } elsif($tag eq 'spoiler_end') { - $ret .= !$charspoil ? '</b>' : - $charspoil == 1 ? '</span>' : - $charspoil == 2 ? '-->' : ''; + $ret .= e $raw; + } elsif($tag eq 'dblink') { + (my $link = $raw) =~ s/^d(\d+)\.(\d+)\.(\d+)$/d$1#$2.$3/; + $ret .= $opt{text} ? e $raw : sprintf '<a href="/%s">%s</a>', $link, e $raw; + + } elsif($opt{idonly}) { + $ret .= e $raw; + + } elsif($tag eq 'b_start') { $ret .= $opt{text} ? e '*' : '<strong>' + } elsif($tag eq 'b_end') { $ret .= $opt{text} ? e '*' : '</strong>' + } elsif($tag eq 'i_start') { $ret .= $opt{text} ? e '/' : '<em>' + } elsif($tag eq 'i_end') { $ret .= $opt{text} ? e '/' : '</em>' + } elsif($tag eq 'u_start') { $ret .= $opt{text} ? e '_' : '<span class="underline">' + } elsif($tag eq 'u_end') { $ret .= $opt{text} ? e '_' : '</span>' + } elsif($tag eq 's_start') { $ret .= $opt{text} ? e '-' : '<s>' + } elsif($tag eq 's_end') { $ret .= $opt{text} ? e '-' : '</s>' } elsif($tag eq 'quote_start') { - $ret .= '<div class="quote">' if !$maxlength; + $ret .= $opt{text} || $opt{inline} ? e '"' : '<div class="quote">'; $rmnewline = 1; } elsif($tag eq 'quote_end') { - $ret .= '</div>' if !$maxlength; + $ret .= $opt{text} || $opt{inline} ? e '"' : '</div>'; $rmnewline = 1; } elsif($tag eq 'code_start') { - $ret .= '<pre>' if !$maxlength; + $ret .= $opt{text} || $opt{inline} ? e '`' : '<pre>'; $rmnewline = 1; $incode = 1; } elsif($tag eq 'code_end') { - $ret .= '</pre>' if !$maxlength; + $ret .= $opt{text} || $opt{inline} ? e '`' : '</pre>'; $rmnewline = 1; $incode = 0; + } elsif($tag eq 'spoiler_start') { + $inspoil = 1; + $ret .= $opt{delspoil} || $opt{keepspoil} ? '' + : $opt{replacespoil} ? '<small><hidden by spoiler settings></small>' + : '<span class="spoiler">'; + } elsif($tag eq 'spoiler_end') { + $inspoil = 0; + $ret .= $opt{delspoil} || $opt{keepspoil} || $opt{replacespoil} ? '' : '</span>'; + } elsif($tag eq 'url_start') { - $ret .= sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]); + $ret .= $opt{text} ? '' : sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]); } elsif($tag eq 'url_end') { - $ret .= '</a>'; + $ret .= $opt{text} ? '' : '</a>'; } elsif($tag eq 'link') { - $ret .= sprintf '<a href="%s" rel="nofollow">%s</a>', xml_escape($raw), $e->('link'); - - } elsif($tag eq 'dblink') { - (my $link = $raw) =~ s/^d(\d+)\.(\d+)\.(\d+)$/d$1#$2.$3/; - $ret .= sprintf '<a href="/%s">%s</a>', $link, $e->($raw); + $ret .= $opt{text} ? e $raw : sprintf '<a href="%s" rel="nofollow">%s</a>', xml_escape($raw), e 'link'; } - !$maxlength || $length < $maxlength; - }; - $ret; -} - - -# Convert bbcode into plain text, stripping all tags and spoilers. [url] tags -# only display the title. -sub bb2text { - my $input = shift; - - my $inspoil = 0; - my $ret = ''; - parse $input, sub { - my($raw, $tag, @arg) = @_; - if($tag eq 'spoiler_start') { - $inspoil = 1; - } elsif($tag eq 'spoiler_end') { - $inspoil = 0; - } else { - $ret .= $raw if !$inspoil && $tag !~ /_(start|end)$/; - } - 1; + !$opt{maxlength} || $length < $opt{maxlength}; }; $ret; } @@ -268,26 +295,15 @@ sub bb_subst_links { my %lookup; parse $msg, sub { my($code, $tag) = @_; - $lookup{$1}{$2} = 1 if $tag eq 'dblink' && $code =~ /^(.)(\d+)/; + $lookup{$1} = 1 if $tag eq 'dblink' && $code =~ /^([vcpgis]\d+)$/; 1; }; return $msg unless %lookup; - # Now resolve the links - state $types = { # Query must return 'id' and 'name' columns, list of IDs will be appended to it. - v => 'SELECT id, title AS name FROM vn WHERE id IN', - c => 'SELECT id, name FROM chars WHERE id IN', - p => 'SELECT id, name FROM producers WHERE id IN', - g => 'SELECT id, name FROM tags WHERE id IN', - i => 'SELECT id, name FROM traits WHERE id IN', - s => 'SELECT s.id, sa.name FROM staff_alias sa JOIN staff s ON s.aid = sa.aid WHERE s.id IN', - }; - my %links; - for my $type (keys %$types) { - next if !$lookup{$type}; - my $lst = $TUWF::OBJ->dbAlli($types->{$type}, [keys %{$lookup{$type}}]); - $links{$type . $_->{id}} = $_->{name} for @$lst; - } + my $first = 0; + my %links = map +($_->{id}, $_->{title}), $TUWF::OBJ->dbAlli( + 'SELECT id, title[1+1] FROM (VALUES', (map +($first++ ? ',(' : '(', \"$_", '::vndbid)'), sort keys %lookup), ') n(id), item_info(NULL, n.id, NULL)' + )->@*; return $msg unless %links; # Now substitute |