summaryrefslogtreecommitdiff
path: root/lib/VNDB/BBCode.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/VNDB/BBCode.pm')
-rw-r--r--lib/VNDB/BBCode.pm190
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/&/&amp;/g;
- s/>/&gt;/g;
- s/</&lt;/g;
- s/\n/<br>/g if !$maxlength;
- s/\n/ /g if $maxlength;
+ if(!$opt{text}) {
+ s/&/&amp;/g;
+ s/>/&gt;/g;
+ s/</&lt;/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">&lt;hidden by spoiler settings&gt;</b><span class="charspoil charspoil_2">' :
- $charspoil == 2 ? '<b class="grayedout charspoil charspoil_-1">&lt;hidden by spoiler settings&gt;</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>&lt;hidden by spoiler settings&gt;</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