kareha/wakautils.pl

   1 # wakautils.pl v8.12
   2
   3 use strict;
   4
   5 use Time::Local;
   6 use Socket;
   7
   8 my $has_md5=0;
   9 eval 'use Digest::MD5 qw(md5)';
  10 $has_md5=1 unless $@;
  11
  12 my $has_encode=0;
  13 eval 'use Encode qw(decode)';
  14 $has_encode=1 unless $@;
  15
  16
  17 use constant MAX_UNICODE => 1114111;
  18
  19 #
  20 # HTML utilities
  21 #
  22
  23 my $protocol_re=qr{(?:http://|https://|ftp://|mailto:|news:|irc:)};
  24 my $url_re=qr{(${protocol_re}[^\s<>()"]*?(?:\([^\s<>()"]*?\)[^\s<>()"]*?)*)((?:\s|<|>|"|\.||\]|!|\?|,|&#44;|&quot;)*(?:[\s<>()"]|$))};
  25
  26 sub protocol_regexp() { return $protocol_re }
  27
  28 sub url_regexp() { return $url_re }
  29
  30 sub abbreviate_html($$$)
  31 {
  32         my ($html,$max_lines,$approx_len)=@_;
  33         my ($lines,$chars,@stack);
  34
  35         return undef unless($max_lines);
  36
  37         while($html=~m!(?:([^<]+)|<(/?)(\w+).*?(/?)>)!g)
  38         {
  39                 my ($text,$closing,$tag,$implicit)=($1,$2,lc($3),$4);
  40
  41                 if($text) { $chars+=length $text; }
  42                 else
  43                 {
  44                         push @stack,$tag if(!$closing and !$implicit);
  45                         pop @stack if($closing);
  46
  47                         if(($closing or $implicit) and ($tag eq "p" or $tag eq "blockquote" or $tag eq "pre"
  48                         or $tag eq "li" or $tag eq "ol" or $tag eq "ul" or $tag eq "br"))
  49                         {
  50                                 $lines+=int($chars/$approx_len)+1;
  51                                 $lines++ if($tag eq "p" or $tag eq "blockquote");
  52                                 $chars=0;
  53                         }
  54
  55                         if($lines>=$max_lines)
  56                         {
  57                                 # check if there's anything left other than end-tags
  58                                 return undef if (substr $html,pos $html)=~m!^(?:\s*</\w+>)*\s*$!s;
  59
  60                                 my $abbrev=substr $html,0,pos $html;
  61                                 while(my $tag=pop @stack) { $abbrev.="</$tag>" }
  62
  63                                 return $abbrev;
  64                         }
  65                 }
  66         }
  67
  68         return undef;
  69 }
  70
  71 sub sanitize_html($%)
  72 {
  73         my ($html,%tags)=@_;
  74         my (@stack,$clean);
  75         my $entity_re=qr/&(?!\#[0-9]+;|\#x[0-9a-fA-F]+;|amp;|lt;|gt;)/;
  76
  77         while($html=~/(?:([^<]+)|<([^<>]*)>|(<))/sg)
  78         {
  79                 my ($text,$tag,$lt)=($1,$2,$3);
  80
  81                 if($lt)
  82                 {
  83                         $clean.="&lt;";
  84                 }
  85                 elsif($text)
  86                 {
  87                         $text=~s/$entity_re/&amp;/g;
  88                         $text=~s/>/&gt;/g;
  89                         $clean.=$text;
  90                 }
  91                 else
  92                 {
  93                         if($tag=~m!^\s*(/?)\s*([a-z0-9_:\-\.]+)(?:\s+(.*?)|)\s*(/?)\s*$!si)
  94                         {
  95                                 my ($closing,$name,$args,$implicit)=($1,lc($2),$3,$4);
  96
  97                                 if($tags{$name})
  98                                 {
  99                                         if($closing)
 100                                         {
 101                                                 if(grep { $_ eq $name } @stack)
 102                                                 {
 103                                                         my $entry;
 104
 105                                                         do {
 106                                                                 $entry=pop @stack;
 107                                                                 $clean.="</$entry>";
 108                                                         } until $entry eq $name;
 109                                                 }
 110                                         }
 111                                         else
 112                                         {
 113                                                 my %args;
 114
 115                                                 $args=~s/\s/ /sg;
 116
 117                                                 while($args=~/([a-z0-9_:\-\.]+)(?:\s*=\s*(?:'([^']*?)'|"([^"]*?)"|['"]?([^'" ]*))|)/gi)
 118                                                 {
 119                                                         my ($arg,$value)=(lc($1),defined($2)?$2:defined($3)?$3:$4);
 120                                                         $value=$arg unless defined($value);
 121
 122                                                         my $type=$tags{$name}{args}{$arg};
 123
 124                                                         if($type)
 125                                                         {
 126                                                                 my $passes=1;
 127
 128                                                                 if($type=~/url/i) { $passes=0 unless $value=~/(?:^${protocol_re}|^[^:]+$)/ }
 129                                                                 if($type=~/number/i) { $passes=0 unless $value=~/^[0-9]+$/  }
 130
 131                                                                 if($passes)
 132                                                                 {
 133                                                                         $value=~s/$entity_re/&amp;/g;
 134                                                                         $args{$arg}=$value;
 135                                                                 }
 136                                                         }
 137                                                 }
 138
 139                                                 $args{$_}=$tags{$name}{forced}{$_} for (keys %{$tags{$name}{forced}}); # override forced arguments
 140
 141                                                 my $cleanargs=join " ",map {
 142                                                         my $value=$args{$_};
 143                                                         $value=~s/'/%27/g;
 144                                                         "$_='$value'";
 145                                                 } keys %args;
 146
 147                                                 $implicit="/" if($tags{$name}{empty});
 148
 149                                                 push @stack,$name unless $implicit;
 150
 151                                                 $clean.="<$name";
 152                                                 $clean.=" $cleanargs" if $cleanargs;
 153                                                 #$clean.=" $implicit" if $implicit;
 154                                                 $clean.=">";
 155                                                 $clean.="</$name>" if $implicit;
 156                                         }
 157                                 }
 158                         }
 159                 }
 160         }
 161
 162         my $entry;
 163         while($entry=pop @stack) { $clean.="</$entry>" }
 164
 165         return $clean;
 166 }
 167
 168 sub describe_allowed(%)
 169 {
 170         my (%tags)=@_;
 171
 172         return join ", ",map { $_.($tags{$_}{args}?" (".(join ", ",sort keys %{$tags{$_}{args}}).")":"") } sort keys %tags;
 173 }
 174
 175 sub do_wakabamark($;$$)
 176 {
 177         my ($text,$handler,$simplify)=@_;
 178         my $res;
 179
 180         my @lines=split /(?:\r\n|\n|\r)/,$text;
 181
 182         while(defined($_=$lines[0]))
 183         {
 184                 if(/^\s*$/) { shift @lines; } # skip empty lines
 185                 elsif(/^(1\.|[\*\+\-]) /) # lists
 186                 {
 187                         my ($tag,$re,$skip,$html);
 188
 189                         if($1 eq "1.") { $tag="ol"; $re=qr/[0-9]+\./; $skip=1; }
 190                         else { $tag="ul"; $re=qr/\Q$1\E/; $skip=0; }
 191
 192                         while($lines[0]=~/^($re)(?: |\t)(.*)/)
 193                         {
 194                                 my $spaces=(length $1)+1;
 195                                 my $item="$2\n";
 196                                 shift @lines;
 197
 198                                 while($lines[0]=~/^(?: {1,$spaces}|\t)(.*)/) { $item.="$1\n"; shift @lines }
 199                                 $html.="<li>".do_wakabamark($item,$handler,1)."</li>";
 200
 201                                 if($skip) { while(@lines and $lines[0]=~/^\s*$/) { shift @lines; } } # skip empty lines
 202                         }
 203                         $res.="<$tag>$html</$tag>";
 204                 }
 205                 elsif(/^(?:    |\t)/) # code sections
 206                 {
 207                         my @code;
 208                         while($lines[0]=~/^(?:    |\t)(.*)/) { push @code,$1; shift @lines; }
 209                         $res.="<pre><code>".(join "<br />",@code)."</code></pre>";
 210                 }
 211                 elsif(/^&gt;/) # quoted sections
 212                 {
 213                         my @quote;
 214                         while($lines[0]=~/^(&gt;.*)/) { push @quote,$1; shift @lines; }
 215                         $res.="<blockquote>".do_spans($handler,@quote)."</blockquote>";
 216
 217                         #while($lines[0]=~/^&gt;(.*)/) { push @quote,$1; shift @lines; }
 218                         #$res.="<blockquote>".do_blocks($handler,@quote)."</blockquote>";
 219                 }
 220                 else # normal paragraph
 221                 {
 222                         my @text;
 223                         while($lines[0]!~/^(?:\s*$|1\. |[\*\+\-] |&gt;|    |\t)/) { push @text,shift @lines; }
 224                         if(!defined($lines[0]) and $simplify) { $res.=do_spans($handler,@text) }
 225                         else { $res.="<p>".do_spans($handler,@text)."</p>" }
 226                 }
 227                 $simplify=0;
 228         }
 229
 230         return $res;
 231 }
 232
 233 sub do_spans($@)
 234 {
 235         my $handler=shift;
 236         return join "<br />",map
 237         {
 238                 my $line=$_;
 239                 my @hidden;
 240
 241                 # hide <code> sections
 242                 $line=~s{ (?<![\x80-\x9f\xe0-\xfc]) (`+) ([^<>]+?) (?<![\x80-\x9f\xe0-\xfc]) \1}{push @hidden,"<code>$2</code>"; "<!--$#hidden-->"}sgex;
 243
 244                 # make URLs into links and hide them
 245                 $line=~s{$url_re}{push @hidden,"<a href=\"$1\" rel=\"nofollow\">$1\</a>"; "<!--$#hidden-->$2"}sge;
 246
 247                 # do <strong>
 248                 $line=~s{ (?<![0-9a-zA-Z\*_\x80-\x9f\xe0-\xfc]) (\*\*|__) (?![<>\s\*_]) ([^<>]+?) (?<![<>\s\*_\x80-\x9f\xe0-\xfc]) \1 (?![0-9a-zA-Z\*_]) }{<strong>$2</strong>}gx;
 249
 250                 # do <em>
 251                 $line=~s{ (?<![0-9a-zA-Z\*_\x80-\x9f\xe0-\xfc]) (\*|_) (?![<>\s\*_]) ([^<>]+?) (?<![<>\s\*_\x80-\x9f\xe0-\xfc]) \1 (?![0-9a-zA-Z\*_]) }{<em>$2</em>}gx;
 252
 253                 # do ^H
 254                 if($]>5.007)
 255                 {
 256                         my $regexp;
 257                         $regexp=qr/(?:&#?[0-9a-zA-Z]+;|[^&<>])(?<!\^H)(??{$regexp})?\^H/;
 258                         $line=~s{($regexp)}{"<del>".(substr $1,0,(length $1)/3)."</del>"}gex;
 259                 }
 260
 261                 $line=$handler->($line) if($handler);
 262
 263                 # fix up hidden sections
 264                 $line=~s{<!--([0-9]+)-->}{$hidden[$1]}ge;
 265
 266                 $line;
 267         } @_;
 268 }
 269
 270 sub compile_template($;$)
 271 {
 272         my ($str,$nostrip)=@_;
 273         my $code;
 274
 275         unless($nostrip)
 276         {
 277                 $str=~s/^\s+//;
 278                 $str=~s/\s+$//;
 279                 $str=~s/\n\s*/ /sg;
 280         }
 281
 282         while($str=~m!(.*?)(<(/?)(var|const|if|loop)(?:|\s+(.*?[^\\]))>|$)!sg)
 283         {
 284                 my ($html,$tag,$closing,$name,$args)=($1,$2,$3,$4,$5);
 285
 286                 $html=~s/(['\\])/\\$1/g;
 287                 $code.="\$res.='$html';" if(length $html);
 288                 $args=~s/\\>/>/g;
 289
 290                 if($tag)
 291                 {
 292                         if($closing)
 293                         {
 294                                 if($name eq 'if') { $code.='}' }
 295                                 elsif($name eq 'loop') { $code.='$$_=$__ov{$_} for(keys %__ov);}}' }
 296                         }
 297                         else
 298                         {
 299                                 if($name eq 'var') { $code.='$res.=eval{'.$args.'};' }
 300                                 elsif($name eq 'const') { my $const=eval $args; $const=~s/(['\\])/\\$1/g; $code.='$res.=\''.$const.'\';' }
 301                                 elsif($name eq 'if') { $code.='if(eval{'.$args.'}){' }
 302                                 elsif($name eq 'loop')
 303                                 { $code.='my $__a=eval{'.$args.'};if($__a){for(@$__a){my %__v=%{$_};my %__ov;for(keys %__v){$__ov{$_}=$$_;$$_=$__v{$_};}' }
 304                         }
 305                 }
 306         }
 307
 308         my $sub=eval
 309                 'no strict; sub { '.
 310                 'my $port=$ENV{SERVER_PORT}==80?"":":$ENV{SERVER_PORT}";'.
 311                 'my $self=$ENV{SCRIPT_NAME};'.
 312                 'my $absolute_self="http://$ENV{SERVER_NAME}$port$ENV{SCRIPT_NAME}";'.
 313                 'my ($path)=$ENV{SCRIPT_NAME}=~m!^(.*/)[^/]+$!;'.
 314                 'my $absolute_path="http://$ENV{SERVER_NAME}$port$path";'.
 315                 'my %__v=@_;my %__ov;for(keys %__v){$__ov{$_}=$$_;$$_=$__v{$_};}'.
 316                 'my $res;'.
 317                 $code.
 318                 '$$_=$__ov{$_} for(keys %__ov);'.
 319                 'return $res; }';
 320
 321         die "Template format error" unless $sub;
 322
 323         return $sub;
 324 }
 325
 326 sub template_for($$$)
 327 {
 328         my ($var,$start,$end)=@_;
 329         return [map +{$var=>$_},($start..$end)];
 330 }
 331
 332 sub include($)
 333 {
 334         my ($filename)=@_;
 335
 336         open FILE,$filename or return '';
 337         my $file=do { local $/; <FILE> };
 338
 339         $file=~s/^\s+//;
 340         $file=~s/\s+$//;
 341         $file=~s/\n\s*/ /sg;
 342
 343         return $file;
 344 }
 345
 346
 347 sub forbidden_unicode($;$)
 348 {
 349         my ($dec,$hex)=@_;
 350         return 1 if length($dec)>7 or length($hex)>7; # too long numbers
 351         my $ord=($dec or hex $hex);
 352
 353         return 1 if $ord>MAX_UNICODE; # outside unicode range
 354         return 1 if $ord<32; # control chars
 355         return 1 if $ord>=0x7f and $ord<=0x84; # control chars
 356         return 1 if $ord>=0xd800 and $ord<=0xdfff; # surrogate code points
 357         return 1 if $ord>=0x202a and $ord<=0x202e; # text direction
 358         return 1 if $ord>=0xfdd0 and $ord<=0xfdef; # non-characters
 359         return 1 if $ord % 0x10000 >= 0xfffe; # non-characters
 360         return 0;
 361 }
 362
 363 sub clean_string($;$)
 364 {
 365         my ($str,$cleanentities)=@_;
 366
 367         if($cleanentities) { $str=~s/&/&amp;/g } # clean up &
 368         else
 369         {
 370                 $str=~s/&(#([0-9]+);|#x([0-9a-fA-F]+);|)/
 371                         if($1 eq "") { '&amp;' } # change simple ampersands
 372                         elsif(forbidden_unicode($2,$3))  { "" } # strip forbidden unicode chars
 373                         else { "&$1" } # and leave the rest as-is.
 374                 /ge  # clean up &, excluding numerical entities
 375         }
 376
 377         $str=~s/\</&lt;/g; # clean up brackets for HTML tags
 378         $str=~s/\>/&gt;/g;
 379         $str=~s/"/&quot;/g; # clean up quotes for HTML attributes
 380         $str=~s/'/&#39;/g;
 381         $str=~s/,/&#44;/g; # clean up commas for some reason I forgot
 382
 383         $str=~s/[\x00-\x08\x0b\x0c\x0e-\x1f]//g; # remove control chars
 384
 385         return $str;
 386 }
 387
 388 sub decode_string($;$$)
 389 {
 390         my ($str,$charset,$noentities)=@_;
 391         my $use_unicode=$has_encode && $charset;
 392
 393         $str=decode($charset,$str) if $use_unicode;
 394
 395         $str=~s{(&#([0-9]*)([;&])|&#([x&])([0-9a-f]*)([;&]))}{
 396                 my $ord=($2 or hex $5);
 397                 if($3 eq '&' or $4 eq '&' or $5 eq '&') { $1 } # nested entities, leave as-is.
 398                 elsif(forbidden_unicode($2,$5))  { "" } # strip forbidden unicode chars
 399                 elsif($ord==35 or $ord==38) { $1 } # don't convert & or #
 400                 elsif($use_unicode) { chr $ord } # if we have unicode support, convert all entities
 401                 elsif($ord<128) { chr $ord } # otherwise just convert ASCII-range entities
 402                 else { $1 } # and leave the rest as-is.
 403         }gei unless $noentities;
 404
 405         $str=~s/[\x00-\x08\x0b\x0c\x0e-\x1f]//g; # remove control chars
 406
 407         return $str;
 408 }
 409
 410 sub escamp($)
 411 {
 412         my ($str)=@_;
 413         $str=~s/&/&amp;/g;
 414         return $str;
 415 }
 416
 417 sub urlenc($)
 418 {
 419         my ($str)=@_;
 420         $str=~s/([^\w ])/"%".sprintf("%02x",ord $1)/sge;
 421         $str=~s/ /+/sg;
 422         return $str;
 423 }
 424
 425 sub clean_path($)
 426 {
 427         my ($str)=@_;
 428         $str=~s!([^\w/._\-])!"%".sprintf("%02x",ord $1)!sge;
 429         return $str;
 430 }
 431
 432
 433
 434 #
 435 # Javascript utilities
 436 #
 437
 438 sub clean_to_js($)
 439 {
 440         my $str=shift;
 441
 442         $str=~s/&amp;/\\x26/g;
 443         $str=~s/&lt;/\\x3c/g;
 444         $str=~s/&gt;/\\x3e/g;
 445         $str=~s/&quot;/\\x22/g; #"
 446         $str=~s/(&#39;|')/\\x27/g;
 447         $str=~s/&#44;/,/g;
 448         $str=~s/&#[0-9]+;/sprintf "\\u%04x",$1/ge;
 449         $str=~s/&#x[0-9a-f]+;/sprintf "\\u%04x",hex($1)/gie;
 450         $str=~s/(\r\n|\r|\n)/\\n/g;
 451
 452         return "'$str'";
 453 }
 454
 455 sub js_string($)
 456 {
 457         my $str=shift;
 458
 459         $str=~s/\\/\\\\/g;
 460         $str=~s/'/\\'/g;
 461         $str=~s/([\x00-\x1f\x80-\xff<>&])/sprintf "\\x%02x",ord($1)/ge;
 462         eval '$str=~s/([\x{100}-\x{ffff}])/sprintf "\\u%04x",ord($1)/ge';
 463         $str=~s/(\r\n|\r|\n)/\\n/g;
 464
 465         return "'$str'";
 466 }
 467
 468 sub js_array(@)
 469 {
 470         return "[".(join ",",@_)."]";
 471 }
 472
 473 sub js_hash(%)
 474 {
 475         my %hash=@_;
 476         return "{".(join ",",map "'$_':$hash{$_}",keys %hash)."}";
 477 }
 478
 479
 480 #
 481 # HTTP utilities
 482 #
 483
 484 # LIGHTWEIGHT HTTP/1.1 CLIENT
 485 # by fatalM4/coda, modified by WAHa.06x36
 486
 487 use constant CACHEFILE_PREFIX => 'cache-'; # you can make this a directory (e.g. 'cachedir/cache-' ) if you'd like
 488 use constant FORCETIME => '0.04';       # If the cache is less than (FORCETIME) days old, don't even attempt to refresh.
 489                                     # Saves everyone some bandwidth. 0.04 days is ~ 1 hour. 0.0007 days is ~ 1 min.
 490 eval 'use IO::Socket::INET'; # Will fail on old Perl versions!
 491
 492 sub get_http($;$$$)
 493 {
 494         my ($url,$maxsize,$referer,$cacheprefix)=@_;
 495         my ($host,$port,$doc)=$url=~m!^(?:http://|)([^/]+)(:[0-9]+|)(.*)$!;
 496         $port=80 unless($port);
 497
 498         my $hash=encode_base64(rc4(null_string(6),"$host:$port$doc",0),"");
 499         $hash=~tr!/+!_-!; # remove / and +
 500         my $cachefile=($cacheprefix or CACHEFILE_PREFIX).($doc=~m!([^/]{0,15})$!)[0]."-$hash"; # up to 15 chars of filename
 501         my ($modified,$cache);
 502
 503         if(open CACHE,"<",$cachefile)  # get modified date and cache contents
 504         {
 505                 $modified=<CACHE>;
 506                 $cache=join "",<CACHE>;
 507                 chomp $modified;
 508                 close CACHE;
 509
 510                 return $cache if((-M $cachefile)<FORCETIME);
 511         }
 512
 513         my $sock=IO::Socket::INET->new("$host:$port") or return $cache;
 514         print $sock "GET $doc HTTP/1.1\r\nHost: $host\r\nConnection: close\r\n";
 515         print $sock "If-Modified-Since: $modified\r\n" if $modified;
 516         print $sock "Referer: $referer\r\n" if $referer;
 517         print $sock "\r\n"; #finished!
 518
 519         # header
 520         my ($line,$statuscode,$lastmod);
 521         do {
 522                 $line=<$sock>;
 523                 $statuscode=$1 if($line=~/^HTTP\/1\.1 (\d+)/);
 524                 $lastmod=$1 if($line=~/^Last-Modified: (.*)/);
 525         } until ($line=~/^\r?\n/);
 526
 527         # body
 528         my ($line,$output);
 529         while($line=<$sock>)
 530         {
 531                 $output.=$line;
 532                 last if $maxsize and $output>=$maxsize;
 533         }
 534         undef $sock;
 535
 536         if($statuscode=="200")
 537         {
 538                 #navbar changed, update cache
 539                 if(open CACHE,">$cachefile")
 540                 {
 541                         print CACHE "$lastmod\n";
 542                         print CACHE $output;
 543                         close CACHE or die "close cache: $!";
 544                 }
 545                 return $output;
 546         }
 547         else # touch and return cache, or nothing if no cache
 548         {
 549                 utime(time,time,$cachefile);
 550                 return $cache;
 551         }
 552 }
 553
 554 sub make_http_forward($;$)
 555 {
 556         my ($location,$alternate_method)=@_;
 557
 558         if($alternate_method)
 559         {
 560                 print "Content-Type: text/html\n";
 561                 print "\n";
 562                 print "<html><head>";
 563                 print '<meta http-equiv="refresh" content="0; url='.$location.'" />';
 564                 print '<script type="text/javascript">document.location="'.$location.'";</script>';
 565                 print '</head><body><a href="'.$location.'">'.$location.'</a></body></html>';
 566         }
 567         else
 568         {
 569                 print "Status: 303 Go West\n";
 570                 print "Location: $location\n";
 571                 print "Content-Type: text/html\n";
 572                 print "\n";
 573                 print '<html><body><a href="'.$location.'">'.$location.'</a></body></html>';
 574         }
 575 }
 576
 577 sub make_cookies(%)
 578 {
 579         my (%cookies)=@_;
 580
 581         my $charset=$cookies{'-charset'};
 582         my $expires=($cookies{'-expires'} or time+14*24*3600);
 583         my $autopath=$cookies{'-autopath'};
 584         my $path=$cookies{'-path'};
 585
 586         my $date=make_date($expires,"cookie");
 587
 588         unless($path)
 589         {
 590                 if($autopath eq 'current') { ($path)=$ENV{SCRIPT_NAME}=~m!^(.*/)[^/]+$! }
 591                 elsif($autopath eq 'parent') { ($path)=$ENV{SCRIPT_NAME}=~m!^(.*?/)(?:[^/]+/)?[^/]+$! }
 592                 else { $path='/'; }
 593         }
 594
 595         foreach my $name (keys %cookies)
 596         {
 597                 next if($name=~/^-/); # skip entries that start with a dash
 598
 599                 my $value=$cookies{$name};
 600                 $value="" unless(defined $value);
 601
 602                 $value=cookie_encode($value,$charset);
 603
 604                 print "Set-Cookie: $name=$value; path=$path; expires=$date;\n";
 605         }
 606 }
 607
 608 sub cookie_encode($;$)
 609 {
 610         my ($str,$charset)=@_;
 611
 612         if($]>5.007) # new perl, use Encode.pm
 613         {
 614                 if($charset)
 615                 {
 616                         require Encode;
 617                         $str=Encode::decode($charset,$str);
 618                         $str=~s/&\#([0-9]+);/chr $1/ge;
 619                         $str=~s/&\#x([0-9a-f]+);/chr hex $1/gei;
 620                 }
 621
 622                 $str=~s/([^0-9a-zA-Z])/
 623                         my $c=ord $1;
 624                         sprintf($c>255?'%%u%04x':'%%%02x',$c);
 625                 /sge;
 626         }
 627         else # do the hard work ourselves
 628         {
 629                 if($charset=~/\butf-?8$/i)
 630                 {
 631                         $str=~s{([\xe0-\xef][\x80-\xBF][\x80-\xBF]|[\xc0-\xdf][\x80-\xBF]|&#([0-9]+);|&#[xX]([0-9a-fA-F]+);|[^0-9a-zA-Z])}{ # convert UTF-8 to URL encoding - only handles up to U-FFFF
 632                                 my $c;
 633                                 if($2) { $c=$2 }
 634                                 elsif($3) { $c=hex $3 }
 635                                 elsif(length $1==1) { $c=ord $1 }
 636                                 elsif(length $1==2)
 637                                 {
 638                                         my @b=map { ord $_ } split //,$1;
 639                                         $c=(($b[0]-0xc0)<<6)+($b[1]-0x80);
 640                                 }
 641                                 elsif(length $1==3)
 642                                 {
 643                                         my @b=map { ord $_ } split //,$1;
 644                                         $c=(($b[0]-0xe0)<<12)+(($b[1]-0x80)<<6)+($b[2]-0x80);
 645                                 }
 646                                 sprintf($c>255?'%%u%04x':'%%%02x',$c);
 647                         }sge;
 648                 }
 649                 elsif($charset=~/\b(?:shift.*jis|sjis)$/i) # old perl, using shift_jis
 650                 {
 651                         require 'sjis.pl';
 652                         my $sjis_table=get_sjis_table();
 653
 654                         $str=~s{([\x80-\x9f\xe0-\xfc].|&#([0-9]+);|&#[xX]([0-9a-fA-F]+);|[^0-9a-zA-Z])}{ # convert Shift_JIS to URL encoding
 655                                 my $c=($2 or ($3 and hex $3) or $$sjis_table{$1});
 656                                 sprintf($c>255?'%%u%04x':'%%%02x',$c);
 657                         }sge;
 658                 }
 659                 else
 660                 {
 661                         $str=~s/([^0-9a-zA-Z])/sprintf('%%%02x',ord $1)/sge;
 662                 }
 663         }
 664
 665         return $str;
 666 }
 667
 668 sub get_xhtml_content_type(;$$)
 669 {
 670         my ($charset,$usexhtml)=@_;
 671         my $type;
 672
 673         if($usexhtml and $ENV{HTTP_ACCEPT}=~/application\/xhtml\+xml/) { $type="application/xhtml+xml"; }
 674         else { $type="text/html"; }
 675
 676         $type.="; charset=$charset" if($charset);
 677
 678         return $type;
 679 }
 680
 681 sub expand_filename($)
 682 {
 683         my ($filename)=@_;
 684         return $filename if($filename=~m!^/!);
 685         return $filename if($filename=~m!^\w+:!);
 686
 687         my ($self_path)=$ENV{SCRIPT_NAME}=~m!^(.*/)[^/]+$!;
 688         return $self_path.$filename;
 689 }
 690
 691 #
 692 # Network utilities
 693 #
 694
 695 sub resolve_host($)
 696 {
 697         my $ip=shift;
 698         return (gethostbyaddr inet_aton($ip),AF_INET or $ip);
 699 }
 700
 701
 702 #
 703 # Data utilities
 704 #
 705
 706 sub process_tripcode($;$$$$)
 707 {
 708         my ($name,$tripkey,$secret,$charset,$nonamedecoding)=@_;
 709         $tripkey="!" unless($tripkey);
 710
 711         if($name=~/^(.*?)((?<!&)#|\Q$tripkey\E)(.*)$/)
 712         {
 713                 my ($namepart,$marker,$trippart)=($1,$2,$3);
 714                 my $trip;
 715
 716                 $namepart=decode_string($namepart,$charset) unless $nonamedecoding;
 717                 $namepart=clean_string($namepart);
 718
 719                 if($secret and $trippart=~s/(?:\Q$marker\E)(?<!&#)(?:\Q$marker\E)*(.*)$//) # do we want secure trips, and is there one?
 720                 {
 721                         my $str=$1;
 722                         my $maxlen=255-length($secret);
 723                         $str=substr $str,0,$maxlen if(length($str)>$maxlen);
 724 #                       $trip=$tripkey.$tripkey.encode_base64(rc4(null_string(6),"t".$str.$secret),"");
 725                         $trip=$tripkey.$tripkey.hide_data($1,6,"trip",$secret,1);
 726                         return ($namepart,$trip) unless($trippart); # return directly if there's no normal tripcode
 727                 }
 728
 729                 # 2ch trips are processed as Shift_JIS whenever possible
 730                 eval 'use Encode qw(decode encode)';
 731                 unless($@)
 732                 {
 733                         $trippart=decode_string($trippart,$charset);
 734                         $trippart=encode("Shift_JIS",$trippart,0x0200);
 735                 }
 736
 737                 $trippart=clean_string($trippart);
 738                 my $salt=substr $trippart."H..",1,2;
 739                 $salt=~s/[^\.-z]/./g;
 740                 $salt=~tr/:;<=>?@[\\]^_`/ABCDEFGabcdef/;
 741                 $trip=$tripkey.(substr crypt($trippart,$salt),-10).$trip;
 742
 743                 return ($namepart,$trip);
 744         }
 745
 746         return clean_string($name) if $nonamedecoding;
 747         return (clean_string(decode_string($name,$charset)),"");
 748 }
 749
 750 sub make_date($$;@)
 751 {
 752         my ($time,$style,@locdays)=@_;
 753         my @days=qw(Sun Mon Tue Wed Thu Fri Sat);
 754         my @months=qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 755         @locdays=@days unless(@locdays);
 756
 757         if($style eq "2ch")
 758         {
 759                 my @ltime=localtime($time);
 760
 761                 return sprintf("%04d-%02d-%02d %02d:%02d",
 762                 $ltime[5]+1900,$ltime[4]+1,$ltime[3],$ltime[2],$ltime[1]);
 763         }
 764         elsif($style eq "futaba" or $style eq "0")
 765         {
 766                 my @ltime=localtime($time);
 767
 768                 return sprintf("%02d/%02d/%02d(%s)%02d:%02d",
 769                 $ltime[5]-100,$ltime[4]+1,$ltime[3],$locdays[$ltime[6]],$ltime[2],$ltime[1]);
 770         }
 771         elsif($style eq "localtime")
 772         {
 773                 return scalar(localtime($time));
 774         }
 775         elsif($style eq "tiny")
 776         {
 777                 my @ltime=localtime($time);
 778
 779                 return sprintf("%02d/%02d %02d:%02d",
 780                 $ltime[4]+1,$ltime[3],$ltime[2],$ltime[1]);
 781         }
 782         elsif($style eq "http")
 783         {
 784                 my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($time);
 785                 return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
 786                 $days[$wday],$mday,$months[$mon],$year+1900,$hour,$min,$sec);
 787         }
 788         elsif($style eq "cookie")
 789         {
 790                 my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($time);
 791                 return sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
 792                 $days[$wday],$mday,$months[$mon],$year+1900,$hour,$min,$sec);
 793         }
 794         elsif($style eq "month")
 795         {
 796                 my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($time);
 797                 return sprintf("%s %d",
 798                 $months[$mon],$year+1900);
 799         }
 800         elsif($style eq "2ch-sep93")
 801         {
 802                 my $sep93=timelocal(0,0,0,1,8,93);
 803                 return make_date($time,"2ch") if($time<$sep93);
 804
 805                 my @ltime=localtime($time);
 806
 807                 return sprintf("%04d-%02d-%02d %02d:%02d",
 808                 1993,9,int ($time-$sep93)/86400+1,$ltime[2],$ltime[1]);
 809         }
 810 }
 811
 812 sub parse_http_date($)
 813 {
 814         my ($date)=@_;
 815         my %months=(Jan=>0,Feb=>1,Mar=>2,Apr=>3,May=>4,Jun=>5,Jul=>6,Aug=>7,Sep=>8,Oct=>9,Nov=>10,Dec=>11);
 816
 817         if($date=~/^[SMTWF][a-z][a-z], (\d\d) ([JFMASOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/)
 818         { return eval { timegm($6,$5,$4,$1,$months{$2},$3-1900) } }
 819
 820         return undef;
 821 }
 822
 823 sub cfg_expand($%)
 824 {
 825         my ($str,%grammar)=@_;
 826         $str=~s/%(\w+)%/
 827                 my @expansions=@{$grammar{$1}};
 828                 cfg_expand($expansions[rand @expansions],%grammar);
 829         /ge;
 830         return $str;
 831 }
 832
 833 sub encode_base64($;$) # stolen from MIME::Base64::Perl
 834 {
 835         my ($data,$eol)=@_;
 836         $eol="\n" unless(defined $eol);
 837
 838         my $res=pack "u",$data;
 839         $res=~s/^.//mg; # remove length counts
 840         $res=~s/\n//g; # remove newlines
 841         $res=~tr|` -_|AA-Za-z0-9+/|; # translate to base64
 842
 843         my $padding=(3-length($data)%3)%3;      # fix padding at the end
 844         $res=~s/.{$padding}$/'='x$padding/e if($padding);
 845
 846         $res=~s/(.{1,76})/$1$eol/g if(length $eol); # break encoded string into lines of no more than 76 characters each
 847
 848         return $res;
 849 }
 850
 851 sub decode_base64($) # stolen from MIME::Base64::Perl
 852 {
 853         my ($str)=@_;
 854
 855         $str=~tr|A-Za-z0-9+=/||cd;      # remove non-base64 characters
 856         $str=~s/=+$//; # remove padding
 857         $str=~tr|A-Za-z0-9+/| -_|; # translate to uuencode
 858         return "" unless(length $str);
 859         return unpack "u",join '',map { chr(32+length($_)*3/4).$_ } $str=~/(.{1,60})/gs;
 860 }
 861
 862 sub dot_to_dec($)
 863 {
 864         return unpack('N',pack('C4',split(/\./, $_[0]))); # wow, magic.
 865 }
 866
 867 sub dec_to_dot($)
 868 {
 869         return join('.',unpack('C4',pack('N',$_[0])));
 870 }
 871
 872 sub mask_ip($$;$)
 873 {
 874         my ($ip,$key,$algorithm)=@_;
 875
 876         $ip=dot_to_dec($ip) if $ip=~/\./;
 877
 878         my ($block,$stir)=setup_masking($key,$algorithm);
 879         my $mask=0x80000000;
 880
 881         for(1..32)
 882         {
 883                 my $bit=$ip&$mask?"1":"0";
 884                 $block=$stir->($block);
 885                 $ip^=$mask if(ord($block)&0x80);
 886                 $block=$bit.$block;
 887                 $mask>>=1;
 888         }
 889
 890         return sprintf "%08x",$ip;
 891 }
 892
 893 sub unmask_ip($$;$)
 894 {
 895         my ($id,$key,$algorithm)=@_;
 896
 897         $id=hex($id);
 898
 899         my ($block,$stir)=setup_masking($key,$algorithm);
 900         my $mask=0x80000000;
 901
 902         for(1..32)
 903         {
 904                 $block=$stir->($block);
 905                 $id^=$mask if(ord($block)&0x80);
 906                 my $bit=$id&$mask?"1":"0";
 907                 $block=$bit.$block;
 908                 $mask>>=1;
 909         }
 910
 911         return dec_to_dot($id);
 912 }
 913
 914 sub setup_masking($$)
 915 {
 916         my ($key,$algorithm)=@_;
 917
 918         $algorithm=$has_md5?"md5":"rc6" unless $algorithm;
 919
 920         my ($block,$stir);
 921
 922         if($algorithm eq "md5")
 923         {
 924                 return (md5($key),sub { md5(shift) })
 925         }
 926         else
 927         {
 928                 setup_rc6($key);
 929                 return (null_string(16),sub { encrypt_rc6(shift) })
 930         }
 931 }
 932
 933 sub make_random_string($)
 934 {
 935         my ($num)=@_;
 936         my $chars="abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";
 937         my $str;
 938
 939         $str.=substr $chars,rand length $chars,1 for(1..$num);
 940
 941         return $str;
 942 }
 943
 944 sub null_string($) { "\0"x(shift) }
 945
 946 sub make_key($$$)
 947 {
 948         my ($key,$secret,$length)=@_;
 949         return rc4(null_string($length),$key.$secret);
 950 }
 951
 952 sub hide_data($$$$;$)
 953 {
 954         my ($data,$bytes,$key,$secret,$base64)=@_;
 955
 956         my $crypt=rc4(null_string($bytes),make_key($key,$secret,32).$data);
 957
 958         return encode_base64($crypt,"") if $base64;
 959         return $crypt;
 960 }
 961
 962
 963
 964 #
 965 # File utilities
 966 #
 967
 968 sub read_array($)
 969 {
 970         my ($file)=@_;
 971
 972         if(ref $file eq "GLOB")
 973         {
 974                 return map { s/\r?\n?$//; $_ } <$file>;
 975         }
 976         else
 977         {
 978                 open FILE,$file or return ();
 979                 binmode FILE;
 980                 my @array=map { s/\r?\n?$//; $_ } <FILE>;
 981                 close FILE;
 982                 return @array;
 983         }
 984 }
 985
 986 sub write_array($@)
 987 {
 988         my ($file,@array)=@_;
 989
 990         if(ref $file eq "GLOB")
 991         {
 992                 print $file join "\n",@array;
 993         }
 994         else # super-paranoid atomic write
 995         {
 996                 my $rndname1="__".make_random_string(12).".dat";
 997                 my $rndname2="__".make_random_string(12).".dat";
 998                 if(open FILE,">$rndname1")
 999                 {
1000                         binmode FILE;
1001                         if(print FILE join "\n",@array)
1002                         {
1003                                 close FILE;
1004                                 rename $file,$rndname2 if -e $file;
1005                                 if(rename $rndname1,$file)
1006                                 {
1007                                         unlink $rndname2 if -e $rndname2;
1008                                         return;
1009                                 }
1010                         }
1011                 }
1012                 close FILE;
1013                 die "Couldn't write to file \"$file\"";
1014         }
1015 }
1016
1017
1018
1019 #
1020 # Spam utilities
1021 #
1022
1023 sub spam_check($$) # Deprecated function
1024 {
1025         my ($text,$spamfile)=@_;
1026         return compile_spam_checker($spamfile)->($text);
1027 }
1028
1029 sub compile_spam_checker(@)
1030 {
1031         my @re=map {
1032                 s{(\\?\\?&\\?#([0-9]+)\\?;|\\?&\\?#x([0-9a-f]+)\\?;)}{
1033                         sprintf("\\x{%x}",($2 or hex $3));
1034                 }gei if $has_encode;
1035                 $_;
1036         } map {
1037                 s/(^|\s+)#.*//; s/^\s+//; s/\s+$//; # strip perl-style comments and whitespace
1038                 if(!length) { () } # nothing left, skip
1039                 elsif(m!^/(.*)/$!) { $1 } # a regular expression
1040                 elsif(m!^/(.*)/([xism]+)$!) { "(?$2)$1" } # a regular expression with xism modifiers
1041                 else { quotemeta } # a normal string
1042         } map read_array($_),@_;
1043
1044         return eval 'sub {
1045                 $_=shift;
1046                 # study; # causes a strange bug - moved to spam_engine()
1047                 return '.(join "||",map "/$_/mo",(@re)).';
1048         }';
1049 }
1050
1051 sub spam_engine(%)
1052 {
1053         my %args=@_;
1054         my @spam_files=@{$args{spam_files}||[]};
1055         my @trap_fields=@{$args{trap_fields}||[]};
1056         my @included_fields=@{$args{included_fields}||[]};
1057         my %excluded_fields=map ($_=>1),@{$args{excluded_fields}||[]};
1058         my $query=$args{query}||new CGI;
1059         my $charset=$args{charset};
1060
1061         for(@trap_fields) { spam_screen($query) if $query->param($_) }
1062
1063         my $spam_checker=compile_spam_checker(@spam_files);
1064         my @fields=@included_fields?@included_fields:$query->param;
1065         @fields=grep !$excluded_fields{$_},@fields if %excluded_fields;
1066 #       my $fulltext=join "\n",map decode_string($query->param($_),$charset),@fields;
1067         my $fulltext=join "\n",map $query->param($_),@fields;
1068         study $fulltext;
1069
1070         spam_screen($query) if $spam_checker->($fulltext);
1071 }
1072
1073 sub spam_screen($)
1074 {
1075         my $query=shift;
1076
1077         print "Content-Type: text/html\n\n";
1078         print "<html><body>";
1079         print "<h1>Anti-spam filters triggered.</h1>";
1080         print "<p>If you are not a spammer, you are probably accidentially ";
1081         print "trying to use an URL that is listed in the spam file. Try ";
1082         print "editing your post to remove it. Sorry for any inconvenience.</p>";
1083         print "<small style='color:white'><small>";
1084         print "$_<br>" for(map $query->param($_),$query->param);
1085         print "</small></small>";
1086
1087         exit 0;
1088 }
1089
1090
1091 #
1092 # Image utilities
1093 #
1094
1095 sub analyze_image($$)
1096 {
1097         my ($file,$name)=@_;
1098         my (@res);
1099
1100         safety_check($file);
1101
1102         return ("jpg",@res) if(@res=analyze_jpeg($file));
1103         return ("png",@res) if(@res=analyze_png($file));
1104         return ("gif",@res) if(@res=analyze_gif($file));
1105
1106         # find file extension for unknown files
1107         my ($ext)=$name=~/\.([^\.]+)$/;
1108         return (lc($ext),0,0);
1109 }
1110
1111 sub safety_check($file)
1112 {
1113         my ($file)=@_;
1114
1115         # Check for IE MIME sniffing XSS exploit - thanks, MS, totally appreciating this
1116         read $file,my $buffer,256;
1117         seek $file,0,0;
1118         die "Possible IE XSS exploit in file" if $buffer=~/<(?:body|head|html|img|plaintext|pre|script|table|title|a href|channel|scriptlet)/;
1119 }
1120
1121 sub analyze_jpeg($)
1122 {
1123         my ($file)=@_;
1124         my ($buffer);
1125
1126         read($file,$buffer,2);
1127
1128         if($buffer eq "\xff\xd8")
1129         {
1130                 OUTER:
1131                 for(;;)
1132                 {
1133                         for(;;)
1134                         {
1135                                 last OUTER unless(read($file,$buffer,1));
1136                                 last if($buffer eq "\xff");
1137                         }
1138
1139                         last unless(read($file,$buffer,3)==3);
1140                         my ($mark,$size)=unpack("Cn",$buffer);
1141                         last if($mark==0xda or $mark==0xd9);  # SOS/EOI
1142                         die "Possible virus in image" if($size<2); # MS GDI+ JPEG exploit uses short chunks
1143
1144                         if($mark>=0xc0 and $mark<=0xc2) # SOF0..SOF2 - what the hell are the rest?
1145                         {
1146                                 last unless(read($file,$buffer,5)==5);
1147                                 my ($bits,$height,$width)=unpack("Cnn",$buffer);
1148                                 seek($file,0,0);
1149
1150                                 return($width,$height);
1151                         }
1152
1153                         seek($file,$size-2,1);
1154                 }
1155         }
1156
1157         seek($file,0,0);
1158
1159         return ();
1160 }
1161
1162 sub analyze_png($)
1163 {
1164         my ($file)=@_;
1165         my ($bytes,$buffer);
1166
1167         $bytes=read($file,$buffer,24);
1168         seek($file,0,0);
1169         return () unless($bytes==24);
1170
1171         my ($magic1,$magic2,$length,$ihdr,$width,$height)=unpack("NNNNNN",$buffer);
1172
1173         return () unless($magic1==0x89504e47 and $magic2==0x0d0a1a0a and $ihdr==0x49484452);
1174
1175         return ($width,$height);
1176 }
1177
1178 sub analyze_gif($)
1179 {
1180         my ($file)=@_;
1181         my ($bytes,$buffer);
1182
1183         $bytes=read($file,$buffer,10);
1184         seek($file,0,0);
1185         return () unless($bytes==10);
1186
1187         my ($magic,$width,$height)=unpack("A6 vv",$buffer);
1188
1189         return () unless($magic eq "GIF87a" or $magic eq "GIF89a");
1190
1191         return ($width,$height);
1192 }
1193
1194 sub make_thumbnail($$$$$;$)
1195 {
1196         my ($filename,$thumbnail,$width,$height,$quality,$convert)=@_;
1197
1198         # first try ImageMagick
1199
1200         my $magickname=$filename;
1201         $magickname.="[0]" if($magickname=~/\.gif$/);
1202
1203         $convert="convert" unless($convert);
1204         `$convert -background white -flatten -size ${width}x${height} -geometry ${width}x${height}! -quality $quality $magickname $thumbnail`;
1205
1206         return 1 unless($?);
1207
1208         # if that fails, try pnmtools instead
1209
1210         if($filename=~/\.jpg$/)
1211         {
1212                 `djpeg $filename | pnmscale -width $width -height $height | cjpeg -quality $quality > $thumbnail`;
1213                 # could use -scale 1/n
1214                 return 1 unless($?);
1215         }
1216         elsif($filename=~/\.png$/)
1217         {
1218                 `pngtopnm $filename | pnmscale -width $width -height $height | cjpeg -quality $quality > $thumbnail`;
1219                 return 1 unless($?);
1220         }
1221         elsif($filename=~/\.gif$/)
1222         {
1223                 `giftopnm $filename | pnmscale -width $width -height $height | cjpeg -quality $quality > $thumbnail`;
1224                 return 1 unless($?);
1225         }
1226
1227         # try Mac OS X's sips
1228
1229         `sips -z $height $width -s formatOptions normal -s format jpeg $filename --out $thumbnail >/dev/null`; # quality setting doesn't seem to work
1230         return 1 unless($?);
1231
1232         # try PerlMagick (it sucks)
1233
1234         eval 'use Image::Magick';
1235         unless($@)
1236         {
1237                 my ($res,$magick);
1238
1239                 $magick=Image::Magick->new;
1240
1241                 $res=$magick->Read($magickname);
1242                 return 0 if "$res";
1243                 $res=$magick->Scale(width=>$width, height=>$height);
1244                 #return 0 if "$res";
1245                 $res=$magick->Write(filename=>$thumbnail, quality=>$quality);
1246                 #return 0 if "$res";
1247
1248                 return 1;
1249         }
1250
1251         # try GD lib (also sucks, and untested)
1252     eval 'use GD';
1253     unless($@)
1254     {
1255                 my $src;
1256                 if($filename=~/\.jpg$/i) { $src=GD::Image->newFromJpeg($filename) }
1257                 elsif($filename=~/\.png$/i) { $src=GD::Image->newFromPng($filename) }
1258                 elsif($filename=~/\.gif$/i)
1259                 {
1260                         if(defined &GD::Image->newFromGif) { $src=GD::Image->newFromGif($filename) }
1261                         else
1262                         {
1263                                 `gif2png $filename`; # gif2png taken from futallaby
1264                                 $filename=~s/\.gif/\.png/;
1265                                 $src=GD::Image->newFromPng($filename);
1266                         }
1267                 }
1268                 else { return 0 }
1269
1270                 my ($img_w,$img_h)=$src->getBounds();
1271                 my $thumb=GD::Image->new($width,$height);
1272                 $thumb->copyResized($src,0,0,0,0,$width,$height,$img_w,$img_h);
1273                 my $jpg=$thumb->jpeg($quality);
1274                 open THUMBNAIL,">$thumbnail";
1275                 binmode THUMBNAIL;
1276                 print THUMBNAIL $jpg;
1277                 close THUMBNAIL;
1278                 return 1 unless($!);
1279         }
1280
1281         return 0;
1282 }
1283
1284
1285 #
1286 # Crypto code
1287 #
1288
1289 sub rc4($$;$)
1290 {
1291         my ($message,$key,$skip)=@_;
1292         my @s=0..255;
1293         my @k=unpack 'C*',$key;
1294         my @message=unpack 'C*',$message;
1295         my ($x,$y);
1296         $skip=256 unless(defined $skip);
1297
1298         $y=0;
1299         for $x (0..255)
1300         {
1301                 $y=($y+$s[$x]+$k[$x%@k])%256;
1302                 @s[$x,$y]=@s[$y,$x];
1303         }
1304
1305         $x=0; $y=0;
1306         for(1..$skip)
1307         {
1308                 $x=($x+1)%256;
1309                 $y=($y+$s[$x])%256;
1310                 @s[$x,$y]=@s[$y,$x];
1311         }
1312
1313         for(@message)
1314         {
1315                 $x=($x+1)%256;
1316                 $y=($y+$s[$x])%256;
1317                 @s[$x,$y]=@s[$y,$x];
1318                 $_^=$s[($s[$x]+$s[$y])%256];
1319         }
1320
1321         return pack 'C*',@message;
1322 }
1323
1324 my @S;
1325
1326 sub setup_rc6($)
1327 {
1328         my ($key)=@_;
1329
1330         $key.="\0"x(4-(length $key)&3); # pad key
1331
1332         my @L=unpack "V*",$key;
1333
1334         $S[0]=0xb7e15163;
1335         $S[$_]=add($S[$_-1],0x9e3779b9) for(1..43);
1336
1337         my $v=@L>44 ? @L*3 : 132;
1338         my ($A,$B,$i,$j)=(0,0,0,0);
1339
1340         for(1..$v)
1341         {
1342                 $A=$S[$i]=rol(add($S[$i],$A,$B),3);
1343                 $B=$L[$j]=rol(add($L[$j]+$A+$B),add($A+$B));
1344                 $i=($i+1)%@S;
1345                 $j=($j+1)%@L;
1346         }
1347 }
1348
1349 sub encrypt_rc6($)
1350 {
1351         my ($block,)=@_;
1352         my ($A,$B,$C,$D)=unpack "V4",$block."\0"x16;
1353
1354         $B=add($B,$S[0]);
1355         $D=add($D,$S[1]);
1356
1357         for(my $i=1;$i<=20;$i++)
1358         {
1359                 my $t=rol(mul($B,rol($B,1)|1),5);
1360                 my $u=rol(mul($D,rol($D,1)|1),5);
1361                 $A=add(rol($A^$t,$u),$S[2*$i]);
1362                 $C=add(rol($C^$u,$t),$S[2*$i+1]);
1363
1364                 ($A,$B,$C,$D)=($B,$C,$D,$A);
1365         }
1366
1367         $A=add($A,$S[42]);
1368         $C=add($C,$S[43]);
1369
1370         return pack "V4",$A,$B,$C,$D;
1371 }
1372
1373 sub decrypt_rc6($)
1374 {
1375         my ($block,)=@_;
1376         my ($A,$B,$C,$D)=unpack "V4",$block."\0"x16;
1377
1378         $C=add($C,-$S[43]);
1379         $A=add($A,-$S[42]);
1380
1381         for(my $i=20;$i>=1;$i--)
1382         {
1383                 ($A,$B,$C,$D)=($D,$A,$B,$C);
1384                 my $u=rol(mul($D,add(rol($D,1)|1)),5);
1385                 my $t=rol(mul($B,add(rol($B,1)|1)),5);
1386                 $C=ror(add($C,-$S[2*$i+1]),$t)^$u;
1387                 $A=ror(add($A,-$S[2*$i]),$u)^$t;
1388
1389         }
1390
1391         $D=add32($D,-$S[1]);
1392         $B=add32($B,-$S[0]);
1393
1394         return pack "V4",$A,$B,$C,$D;
1395 }
1396
1397 sub setup_xtea($)
1398 {
1399 }
1400
1401 sub encrypt_xtea($)
1402 {
1403 }
1404
1405 sub decrypt_xtea($)
1406 {
1407 }
1408
1409 sub add(@) { my ($sum,$term); while(defined ($term=shift)) { $sum+=$term } return $sum%4294967296 }
1410 sub rol($$) { my ($x,$n); ( $x = shift ) << ( $n = 31 & shift ) | 2**$n - 1 & $x >> 32 - $n; }
1411 sub ror($$) { rol(shift,32-(31&shift)); } # rorororor
1412 sub mul($$) { my ($a,$b)=@_; return ( (($a>>16)*($b&65535)+($b>>16)*($a&65535))*65536+($a&65535)*($b&65535) )%4294967296 }
1413
1414 1;