[[! use Time::CTime (); use Algorithm::Diff 'sdiff'; use POSIX ('ceil', 'floor'); my %p; # $X->{page} global page data my %d; # $X->{page}->{$p} local page data # redefine _hchar - usually a bad idea, but who cares sub _hchar {local$_=shift||return'';s/&/&/g;s//>/g;s/"/"/g;s/\r?\n/
\n/g;return$_;} sub formatdate {return _hchar(Time::CTime::strftime($_[0],gmtime($_[1]||0)))||'';} sub txt {local$_=shift||return'';s/&/&/g;s//>/g;return$_;} sub art2str {my$r='';$r.=($r?' & ':'').$_->{name}foreach (@{$_[0]->{artists}});return $_[1]?$r:_hchar($r);} sub calctime {my$r=shift;return'0:00:00'if!$r;my$x=sprintf'%d:%02d:%02d',int($r/3600),int(($r%3600)/60),($r%3600)%60;return $x;} sub shorten {local$_=shift||return'';return length>$_[0]?substr($_,0,$_[0]-3).'...':$_}; # Date string format: yyyy-mm-dd # y = 0 -> Unknown # y = 9999 -> TBA (To Be Announced) # m = 0 -> Month + day unknown, year known # d = 0 -> Day unknown, month + year known sub datestr { my $d = $_[0]||'00000000'; my @d = map { int } $1, $2, $3 if $d =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; return 'unknown' if $d[0] == 0; my $r = sprintf !$d[1] ? '%04d' : !$d[2] ? '%04d-%02d' : '%04d-%02d-%02d', @d; my $b = $r gt Time::CTime::strftime("%Y-%m-%d", gmtime()); $r = 'TBA' if $d[0] == 9999; return ($b?'':'').$r.($b?'':''); } sub mediastr { return join(', ', map { $_->{medium} =~ /^(cd|dvd|gdr|blr)$/ ? sprintf('%d %s%s', $_->{qty}, $VNDB::MED->{$_->{medium}}, $_->{qty}>1?'s':'') : $VNDB::MED->{$_->{medium}} } @{$_[0]}); } sub sortbut { # url, col my $r=' '; my $u = _hchar($_[0]); $u .= $u =~ /\?/ ? ';' : '?'; for ('a', 'd') { my $chr = $_ eq 'd' ? "\x{25BE}" : "\x{25B4}"; $r .= $d{order}[0] eq $_[1] && $d{order}[1] eq $_ ? $chr : sprintf '%s', $u, $_[1], $_, $chr; } return $r; } sub pagebut { # url my @br; my $ng = $_[0] =~ /\?/ ? ';' : '?'; push @br, sprintf '<- previous', $_[0].($d{page}-2 ? $ng.'p='.($d{page}-1) : '') if $d{page} > 1; push @br, sprintf 'next ->', $_[0].$ng.'p='.($d{page}+1) if $d{npage}; return $#br >= 0 ? ('

( '.join(' | ', @br).' )

') : ''; } sub wraplong { # text, margin local $_ = $_[0]; my $m = $_[1]/2; s/([^\s\r\n]{$m})([^\s\r\n])/$1 $2/g; return $_; } sub wordsplit { # split a string into an array of words, but make sure to not split HTML tags # return [ split //, $_[0] ]; my @a; my $in=''; for (split /\s+/, $_[0]) { my $gt = () = />/g; my $lt = () = / $lt) { push @a, $in.$_; $in=''; } elsif($lt > $gt || $in) { $in .= $_.' '; } else { push @a, $_; }; } push @a, $in if $in; return \@a; } sub cdiff { # obj1, obj2, @items->[ short, name, serialise, diff, [parsed_x, parsed_y] ] my($x, $y, @items, @c) = @_; # serialise = 0 -> integer, 1 -> string, CODEref -> code my $type = defined $$y{minage} ? 'r' : defined $$y{length} ? 'v' : 'p'; my $pre = '
'. ($$y{next} ? qq|later revision ->| : ''). ($x ? qq|<- earlier revision| : ''). qq|$type$$y{id} 
|; if(!$x) { # just show info about the revision if there is no previous edit return $pre.qq|
Revision $$y{cid} (edit)
By $$y{username} on |. formatdate('%Y-%m-%d at %R', $$y{added}).'
Edit summary:

'. summary($$y{comments}, 0, '[no summary]').'
'; } for (@items) { $_->[4] = !$_->[2] ? $x->{$_->[0]}||'0' : !ref($_->[2]) ? _hchar(wraplong($x->{$_->[0]}||'[empty]',60)) : &{$_->[2]}($x->{$_->[0]})||'[empty]'; $_->[5] = !$_->[2] ? $y->{$_->[0]}||'0' : !ref($_->[2]) ? _hchar(wraplong($y->{$_->[0]}||'[empty]',60)) : &{$_->[2]}($y->{$_->[0]})||'[empty]'; push(@c, $_) if $_->[4] ne $_->[5]; if($_->[3] && $_->[4] ne $_->[5]) { my($rx,$ry,$ch) = ('','','u'); for (sdiff(wordsplit($_->[4]), wordsplit($_->[5]))) { if($ch ne $_->[0]) { if($ch ne 'u') { $rx .= ''; $ry .= ''; } $rx .= '' if $_->[0] eq '-' || $_->[0] eq 'c'; $ry .= '' if $_->[0] eq '+' || $_->[0] eq 'c'; } $ch = $_->[0]; $rx .= $_->[1].' ' if $ch ne '+'; $ry .= $_->[2].' ' if $ch ne '-'; } $_->[4] = $rx; $_->[5] = $ry; } } return $pre.''. qq|'. qq|'. ''. join('',map{ '' } @c).'
 Revision $$x{cid} (edit)
By $$x{username} on |.formatdate('%Y-%m-%d at %R', $$x{added}).'
Revision $$y{cid} (edit)
By $$y{username} on |.formatdate('%Y-%m-%d at %R', $$y{added}).'
 Edit summary of revision '.$$y{cid}.'

'.summary($$y{comments}, 0, '[no summary]').'

'.$_->[1].''.$_->[4].''.$_->[5].'
'; } sub summary { # cmd, len, def return $_[2]||'' if !$_[0]; my $res = ''; my $len = 0; my $as = 0; for (split / /, $_[0]) { next if !defined $_ || $_ eq ''; my $l = length; s/\&/&/g; s/>/>/g; s/]+)\]//) { $l -= length($1)+6; $as++; } if(!$as && s/(http|https):\/\/(.+[0-9a-zA-Z\/])/link<\/a>/) { $l = 4; } elsif(!$as) { s/^([uvpr][0-9]+)[^\w]*$/$1<\/a>/; } while(s/\[\/url\]/<\/a>/) { $l -= 6; $as--; } $len += $l + 1; last if $_[1] && $len > $_[1]; $res .= "$_ "; } $res =~ y/\r\n/ / if $_[1]; $res =~ s/\r?\n/
/g if !$_[1]; $res =~ s/ +$//; $res .= '
' x $as if $as; $res .= '...' if $_[1] && $len > $_[1]; return $res; } sub ttabs { # [vrp], obj, sel my($t, $o, $s) = @_; $s||=''; my @act = ( !$s?'%s':'%1$s', $$o{locked} ? 'locked for editing' : (), $p{Authlock} ? sprintf('%s', $$o{locked} ? 'unlock' : 'lock') : (), $p{Authdel} ? ( 'del', sprintf('%s', $t eq 'v' ? ' id="vhide"' : '', $$o{hidden} ? 'unhide' : 'hide') ) : (), !$$o{locked} || ($p{Authedit} && $p{Authlock}) ? ($s eq 'edit' ? 'edit' : 'edit') : (), $p{Authhist} ? ($s eq 'hist' ? 'history' : 'history') : (), ); return '

< '.join(' - ', map { sprintf $_, $t.$$o{id} } @act).' >

'.( $t eq 'v' ? qq| | : $t eq 'r' ? qq| | : '' ); } my %pagetitles = ( faq => 'Frequently Asked Questions', userlogin => 'Login', userreg => 'Register a new account', userpass => 'Forgot your password?', home => 'Visual Novel Database', pbrowse => 'Browse producers', userlist => 'Browse users', myvotes => sub { return $p{myvotes}{user}{username} eq $p{AuthUsername} ? 'My votes' : ('Votes by '.$p{myvotes}{user}{username}); }, userpage => sub { return 'User: '.$p{userpage}{user}{username} }, vnlist => sub { return $p{vnlist}{user}{username} eq $p{AuthUsername} ? 'My visual novel list' : ($p{vnlist}{user}{username}.'\'s visual novel list'); }, useredit => sub { return !$p{useredit}{adm} ? 'My account' : 'Edit '.$p{useredit}{form}{username}.'\'s account'; }, ppage => sub { return $p{ppage}{prod}{name} }, pedit => sub { return $p{pedit}{id} ? sprintf('Edit %s', $p{pedit}{form}{name}) : 'Add a new producer'; }, vnedit => sub { return $p{vnedit}{id} ? sprintf('Edit %s', $p{vnedit}{form}{title}) : 'Add a new visual novel'; }, redit => sub { return $p{redit}{id} ? sprintf('Edit %s', $p{redit}{rel}{title}) : sprintf('Add release to %s', $p{redit}{vn}{title}); }, vnpage => sub { return $p{vnpage}{vn}{title}; }, vnrg => sub { return 'Relations for '.$p{vnrg}{vn}{title} }, vnstats => sub { return 'User statistics for '.$p{vnstats}{vn}{title} }, vnbrowse => sub { return $p{vnbrowse}{chr} eq 'search' ? sprintf 'Search results for "%s"', $p{searchquery} : $p{vnbrowse}{chr} eq 'cat' ? 'Browse categories' : $p{vnbrowse}{chr} eq 'mod' ? 'Visual Novels awaiting moderation' : $p{vnbrowse}{chr} eq 'all' ? 'Browse all visual novels' : $p{vnbrowse}{chr} eq '0' ? 'Browse by char: Other' : sprintf 'Browse by char: %s', uc $p{vnbrowse}{chr}; }, rpage => sub { return $p{rpage}{rel}{romaji} || $p{rpage}{rel}{title} }, hist => sub { return !$p{hist}{id} || !$p{hist}{type} ? 'Recent changes' : $p{hist}{type} eq 'u' ? 'Recent changes by '.$p{hist}{title} : 'Edit history of '.$p{hist}{title}; }, docs => sub { return ( 'Categories', 'Adding/editing a visual novel', 'Adding/editing a release', 'Adding/editing a producer', 'General guidelines', 'Error parsing form', )[$p{docs}{p}-1]||'' } ); sub gettitle{$p{$_}&&($p{PageTitle}=ref($pagetitles{$_}) eq 'CODE' ? &{$pagetitles{$_}} : $pagetitles{$_}) for (keys%pagetitles);} # # F O R M E R R O R H A N D L I N G # my %formerr_names = ( mail => 'Email', username => 'Username', userpass => 'Password', pass1 => 'Password', pass2 => 'Password (second)', title => 'Title', desc => 'Description', rel => 'Relation', romaji => 'Romanized title', lang => 'Language', web => 'Website', released => 'Release date', platforms => 'Platforms', media => 'Media', name => 'Name', vn => 'Visual novel relations', ); my @formerr_msgs = ( sub { return sprintf 'Field "%s" is required.', @_ }, sub { return sprintf '%s should have at least %d characters.', @_ }, sub { return sprintf '%s is too large! Only %d characters allowed.', @_ }, sub { return $_[1] eq 'mail' ? 'Invalid email address' : $_[1] eq 'url' ? 'Invalid URL' : $_[1] eq 'pname' ? sprintf('%s can only contain alfanumeric characters!', $_[0]) : $_[1] eq 'asciiprint' ? sprintf('Only ASCII characters are allowed at %s', $_[0]) : $_[1] eq 'int' ? sprintf('%s should be a number!', $_[0]) : ''; }, sub { return sprintf '%s: invalid item selected', @_ }, sub { return 'Invalid unicode, are you sure your browser works fine?' }, ); my %formerr_exeptions = ( loginerr => 'Invalid username or password', badpass => 'Passwords do not match', usrexists => 'Username already exists, please choose an other one', mailexists => 'There already is a user with that email address, please request a new password if you forgot it', nomail => 'No user found with that email address', nojpeg => 'Image is not in JPEG or PNG format!', toolarge => 'Image is too large (in filesize), try to compress it a little', ); sub formerr { my @err = ref $_[0] eq 'ARRAY' ? @{$_[0]} : (); return '' if $#err < 0; my @msgs; my $ret = ' Error:
    '; $ret .= sprintf "
  • %s
  • \n", /^([a-z0-9]+)_([0-9]+)_?(.*)$/ ? &{$formerr_msgs[$2-1]}($formerr_names{$1}, $3?$3:'') : $formerr_exeptions{$_} foreach (@err); $ret .= "
