diff options
author | Yorhel <git@yorhel.nl> | 2019-12-30 09:49:13 +0100 |
---|---|---|
committer | Yorhel <git@yorhel.nl> | 2019-12-30 09:49:13 +0100 |
commit | d79c982ee876502db2e1a12752667c6a198c2ddc (patch) | |
tree | ccd4a4e72e5b0d3dd412bed6aee58044e93893f0 /lib/VN3/BBCode.pm | |
parent | e146ed7bda12d369532e485ca0c2e3d823811854 (diff) |
Actually, let's get rid of v3 now that it doesn't work anymore anyway
Diffstat (limited to 'lib/VN3/BBCode.pm')
-rw-r--r-- | lib/VN3/BBCode.pm | 300 |
1 files changed, 0 insertions, 300 deletions
diff --git a/lib/VN3/BBCode.pm b/lib/VN3/BBCode.pm deleted file mode 100644 index a9922b4c..00000000 --- a/lib/VN3/BBCode.pm +++ /dev/null @@ -1,300 +0,0 @@ -package VN3::BBCode; - -use strict; -use warnings; -use v5.10; -use Exporter 'import'; -use TUWF::XML 'xml_escape'; - -our @EXPORT = qw/bb2html bb2text bb_subst_links/; - -# Supported BBCode: -# [spoiler] .. [/spoiler] -# [quote] .. [/quote] -# [code] .. [/code] -# [url=..] [/url] -# [raw] .. [/raw] -# link: http://../ -# dblink: v+, v+.+, d+#+, d+#+.+ -# -# Permitted nesting of formatting codes: -# spoiler -> url, raw, link, dblink -# quote -> anything -# code -> nothing -# url -> raw -# raw -> nothing - - -# State action function usage: -# _state_action \@stack, $match, $char_pre, $char_post -# Returns: ($token, @arg) on successful parse, () otherwise. - -# Trivial open and close actions -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 _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 { () } } -sub _raw_end { if(lc$_[1] eq '[/raw]' ) { pop @{$_[0]}; ('raw_end' ) } else { () } } -sub _url_end { if(lc$_[1] eq '[/url]' ) { pop @{$_[0]}; ('url_end' ) } else { () } } - -sub _url_start { - if($_[1] =~ m{^\[url=((https?://|/)[^\]>]+)\]$}i) { - push @{$_[0]}, 'url'; - (url_start => $1) - } else { () } -} - -sub _link { - my(undef, $match, $char_pre, $char_post) = @_; - - # Tags arent links - return () if $match =~ /^\[/; - - # URLs (already "validated" in the parsing regex) - return ('link') if $match =~ /^[hf]t/; - - # Now we're left with various forms of IDs, just need to make sure it's not surrounded by word characters - return ('dblink') if $char_pre !~ /\w/ && $char_post !~ /\w/; - - (); -} - - -# 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 %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], - code => [\&_code_end ], - url => [\&_url_end, \&_raw_start], - raw => [\&_raw_end ], -); - - -# Usage: -# -# parse $input, sub { -# my($raw, $token, @arg) = @_; -# return 1; # to continue processing, 0 to stop. (Note that _close tokens may still follow after stopping) -# }; -# -# $raw = the raw part that has been parsed -# $token = name of the parsed bbcode token, with some special cases (see below) -# @arg = $token-specific arguments. -# -# Tags: -# text -> literal text, $raw is the text to display -# spoiler_start -> start a spoiler -# spoiler_end -> end -# quote_start -> start a quote -# quote_end -> end -# code_start -> code block -# code_end -> end -# url_start -> [url=..], $arg[0] contains the url -# url_end -> [/url] -# raw_start -> [raw] -# raw_end -> [/raw] -# link -> http://.../, $raw is the link -# dblink -> v123, t13.1, etc. $raw is the dblink -# -# This function will ensure correct nesting of _start and _end tokens. -sub parse { - my($raw, $sub) = @_; - $raw =~ s/\r//g; - return if !$raw && $raw ne '0'; - - my $last = 0; - 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 - )}xg) { - my $token = $&; - my $pre = substr $raw, $last, $-[0]-$last; - my $char_pre = $-[0] ? substr $raw, $-[0]-1, 1 : ''; - $last = pos $raw; - my $char_post = substr $raw, $last, 1; - - # Pass through the unformatted text before the match - $sub->($pre, 'text') || goto FINAL if length $pre; - - # Call the state functions. Arguments to these functions are implicitely - # passed through @_, which avoids allocating a new stack for each function - # call. - my $state = $STATE{ $stack[$#stack]||'' }; - my @ret; - @_ = (\@stack, $token, $char_pre, $char_post); - for(@$state) { - @ret = &$_; - last if @ret; - } - $sub->($token, @ret ? @ret : ('text')) || goto FINAL; - } - - $sub->(substr($raw, $last), 'text') if $last < length $raw; - -FINAL: - # Close all tags. This code is a bit of a hack, as it bypasses the state actions. - $sub->('', "${_}_end") for reverse @stack; -} - - -sub bb2html { - my($input, $maxlength, $charspoil) = @_; - - my $incode = 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 { - 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); - 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; - $_; - }; - - parse $input, sub { - my($raw, $tag, @arg) = @_; - - #$ret .= "$tag {$raw}\n"; - #return 1; - - if($tag eq 'text') { - $ret .= $e->($raw); - - } elsif($tag eq 'spoiler_start') { - $ret .= !$charspoil - ? '<b class="spoiler">' - : '<b class="grayedout charspoil charspoil_-1"><hidden by spoiler settings></b><span class="charspoil charspoil_2 hidden">'; - } elsif($tag eq 'spoiler_end') { - $ret .= !$charspoil ? '</b>' : '</span>'; - - } elsif($tag eq 'quote_start') { - $ret .= '<div class="quote">' if !$maxlength; - $rmnewline = 1; - } elsif($tag eq 'quote_end') { - $ret .= '</div>' if !$maxlength; - $rmnewline = 1; - - } elsif($tag eq 'code_start') { - $ret .= '<pre>' if !$maxlength; - $rmnewline = 1; - $incode = 1; - } elsif($tag eq 'code_end') { - $ret .= '</pre>' if !$maxlength; - $rmnewline = 1; - $incode = 0; - - } elsif($tag eq 'url_start') { - $ret .= sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]); - } elsif($tag eq 'url_end') { - $ret .= '</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); - } - - !$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; - }; - $ret; -} - - -# Turn (most) 'dblink's into [url=..] links. This function relies on TUWF to do -# the database querying, so can't be used from Multi. -# Doesn't handle: -# - d+, t+, r+ and u+ links -# - item revisions -sub bb_subst_links { - my $msg = shift; - - # Parse a message and create an index of links to resolve - my %lookup; - parse $msg, sub { - my($code, $tag) = @_; - $lookup{$1}{$2} = 1 if $tag eq 'dblink' && $code =~ /^(.)(\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.id 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; - } - return $msg unless %links; - - # Now substitute - my $result = ''; - parse $msg, sub { - my($code, $tag) = @_; - $result .= $tag eq 'dblink' && $links{$code} - ? sprintf '[url=/%s]%s[/url]', $code, $links{$code} - : $code; - 1; - }; - return $result; -} - - -1; |