\n
\n"; } # # F O R M C R E A T I N G # # args = [ # { # type => $type, # %options # }, ... # ], $formobj # # $type $formobj %options ( required, [ optional ] ) # error X ( ) # startform ( action, [ upload ] ) # endform ( ) # input X ( short, name, [ class, default ] ) # pass ( short, name ) # upload ( short, name, [ class ] ) # hidden X ( short, [ value ] ) # textarea X ( short, name, [ rows, cols, class ] ) # select X ( short, name, options, [ class ] ) # options = arrayref of hashes with keys: short, name # as X ( name ) # trans X ( ) # submit ( [ text, short ] ) # sub ( title ) # check X ( short, name, [ value ] ) # static ( text, raw [ name, class ] ) # date X ( short, name ) # sub cform { my $obj = shift; my $frm = shift; my $ret = ''; my $csub = ''; for (@$obj) { $_->{class} ||= ''; $_->{class} .= ' sf_'.$csub if $csub && $_->{class} !~ /nohid/; $_->{class} .= ' formhid' if $csub && $frm->{_hid} && !$frm->{_hid}{$csub} && $_->{class} !~ /nohid/; $_->{name} = '* '.$_->{name} if $_->{r}; # error if($_->{type} eq 'error') { $ret .= formerr($frm->{_err}); # startform } elsif($_->{type} eq 'startform') { $ret .= sprintf qq|
\n|, $_->{action}, $_->{upload} ? ' enctype="multipart/form-data"' : ''; $ret .= sprintf qq| \n|, $frm->{_hid} ? _hchar(join(',', keys %{$frm->{_hid}})) : '' if $_->{fh}; $ret .= qq|

Items denoted by a red asterisk (*) are required.

\n| if scalar grep { $_->{r} } @$obj; $ret .= "
    \n"; # endform } elsif($_->{type} eq 'endform') { $ret .= qq|
\n|; # input } elsif($_->{type} eq 'input') { $ret .= sprintf qq|\n \n %s\n\n|, $_->{class} ? ' class="'.$_->{class}.'"' : '', $_->{short}, $_->{name}, $_->{pre} ? ''.$_->{pre}.'' : '', _hchar($frm->{$_->{short}}?$frm->{$_->{short}}:$_->{default}); # pass } elsif($_->{type} eq 'pass') { $ret .= sprintf qq|\n \n \n\n|, $_->{class} ? ' class="'.$_->{class}.'"' : '', $_->{short}, $_->{name}; # upload } elsif($_->{type} eq 'upload') { $ret .= sprintf qq|\n \n \n\n|, $_->{class} ? ' class="'.$_->{class}.'"' : '', $_->{short}, $_->{name}; # hidden } elsif($_->{type} eq 'hidden') { $ret .= sprintf qq| \n|, $_->{short}, _hchar($_->{value} || $frm->{$_->{short}}); # textarea } elsif($_->{type} eq 'textarea') { $ret .= sprintf qq|\n \n \n\n|, $_->{class} ? ' class="'.$_->{class}.'"' : '', $_->{short}, $_->{name}, $_->{rows}||15, $_->{cols}||70, txt($frm->{$_->{short}}); # select } elsif($_->{type} eq 'select') { $ret .= sprintf qq|\n \n \n\n|, $_->{class} ? ' class="'.$_->{class}.'"' : '', $_->{short}, $_->{name}, eval { my $r=''; for my $s (@{$_->{options}}) { $r .= sprintf qq| \n|, $s->{short}, defined $frm->{$_->{short}} && $frm->{$_->{short}} eq $s->{short} ? ' selected="selected"' : '', $s->{name}; } return $r; }; # jssel } elsif($_->{type} eq 'jssel') { (my $oname = $_->{name}) =~ s/^\*<\/i>//; $ret .= sprintf qq|\n| .qq| \n| .qq| \n| .qq|
\n| .qq| Loading...\n| .qq|
\n| .qq| \n| .qq|\n|, $_->{class} ? ' class="'.$_->{class}.'"' : '', $_->{sh}, $_->{name}, $_->{sh}, $_->{sh}, $oname, $_->{sh}, $_->{short}, $_->{short}, _hchar($frm->{$_->{short}}); # submit } elsif($_->{type} eq 'submit') { $ret .= sprintf qq|
  • \n
    \n
  • \n|, $_->{text} || 'Verstuur', $_->{short} ? sprintf(' name="%s" id="%1$s"', $_->{short}) : ''; # sub } elsif($_->{type} eq 'sub') { $ret .= sprintf qq|
  • \n %s %s\n
  • \n|, $_->{short}, $frm->{_hid} && !$frm->{_hid}{$_->{short}} ? '▸' : '▾', $_->{title}; $csub = $_->{short}; # check } elsif($_->{type} eq 'check') { $ret .= sprintf qq|
  • \n \n \n
  • \n|, $_->{class} ? ' '.$_->{class} : '', $_->{short}, $_->{value} || 'true', $frm->{$_->{short}} ? ' checked="checked"' : '', $_->{name}; # static } elsif($_->{type} eq 'static') { $ret .= $_->{name} ? sprintf qq|\n \n

    %s

    \n|, $_->{class} ? ' class="'.$_->{class}.'"' : '', $_->{name}, $_->{text} : $_->{raw} ? sprintf qq|\n %s\n|, $_->{class} ? ' class="'.$_->{class}.'"' : '', $_->{text} : sprintf qq|
  • \n %s\n
  • |, $_->{class} ? ' '.$_->{class} : '', $_->{text}; # date } elsif($_->{type} eq 'date') { $ret .= sprintf qq|
  • \n \n|, $_->{class} ? ' '.$_->{class} : '', $_->{short}, $_->{name}; $ret .= sprintf qq| \n|, $_->{short}, $_->{short}, eval { my $r=''; for my $s (0, 1990..((localtime())[5]+1905), 9999) { $r .= sprintf qq| \n|, $s, $frm->{$_->{short}} && ($frm->{$_->{short}}[0]||0) == $s ? ' selected="selected"' : '', !$s ? '-year-' : $s < 9999 ? $s : 'TBA'; } return $r; }; $ret .= sprintf qq| \n|, $_->{short}, $_->{short}, eval { my $r=''; for my $s (0..12) { $r .= sprintf qq| \n|, $s, $frm->{$_->{short}} && ($frm->{$_->{short}}[1]||0) == $s ? ' selected="selected"' : '', $s ? $Time::CTime::MonthOfYear[$s-1] : '-month-'; } return $r; }; $ret .= sprintf qq| \n
  • \n|, $_->{short}, $_->{short}, eval { my $r=''; for my $s (0..31) { $r .= sprintf qq| \n|, $s, $frm->{$_->{short}} && ($frm->{$_->{short}}[2]||0) == $s ? ' selected="selected"' : '', $s ? $s : '-day-'; } return $r; }; } } return $ret; } ]]