bicyclesonthemoon.info Git - ott/bsta/blob - bsta_lib.1.pm

   1 # bsta_lib.pm is generated from bsta_lib.1.pm
   2 #
   3 # Library of functions
   4 #
   5 # Copyright (C) 2016, 2017, 2019, 2020, 2022, 2023  Balthasar Szczepański
   6 #
   7 # This program is free software: you can redistribute it and/or modify
   8 # it under the terms of the GNU Affero General Public License as
   9 # published by the Free Software Foundation, either version 3 of the
  10 # License, or (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU Affero General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU Affero General Public License
  18 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 package bsta_lib;
  21
  22 use strict;
  23 #use warnings
  24
  25 use utf8;
  26 use Exporter;
  27 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  28
  29 ###PERL_EXPORT_VERSION: our $VERSION = 'x.x.x';
  30 our @ISA         = qw(Exporter);
  31 our @EXPORT      = ();
  32 our @EXPORT_OK   = (
  33         'STATE', 'TEXT_MODE',
  34         'failpage', 'fail_method', 'fail_content_type',
  35         'get_remote_addr', 'get_frame', 'get_password',
  36         'merge_settings',
  37         'print_viewer_page',
  38         'write_index',
  39
  40         'readdatafile', 'writedatafile', 'printdatafile', # TO REMOVE
  41         'entityencode', # TO REMOVE
  42         'printdatafileht', # TO REMOVE ???
  43         'gethttpheader', 'getcgi', # TO REMOVE
  44         'urldecode', # TO REMOVE
  45         'urlencode', # TO REMOVE
  46         'linehtml', # TO REMOVE
  47         'bb2ht', 'bb2bb' # TO REMOVE
  48 );
  49
  50 ###PERL_LIB: use lib /botm/lib/bsta
  51 use botm_common (
  52         'url_query_decode', 'url_query_encode',
  53         'url_decode', 'url_encode',
  54         'html_entity_encode_dec',
  55         'merge_url',
  56         'read_header_env',
  57         'read_data_file', 'write_data_file'
  58 );
  59
  60 ###PERL_CGI_PATH:           CGI_PATH           = /bsta/
  61 ###PERL_CGI_BBCODE_PATH:    CGI_BBCODE_PATH    = /bsta/b
  62 ###PERL_CGI_CSS_PATH:       CGI_CSS_PATH       = /bsta/bsta.css
  63 ###PERL_CGI_FRAME_PATH:     CGI_FRAME_PATH     = /bsta/f
  64 ###PERL_CGI_GOTO_PATH:      CGI_GOTO_PATH      = /bsta/g
  65 ###PERL_CGI_INFO_PATH:      CGI_INFO_PATH      = /bsta/i
  66 ###PERL_CGI_LOGO_PATH:      CGI_LOGO_PATH      = /bsta/botmlogo.png
  67 ###PERL_CGI_TIMER_PATH:     CGI_TIMER_PATH     = /bsta/timer.js
  68 ###PERL_CGI_VIEWER_PATH:    CGI_VIEWER_PATH    = /bsta/v
  69
  70 ###PERL_SCHEME:             SCHEME             = http
  71 ###PERL_WEBSITE:            WEBSITE            = 1190.bicyclesonthemoon.info
  72 ###PERL_FAVICON_PATH:       FAVICON_PATH       = /img/favicon.png
  73
  74
  75 use constant STATE => {
  76         'inactive' => 0,
  77         'waiting'  => 1,
  78         'ready'    => 2,
  79         'end'      => 3,
  80 };
  81 use constant TEXT_MODE => {
  82         'normal' => 0,
  83         'bb'     => 1,
  84         'info'   => 2,
  85 };
  86
  87 use constant tags_bbcode => {
  88         'ht'    => '',
  89         '/ht'   => '',
  90         'fq'    => '[quote]',
  91         '/fq'   => '[/quote]',
  92         'tq'    => '[quote]',
  93         '/tq'   => '[/quote]',
  94         'ni'    => '[color=#0057AF]',
  95         '/ni'   => '[/color]',
  96         'br'    => '[color=#BB6622]',
  97         '/br'   => '[/color]',
  98         'po'    => '[color=#FF8800]',
  99         '/po'   => '[/color]',
 100         'url'   => '[url]',
 101         'url='  => '[url=',
 102         'url/=' => ']',
 103         '/url'  => '[/url]',
 104         'i'     => '[i]',
 105         '/i'    => '[/i]',
 106         'list'  => '[list]',
 107         'list=' => '[list=',
 108         'list/='=> ']',
 109         '/list' => '[/list]',
 110         '*'     => '[*]',
 111         '/*'    => '[/*]',
 112         '?'     => '[unknown!]',
 113         '/?'    => '[/unknown!]',
 114 };
 115 use constant tags_html => {
 116         'ht'     => '',
 117         '/ht'    => '',
 118         'fq'     => '<div class="fq">',
 119         '/fq'    => '</div>',
 120         'tq'     => '<div class="tq">',
 121         '/tq'    => '</div>',
 122         'ni'     => '<span class="ni">',
 123         '/ni'    => '</span>',
 124         'br'     => '<span class="br">',
 125         '/br'    => '</span>',
 126         'po'     => '<span class="po">',
 127         '/po'    => '</span>',
 128         'url'    => '<a href="#">',#think: how to add selfincluding?
 129         'url='   => '<a href="',
 130         'url/='  => '">',
 131         '/url'   => '</a>',
 132         'i'      => '<i>',
 133         '/i'     => '</i>',
 134         'list'   => '<ul>',
 135         'list='  => '<ol style="list-style-type: ',
 136         'list=1' => 'decimal',
 137         'list=A' => 'upper-alpha',
 138         'list=a' => 'lower-alpha',
 139         'list=I' => 'upper-roman',
 140         'list=i' => 'lower-roman',
 141         'list/=' => '">',
 142         '/list'  => '</ul>',
 143         '/list=' => '</ol>',
 144         '*'      => '<li>',
 145         '/*'     => '</li>',
 146         '?'      => '[unknown!]',
 147         '/?'     => '[/unknown!]',
 148 };
 149
 150
 151
 152 # Function to return an error page
 153 # arguments: 1 - header fields, 2 - page title, 3 - error message, 4 method
 154 sub failpage {
 155         (my $header, my $title, my $message, my $method) = @_;
 156         if($header ne ''){
 157                 print $header;
 158         }
 159         if($method eq 'HEAD') {
 160                 print "\n";
 161                 return;
 162         }
 163         print "Content-type: text/html; charset=UTF-8\n\n";
 164
 165         print '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "">'."\n";
 166         print '<html lang="en"><head>'."\n";
 167         print '<meta http-equiv="Content-type" content="text/html; charset=UTF-8">'."\n";
 168         if ($title ne '') {
 169                 print '<title>'.html_entity_encode_dec($title, 1).'</title>'."\n";
 170         }
 171         print '</head><body>'."\n";
 172         if ($title ne '') {
 173                 print '<h1>'.html_entity_encode_dec($title, 1).'</h1>'."\n";
 174         }
 175         if ($message ne '') {
 176                 print '<p>'.html_entity_encode_dec($message, 1).'</p>'."\n";
 177         }
 178         print '</body></html>'."\n";
 179 }
 180
 181 sub fail_method {
 182         (my $method, my $allowed) = @_;
 183
 184         my $header = "Status: 405 Method Not Allowed\n";
 185         if ($allowed ne '') {
 186                 $header .= "Allow: $allowed\n";
 187         }
 188         return failpage(
 189                 $header,
 190                 "405 Method Not Allowed",
 191                 "The interface does not support the $method method.",
 192                 $method
 193         );
 194 }
 195
 196 sub fail_content_type
 197 {
 198         (my $content_type, my $method) = @_;
 199
 200         return failpage(
 201                 "Status: 415 Unsupported Media Type\n",
 202                 "415 Unsupported Media Type",
 203                 "Unsupported Content-type: $content_type.",
 204                 $method
 205         );
 206 }
 207
 208 # function to obtain address of remote agent
 209 sub get_remote_addr {
 210         if ($ENV{'HTTP_X_FORWARDED_FOR'} =~ /^.+$/) {
 211                 return $&;
 212         }
 213         elsif ($ENV{'REMOTE_ADDR'} =~ /^.+$/) {
 214                 return $&;
 215         }
 216         else {
 217                 return '0.0.0.0';
 218         }
 219 }
 220
 221 # function to obtain frame number
 222 sub get_frame {
 223         (my $cgi) = @_;
 224
 225         if ($cgi{'f'} =~ /^.+$/) {
 226                 return int($&);
 227         }
 228         elsif ($ENV{'PATH_INFO'} =~ /^\/(.+)$/) {
 229                 return int($1);
 230         }
 231         else {
 232                 return 0;
 233         }
 234 }
 235
 236 # function to obtain password
 237 sub get_password {
 238         (my $cgi) = @_;
 239
 240         if ($cgi{'p'} =~ /^.+$/) {
 241                 return $&;
 242         }
 243         else {
 244                 return '';
 245         }
 246 }
 247
 248 sub merge_settings {
 249                 my %final_settings;
 250
 251         foreach my $settings (@_) {
 252                 foreach my $ind (keys %$settings) {
 253                         $final_settings{$ind} = $settings->{$ind};
 254                 }
 255         }
 256         return %final_settings;
 257 }
 258
 259 # TO REMOVE
 260 # function to encode entities, decimal,
 261 sub entityencode {
 262         (my $t, my $all) = @_;
 263         return html_entity_encode_dec($t, 1, $all);
 264 }
 265
 266 # TO REMOVE
 267 # function to get values of http header fields. Returns a hash. names of header
 268 # fields are lowercase
 269 sub gethttpheader {
 270         (my $env) = @_;
 271
 272         return read_header_env($env);
 273 }
 274
 275 # TO REMOVE
 276 # The function to get CGI parameters from string.
 277 # Format is: name=url_encoded_value&name=url_encoded_value& ... &name=url_encoded_value
 278 sub getcgi {
 279         return url_query_decode($_[0]);
 280 }
 281
 282 # TO REMOVE
 283 # Function for decoding URL-encoded text
 284 sub urldecode {
 285         return url_decode($_[0]);
 286 }
 287
 288 # TO REMOVE
 289 # Function to read data from datafiles.
 290 # Very similar to http header file reading. (function readheaderfile() in proxy
 291 # library)
 292 #
 293 # Differences:
 294 #
 295 # 1. After field name and colon there must be exactly one whitespace (space or
 296 # tab). Any other leading or trailing whitespace (but not the newline character
 297 # at the end of the line) is treated as part of the field value.
 298 #
 299 # 2. Instead of colon an equal sign can be used. The number of whitespaces after
 300 # it is then zero and not one.
 301 #
 302 # 3. When header field is split into multiple lines the next lines must start
 303 # with exactly one whitespace (tab or space) Any other leading or trailing
 304 # whitespace (but not the newline character at the end of the line) is treated
 305 # as part of the field value. the lines will be joined with a newline between
 306 # them.
 307 #
 308 # 4. When the same field name appears it replaces the previous one.
 309 #
 310 # 5. Line separator is LF and not CR LF. The CR character is treated as part of
 311 # the field value.
 312 #
 313 # 6. After the end of header (double newline) all next lines are treated as the
 314 # value of the "content" field.
 315 #
 316 # Returns a hash containing the values.
 317 # Names are case sensitive and are converted to lowercase
 318 #
 319 # Argument can be a path or a file handle. In case of a file handle it will just
 320 # read the file. In case of path it opens the file before reading and closes
 321 # after. On failure (file not open) returns empty hash.
 322 #
 323 sub readdatafile {
 324         (my $datapath) = @_;
 325
 326         return read_data_file($datapath);
 327 }
 328
 329 # TO REMOVE
 330 # the function to write data to datafiles (see readdatafile() description)
 331 #
 332 # First argument can be a path or a file handle. In case of a file handle it
 333 # will just write the file. In case of path it opens the file before writing and
 334 # closes after.
 335 #
 336 # On failure (file not open) returns 0.
 337 # On success returns 1.
 338 #
 339 sub writedatafile {
 340         (my $headerpath, my %header) = @_;
 341
 342         return write_data_file($headerpath, '', 0, \%header);
 343 }
 344
 345 # TO REMOVE
 346 # the function to print data to stdout (see readdatafile() description)
 347 #
 348 # On success returns 1.
 349 #
 350 sub printdatafile {
 351         (my %header) = @_;
 352
 353         return write_data_file(\*STDOUT, '', 0, \%header);
 354 }
 355
 356 # TO REMOVE
 357 # the function to print data to stdout as html (see readdatafile() description)
 358 #
 359 # On success returns 1.
 360 #
 361 sub printdatafileht {
 362         (my %header) = @_;
 363
 364         print_html_data(\*STDOUT, \%header);
 365         return 1;
 366 }
 367
 368 # TO REMOVE
 369 sub urlencode {
 370         (my $t, my $all) = @_;
 371         return url_encode($t, '', $all);
 372 }
 373
 374 # BB code stuff
 375 # different & simpler implementation than in post library
 376 # to consider:
 377 # a BBcode library?
 378
 379 #analyse bbcode text to build tag tree #TODO make [/*] optional!
 380 sub bbtree {
 381         (my $bb, my $printdebug) = @_;
 382         my %bbtree;
 383         my $ind;
 384         my $tag;
 385         my $tag_name;
 386         my $tag_value;
 387         my $tag_end;
 388         my $level=0;
 389         my $pre_text;
 390         my $debug;
 391
 392         $ind="_";
 393         $level=0;
 394         $bbtree{"_.name" }  = "ht";
 395         $bbtree{"_.value" } = '';
 396         $bbtree{"_.type"  } = "tag";
 397         $bbtree{"_.count" } = 0;
 398         $bbtree{"_.closed"} = 0;
 399         $debug .= debug($printdebug,
 400                 "\n".
 401                 "<!--GENERATING BBCODE TREE:\n".
 402                 '[_]automatic tag: [ht]'."\n"
 403         );
 404
 405         while ($bb ne '') {
 406                 my $new_ind = $ind.'.'.$bbtree{$ind.'.count'};
 407
 408                 if($bb =~ m/\[(\/?)([a-z]+|\*)(=([^\[\]]*))?\]/g) {
 409                         $pre_text = $`;
 410                         $tag = $&;
 411                         $tag_end = $1;
 412                         $tag_name = $2;
 413                         $tag_value = $4;
 414                         $bb = $';
 415
 416                         if ($pre_text ne '') {
 417                                 $debug .= debug($printdebug, "[$new_ind]text: $pre_text\n");
 418                                 $bbtree{$new_ind.'.type' } = 'text';
 419                                 $bbtree{$new_ind.'.value'} = $pre_text;
 420                                 $bbtree{    $ind.'.count'}+= 1;
 421                                 $new_ind = $ind.'.'.$bbtree{$ind.'.count'};
 422                         }
 423
 424                         if($tag_name =~ /^(fq|tq|br|ni|po|url|i|list|\*)$/) {
 425                                 if ($tag_end ne '') {
 426                                         if (
 427                                                 ($tag_name ne $bbtree{$ind.'.name'}) ||
 428                                                 ($level <= 0)
 429                                         ) {
 430                                                 $debug .= debug($printdebug, "[$new_ind]text: $tag\n");
 431                                                 $bbtree{$new_ind.'.type' } = 'text';
 432                                                 $bbtree{$new_ind.'.value'} = $tag;
 433                                                 $bbtree{    $ind.'.count'}+= 1;
 434                                                 # $new_ind = $ind.'.'.$bbtree{$ind.'.count'};
 435                                         }
 436                                         else {
 437                                                 $debug .= debug($printdebug, "[$new_$ind]tag: $tag\n");
 438                                                 $bbtree{$new_ind.'.type'  } = 'tag';
 439                                                 $bbtree{$new_ind.'.name'  } = '/'.$tag_name;
 440                                                 $bbtree{$new_ind.'.value' } = $tag_value;
 441                                                 $bbtree{    $ind.'.count' }+= 1;
 442                                                 $bbtree{    $ind.'.closed'} = 1;
 443                                                 $level -= 1;
 444                                                 $ind =~ s/\.[0-9]+$//;
 445                                                 # $new_ind = $ind.'.'.$bbtree{$ind.'.count'};
 446                                         }
 447                                 }
 448                                 else
 449                                 {
 450                                         $debug .= debug($printdebug, "[$new_ind]tag: $tag\n");
 451                                         $bbtree{$new_ind.'.type'  } = 'tag';
 452                                         $bbtree{$new_ind.'.name'  } = $tag_name;
 453                                         $bbtree{$new_ind.'.value' } = $tag_value;
 454                                         $bbtree{$new_ind.'.count' } = 0;
 455                                         $bbtree{$new_ind.'.closed'} = 0;
 456                                         $bbtree{    $ind.'.count' }+= 1;
 457                                         $level += 1;
 458                                         $ind = $new_ind;
 459                                         # $new_ind = $ind.'.'.$bbtree{$ind.'.count'};
 460                                 }
 461                         }
 462                         else {
 463                                 $debug .= debug($printdebug, "[$new_ind]text: $tag\n");
 464                                 $bbtree{$new_ind.'.type' } = 'text';
 465                                 $bbtree{$new_ind.'.value'} = $tag;
 466                                 $bbtree{    $ind.'.count'}+= 1;
 467                                 # $new_ind = $ind.'.'.$bbtree{$ind.'.count'};
 468                         }
 469                 }
 470                 else {
 471                         $debug .= debug($printdebug, "[$new_ind]text: $bb\n");
 472                         $bbtree{$new_ind.'.type' } = 'text';
 473                         $bbtree{$new_ind.'.value'} = $bb;
 474                         $bbtree{    $ind.'.count'}+= 1;
 475                         # $new_ind = $ind.'.'.$bbtree{$ind.'.count'};
 476                         $bb = '';
 477                 }
 478         }
 479         my $final_ind = '_.'.$bbtree{"_.count"}
 480         $debug .= debug($printdebug, "[$final_ind]automatic tag: [/ht]\n -->\n");
 481         $bbtree{$final_ind.'.type' } = "tag";
 482         $bbtree{$final_ind.'.name' } = '/ht';
 483         $bbtree{         '_.count' }+= 1;
 484         $bbtree{         '_.closed'} = 1;
 485
 486         return ($debug, %bbtree);
 487 }
 488
 489 #convert tag tree to final text
 490 sub convtree {
 491         (my $printdebug, my $debug, my $lang, my $bbtree) = @_;
 492         my $out;
 493         my $ind;
 494         my $indd;
 495         my $level = 0;
 496         my $tags = ($lang eq 'html') ? tags_html : tags_bbcode;
 497         my $escape = ($lang eq 'html');
 498
 499         # $debug .= debug($printdebug, "\n****\n");
 500         # foreach my $iiii (keys %tags) {
 501                 # $debug .= debug($printdebug, $iiii.'='.$tags->{$iiii}."\n");
 502         # }
 503         # $debug .= debug($printdebug, "****\n");
 504
 505         $level = 0;
 506         $ind = '_';
 507         $out = '';
 508         $debug .= debug($printdebug, "\n<!--PROCESSING BBCODE TREE:\n");
 509
 510         while ($level >= 0) {
 511                 my $goto_next = '';
 512                 $debug .= debug($printdebug, "[$level:$ind:".int($bbtree->{$ind.'.count'})."]");
 513                 #normal text
 514                 if ($bbtree->{$ind.'.type'} eq 'text') {
 515                         my $text = $bbtree->{$ind.'.value'}
 516                         $debug .= debug($printdebug, "text: ".$text);
 517                         $out .= $escape ? html_encode_line($text) : $text;
 518
 519                         $goto_next = 'tx';
 520                 }
 521                 #tag
 522                 elsif ($bbtree->{$ind.'.type'} eq 'tag') {
 523                         my $name = $bbtree->{$ind.'.name'};
 524                         #endtag
 525                         if ($name =~ /^\//) {
 526                                 $debug .= debug($printdebug, "tag: [$name]");
 527                                 $indd = $ind;
 528                                 $indd =~ s/\.([0-9]+)$//;
 529                                 if (exists($tags->{$name.'='}) && ($bbtree->{$indd.'.value'} ne '')) {
 530                                         $out .= $tags->{$name.'='};
 531                                 }
 532                                 elsif (exists($tags->{$name})) {
 533                                         $out .= $tags->{$name};
 534                                 }
 535                                 else {
 536                                         $out .= $tags->{'/?'};
 537                                         $debug .= debug($printdebug, "[unknown!]");
 538                                 }
 539
 540                                 $ind =~ s/\.([0-9]+)$//;
 541                                 $level -= 1;
 542                                 $debug .= debug($printdebug, "[<]");
 543                                 if ($level >= 0) {
 544                                         $goto-next = 'nd';
 545                                 }
 546                                 else {
 547                                         # time to end this
 548                                         $level = -1;
 549                                 }
 550                         }
 551                         #starttag
 552                         else {
 553                                 my $value = $bbtree->{$ind.'.value'};
 554                                 if($bbtree->{$ind.'.closed'} ne '') {
 555                                         $debug .= debug($printdebug, "tag: [$name]");
 556
 557                                         if (exists($tags->{$name.'='}) && ($value ne '')) {
 558                                                 if (exists($tags->{$name.'='.$value})) {
 559                                                         $out .=
 560                                                                 $tags->{$name.'='} .
 561                                                                 $tags->{$name.'='.$value'} .
 562                                                                 $tags->{$name.'/='};
 563                                                 }
 564                                                 else {
 565                                                         $out .=
 566                                                                 $tags->{$name.'='} .
 567                                                                 ($escape ? html_entity_encode_dec($value, 1) : $value) .
 568                                                                 $tags->{$name.'/='};
 569                                                 }
 570                                         }
 571                                         elsif (exists($tags->{$name})) {
 572                                                 $out .= $tags->{$name};
 573                                         }
 574                                         else {
 575                                                 $out .= $out.$tags->{'?'};
 576                                                 $debug .= debug($printdebug, "[unknown!]");
 577                                         }
 578                                 }
 579                                 else {
 580                                         $debug .= debug($printdebug, "unclosed tag: [$name]");
 581                                         my $text = $name . (($value ne '') ? ('='.$value) : '');
 582                                         $out .= '['.($escape ? html_encode_line($text) : $text).']';
 583                                 }
 584                                 if ($bbtree->{$ind.'.count'} > 0) {
 585                                         $ind = $ind.'.0';
 586                                         $level += 1;
 587                                         $debug .= debug($printdebug, "[>]");
 588                                 }
 589                                 else {
 590                                         $goto_next = 'st';
 591                                 }
 592                         }
 593                 }
 594                 # what is this
 595                 else {
 596                         $debug .= debug($printdebug, "unknown thing: ".$bbtree->{$ind.'.type'});
 597                         #should not occur with a correct bbtree
 598                         #unless unimplemented
 599                         $ind =~ s/\.([0-9]+)$//;
 600                         $level -= 1;
 601                         $debug .= debug($printdebug, "[<ui]");
 602                         if ($level > 0) {
 603                                 $goto_next = 'un';
 604                         }
 605                         else {
 606                                 # time to end this
 607                                 $level = -1;
 608                         }
 609                 }
 610                 if ($goto_next ne '') {
 611                         {do{
 612                                 $ind =~ s/\.([0-9]+)$//;
 613                                 my $i = int($1) + 1;
 614                                 if ($i < $bbtree->{$ind.'.count'}){
 615                                         # goto next
 616                                         $ind = $ind.'.'.$i;
 617                                         last;
 618                                 }
 619                                 else {
 620                                         # step out
 621                                         # should not occur with a correct bbtree
 622                                         $debug .= debug($printdebug, "[<$goto_next]");
 623                                         $level -= 1;
 624                                 }
 625                         } while ($level >= 0);}
 626                 }
 627
 628                 $debug .= debug($printdebug, "[>$level:$ind]\n");
 629         }
 630
 631         $debug .= debug($printdebug, "-->\n");
 632         return ($debug, $out);
 633 }
 634
 635 #bbcode to html, TBD
 636 sub bb_to_html {
 637         (my $bb, my $printdebug) = @_;
 638         my $ht;
 639         my %bbtree;
 640         my $debug;
 641
 642         ($debug, %bbtree) = bbtree($bb, $printdebug);
 643         ($debug, $ht) = convtree ($printdebug, $debug, 'html', %bbtree);
 644
 645         return $ht;
 646 }
 647
 648 #bbcode to bb, TBD
 649 sub bb_to_bbcode {
 650         (my $bb, my $printdebug) = @_;
 651         my $ht;
 652         my %bbtree;
 653         my $debug;
 654
 655         ($debug, %bbtree) = bbtree($bb, $printdebug);
 656         ($debug, $ht) = convtree ($printdebug, $debug, 'bb', %bbtree);
 657
 658         return $ht;
 659 }
 660
 661 # TO REMOVE
 662 sub bb2ht {
 663         return bb_to_html(@_);
 664 }
 665
 666 # TO REMOVE
 667 sub bb2bb {
 668         return bb_to_bbcode(@_);
 669 }
 670
 671 sub eval_bb {
 672         (my $bb) = @_;
 673         my $value;
 674         my $before;
 675         my $after;
 676
 677         while ($bb =~ m/###([^#;]*);/g) {
 678                 $value = $1;
 679                 $before = $`;
 680                 $after = $';
 681
 682                 if ($value =~ /^att&([0-9]+)$/) {
 683                         $value = merge_url(
 684                                 SCHEME().WEBSITE(),
 685                                 CGI_ATTACH_PATH(),
 686                                 int($1)
 687                         )
 688                 }
 689                 elsif ($value =~ /^vw&([0-9]+)$/) {
 690                         $value = merge_url(
 691                                 SCHEME().WEBSITE(),
 692                                 CGI_VIEWER_PATH(),
 693                                 int($1)
 694                         )
 695                 }
 696                 elsif ($value =~ /^fr&([0-9]+)$/) {
 697                         $value = merge_url(
 698                                 SCHEME().WEBSITE(),
 699                                 CGI_FRAME_PATH(),
 700                                 int($1)
 701                         )
 702                 }
 703                 else {
 704                         $value = '';
 705                 }
 706                 $bb = $before . $value . $after;
 707         }
 708         return $bb;
 709 }
 710
 711
 712 sub html_encode_line {
 713         (my $text, my $non_ascii, my $all) = @_;
 714         my $html;
 715         my $ind;
 716
 717         $text =~ s/\r\n/\n/gs;
 718         $text =~ s/\r/\n/gs;
 719
 720         while ($text ne '') {
 721                 $ind = index($text, "\n");
 722                 if ($ind >= 0) {
 723                         $html .= html_entity_encode_dec(substr($text, 0, $ind), $non_ascii, $all)."<br>\n";
 724                         $text = substr($text, $ind+1);
 725                 }
 726                 else
 727                 {
 728                         $html .= html_entity_encode_dec($text, 1);
 729                         $text = '';
 730                 }
 731         }
 732         return $html;
 733 }
 734
 735 # TO REMOVE
 736 sub linehtml {
 737         return html_encode_line($_[0], 1);
 738 }
 739
 740 sub debug {
 741         (my $print, my $text) = @_;
 742
 743         if ($print) {
 744                 print $text;
 745         }
 746
 747         return $text;
 748 }
 749
 750
 751 sub print_html_start {
 752         (my $fh) = @_;
 753         print $fh '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "">'."\n";
 754         print $fh '<html lang="en">'."\n";
 755 }
 756
 757 sub print_html_end {
 758         (my $fh) = @_;
 759         print $fh '</html>'."\n";
 760 }
 761
 762 sub print_html_head_start {
 763         print $fh '<head>'."\n";
 764         print $fh '<meta http-equiv="Content-type" content="text/html; charset=UTF-8">'."\n";
 765         print $fh '<link rel="icon" type="image/png" href="'.html_entity_encode_dec(FAVICON_PATH(),1).'">'."\n";
 766         print $fh '<link rel="stylesheet" href="'.html_entity_encode_dec(CGI_CSS_PATH(),1).'">'."\n";
 767 }
 768
 769 sub print_html_head_end {
 770         (my $fh) = @_;
 771         print $fh '</head>'."\n";
 772 }
 773
 774 sub print_html_body_start {
 775         (my $fh) = @_;
 776         print $fh '<body>'."\n";
 777         print $fh '<a href="/"><img id="botmlogo" src="'.html_entity_encode_dec(CGI_LOGO_PATH(),1).'" alt="'.html_entity_encode_dec(WEBSITE(),1).'"></a>'."\n";
 778         print $fh '<div id="all">'."\n";
 779 }
 780
 781 sub print_html_body_end {
 782         (my $fh) = @_;
 783         print $fh '</div>'."\n";
 784         print $fh '<a href="/" class="cz">'.html_entity_encode_dec(WEBSITE(),1).'</a>'."\n";
 785         print $fh '</body></html>'."\n";
 786 }
 787
 788 sub print_html_data {
 789         (my $fh, my $data) = @_;
 790
 791         foreach my $key (keys %$data) {
 792                 unless ($key eq 'content') {
 793                         my $val = $data->{'ind'};
 794                         $val =~ s/(\r)?\n/\n /gs; # does the space make sense in HTML anyway?
 795                         print $fh html_encode_line("$key: $val\n", 1);
 796                 }
 797         }
 798         print $fh html_encode_line("\n".$data->{'content'});
 799 }
 800
 801 sub print_viewer_page {
 802         (
 803                 my $file,
 804                 my $context,
 805                 my $state,
 806                 my $settings,
 807                 my $frame_data,
 808                 my $next_frame_data
 809         ) = @_;
 810         my $fh;
 811
 812         my $frame = int($context->{'frame'});
 813         # my $prev_frame = $frame - 1;
 814         my $next_frame = $frame + 1;
 815
 816         my $title   =      $frame_data->{'title'};
 817         my $command = $next_frame_data->{'title'};
 818
 819         my $access      = $context->{'access'};
 820         my $password_ok = $context->{'password_ok'};
 821         my $static      = $context->{'static'};
 822
 823         my $text_mode      = int($context->{'text_mode'});
 824         my $timer_unlocked = int($context->{'timer_unlocked'});
 825         my $timer          = int($context->{'timer'};
 826
 827         my $last_frame = int($state->{'last'});
 828         my $ong_state  = int($state->{'state'});
 829
 830         my $timer_color_h = (($timer_unlocked >= 1) || ($ong_state >= STATE->{'ready'})) ? 'br' : 'ni';
 831         my $timer_color_m = (($timer_unlocked >= 2) || ($ong_state >= STATE->{'ready'})) ? 'br' : 'ni';
 832         my $timer_color_s = (($timer_unlocked >= 3) || ($ong_state >= STATE->{'ready'})) ? 'br' : 'ni';
 833
 834         my $timer_h;
 835         my $timer_m;
 836         my $timer_s;
 837         if ($timer > 0) {
 838                 $timer_s = sprintf('%02d', $timer % 60);
 839                 $timer_h = int($timer / 60);
 840                 $timer_m = sprintf('%02d', $timer_h % 60);
 841                 $timer_h = sprintf('%02d', $timer_h / 60);
 842         }
 843         elsif (($timer >= -15) && ($ong_state >= STATE->{'ready'})) {
 844                 $timer_h = '00';
 845                 $timer_m = '00';
 846                 $timer_s = 'NG';
 847         }
 848         else {
 849                 $timer_h = 'EE';
 850                 $timer_m = 'EE';
 851                 $timer_s = 'EE';
 852         }
 853
 854         my $prev_available = (($frame > 0) && $access');
 855         my $next_available = ($password_ok' || ($next_frame <= $last_frame));
 856         my $prefetch_next  = (
 857                 $password_ok ||
 858                 ($next_frame < $tast_frame) || (
 859                         ($next_frame <= $last_frame) &&
 860                         ($ong_state >= STATE->{'ready'})
 861                 )
 862         );
 863         my $show_timer = (
 864                 ($frame == $last_frame)) && (
 865                         ($ong_state == STATE->{'waiting'}) ||
 866                         ($ong_state == STATE->{'ready'})
 867                 )
 868         );
 869         my $show_command = (
 870                 $password_ok' ||
 871                 ($frame' < $last_frame) || (
 872                         ($ong_state) >= STATE->{'ready'}) &&
 873                         $context->{'show_command'}
 874                 )
 875         );
 876         my $show_command_link = ($next_available || (!$access));
 877         my $show_command_cursor = (($frame == $last_frame) || ($command eq ''));
 878         my $frame_indirect = !(
 879                 (!$access) || (
 880                         ($frame <= $last_frame) &&
 881                         ($ong_state > STATE->{'inactive'})
 882                 )
 883         );
 884         my $nextframe_indirect = !($next_frame < $last_frame);
 885
 886         my $password_query;
 887
 888         my $base_url   = CGI_PATH;
 889         my $goto_url   = CGI_GOTO_PATH;
 890         my $info_url   = CGI_INFO_PATH;
 891         my $bbcode_url = CGI_BBCODE_PATH;
 892         my $timer_url  = CGI_TIMER_PATH;
 893         my $viewer_full_url = merge_url(
 894                 {'scheme' => SCHEME(), 'host' => WEBSITE()},
 895                 {'path' => CGI_VIEWER_PATH()},
 896                 {'path' => $frame}
 897         );
 898         my $viewer_url = merge_url(
 899                 {'path' => CGI_VIEWER_PATH()},
 900                 {'path' => $frame}
 901         );
 902         my $viewer_0_url = merge_url(
 903                 {'path' => CGI_VIEWER_PATH()},
 904                 {'path' => 0}
 905         );
 906         my $viewer_prev_url = merge_url(
 907                 {'path' => CGI_VIEWER_PATH()},
 908                 {'path' => $frame-1}
 909         );
 910         my $viewer_next_url = merge_url(
 911                 {'path' => CGI_VIEWER_PATH()},
 912                 {'path' => $next_frame}
 913         );
 914         my $viewer_last_url = merge_url(
 915                 {'path' => CGI_VIEWER_PATH()},
 916                 {'path' => ($static ? -1 : $last_frame)}
 917         );
 918         if ($text_mode != TEXT_MODE->{'bb'}) {
 919                 $bbcode_url = merge_url(
 920                         $viewer_url,
 921                         {'query'=>{
 922                                 'b' = TEXT_MODE->{'bb'}
 923                         }}
 924                 );
 925         }
 926         if ($text_mode != TEXT_MODE->{'info'}) {
 927                 $info_url = merge_url(
 928                         $viewer_url,
 929                         {'query'=>{
 930                                 'b' = TEXT_MODE->{'info'}
 931                         }}
 932                 );
 933         }
 934         my $frame_file = '';
 935         my $frame_url;
 936         my $frame_next_url;
 937         my $frame_normal_url;
 938         my $frame_full_url;
 939         if ($frame_data->{'frame'} ne '') {
 940                 $frame_file = $frame_data->{'frame'};
 941         }
 942         else {
 943                 $frame_file = sprintf(
 944                         $settings->{'frame'},
 945                         $frame, $frame_data->{'ext'}
 946                 );
 947         }
 948         $frame_normal_url = merge_url(
 949                         {'path' => CGI_PATH()},
 950                         {'path' => $frame_file}
 951                 );
 952         $frame_url = $frame_indirect ?
 953                 merge_url(
 954                         {'path' => CGI_FRAME_PATH()},
 955                         {'path' => $frame}
 956                 ) :
 957                 $frame_normal_url;
 958         $frame_full_url = merge_url(
 959                 {'scheme' => SCHEME(), 'host' => WEBSITE()},
 960                 {'path' => $frame_normal_url}
 961         );
 962         if ($nextframe_indirect) {
 963                 $frame_next_url = merge_url(
 964                         {'path' => CGI_FRAME_PATH()},
 965                         {'path' => $nextframe}
 966                 );
 967         }
 968         elsif ($next_frame_data->{'frame'} ne '') {
 969                 $frame_next_url = merge_url(
 970                         {'path' => CGI_PATH()},
 971                         {'path' => $next_frame_data->{'frame'}}
 972                 );
 973         }
 974         else {
 975                 $frame_next_url = merge_url(CGI_PATH(), sprintf(
 976                         $settings->{'frame'}, $next_frame, $next_frame_data->{'ext'}
 977                 ));
 978         }
 979
 980         if ($password_ok) {
 981                 $password_query = url_query_encode({'p', $settings->{'password'}});
 982                 $goto_url        = merge_url($goto_url       , {'query' => $password_query});
 983                 $info_url        = merge_url($info_url       , {'query' => $password_query});
 984                 $bbcode_url      = merge_url($bbcode_url     , {'query' => $password_query});
 985                 $viewer_url      = merge_url($viewer_url     , {'query' => $password_query});
 986                 $viewer_0_url    = merge_url($viewer_0_url   , {'query' => $password_query});
 987                 $viewer_prev_url = merge_url($viewer_prev_url, {'query' => $password_query});
 988                 $viewer_next_url = merge_url($viewer_next_url, {'query' => $password_query});
 989                 $viewer_last_url = merge_url($viewer_last_url, {'query' => $password_query});
 990                 if ($frame_indirect) {
 991                         $frame_url = merge_url($frame_url     , {'query' => $password_query});
 992                 }
 993                 if ($nextframe_indirect) {
 994                         $frame_url = merge_url($frame_next_url, {'query' => $password_query});
 995                 }
 996         }
 997         my $_base_url        = html_entity_encode_dec($base_url       , 1);
 998         my $_goto_url        = html_entity_encode_dec($goto_url       , 1);
 999         my $_info_url        = html_entity_encode_dec($info_url       , 1);
1000         my $_bbcode_url      = html_entity_encode_dec($bbcode_url     , 1);
1001         my $_timer_url       = html_entity_encode_dec($timer_url      , 1);
1002         my $_viewer_full_url = html_entity_encode_dec($viewer_full_url, 1);
1003         my $_viewer_url      = html_entity_encode_dec($viewer_url     , 1);
1004         my $_viewer_0_url    = html_entity_encode_dec($viewer_0_url   , 1);
1005         my $_viewer_prev_url = html_entity_encode_dec($viewer_prev_url, 1);
1006         my $_viewer_next_url = html_entity_encode_dec($viewer_next_url, 1);
1007         my $_viewer_last_url = html_entity_encode_dec($viewer_last_url, 1);
1008         my $_frame_url       = html_entity_encode_dec($frame_url      , 1);
1009         my $_frame_next_url  = html_entity_encode_dec($frame_next_url , 1);
1010         my $_frame_full_url  = html_entity_encode_dec($frame_full_url , 1);
1011
1012         my $_title   = html_entity_encode_dec($title,   1);
1013         my $_command = html_entity_encode_dec($command, 1);
1014
1015         if ($text_mode == TEXT_MODE->{'info'}) {
1016                 if ($show_command) {
1017                         $frame_data->{'command'} = $command;
1018                 }
1019                 if ($context->{'access'}) {
1020                         $frame_data->{'frame'} = $frame_file;
1021                 }
1022         }
1023
1024         if (ref($file)) {
1025                 $fh=$file;
1026                 unless (seek($fh, 0, 0)) {
1027                         #don't actually fail here
1028                 }
1029         }
1030         else {
1031                 unless (open ($fh, ">:encoding(UTF-8)", encode('locale_fs', $file))) {
1032                         return 0;
1033                 }
1034         }
1035
1036         print_html_start($fh);
1037         print_html_head_start($fh);
1038
1039         print $fh '<link rel="index" href="'.$_goto_url.'">'."\n";
1040         print $fh '<link rel="start" href="'.$_viewer_0_url.'">'."\n";
1041         if ($prev_available) {
1042                 print $fh '<link rel="prev" href="'.$_viewer_prev_url.'">'."\n";
1043         }
1044         if ($next_available) {
1045                 print $fh '<link rel="next" href="'.$_viewer_next_url.'">'."\n";
1046                 if ($prefetch_next) {
1047                         print $fh '<link rel="prefetch" href="'.$_viewer_next_url.'">'."\n";
1048                         print $fh '<link rel="prefetch" href="'.$_frame_next_url.'">'."\n";
1049                 }
1050         }
1051         if ($show_timer) {
1052                 print $fh '<!-- <script src="'.$_timer_url.'"></script> -->'."\n";
1053         }
1054
1055         print_html_head_end($fh);
1056         print_html_body_start($fh);
1057
1058         print $fh '<div id="inst" class="ins">'."\n";
1059
1060         print $fh '<div id="title">'."\n";
1061         print $fh '<h1 id="titletext">'.$_title.'</h1>'."\n";
1062         print $fh '</div>'."\n";
1063
1064         print $fh '</div><div id="framespace">'."\n";
1065
1066         print $fh '<img src="'.$_frame_url.'" id="frame" alt="'.$frame.'" title="'.$_title.'">'."\n";
1067
1068         print $fh '</div><div id="insb" class="ins">'."\n";
1069
1070         if ($text_mode == TEXT_MODE->{'info'}) {
1071                 print $fh '<div id="chat">'."\n";
1072
1073                 print_html_data($fh, $frame_data);
1074
1075                 print $fh '</div>'."\n";
1076         }
1077         elsif ($text_mode == TEXT_MODE->{'bb'}) {
1078                 print $fh '<div id="chat">'."\n";
1079
1080                 print $fh '[quote][center][size=200]'.$_title.'[/size]<br>'."\n";
1081                 print $fh '[url='.$_viewer_full_url.'][img]'.$_frame_full_url.'[/img][/url][/center]<br>'."\n";
1082                 print $fh html_encode_line(bb_to_bbcode(eval_bb($frame_data->{'content'})));
1083                 print $fh '[/quote]</div>'."\n";
1084
1085                 print $fh '</div>'."\n";
1086         }
1087         elsif ($frame_data->{'content'} ne '') {
1088                 print $fh '<div id="undertext">'."\n";
1089                 print $fh bb_to_html(eval_bb($frame_data->{'content'}))."\n";
1090                 print $fh '</div>'."\n";
1091         }
1092
1093         print $fh '<div id="command">'."\n";
1094
1095         if ($show_timer) {
1096                 print $fh '[<span id="ongh" class="'.$timer_color_h.'">'.$timer_h.'</span>';
1097                 print $fh ':<span id="ongm" class="'.$timer_color_m.'">'.$timer_m.'</span>';
1098                 print $fh ':<span id="ongs" class="'.$timer_color_s.'">'.$timer_s.'</span>]<br>'."\n";
1099         }
1100         print '&gt';
1101         if ($show_command_link) {
1102                 print $fh '<a href="'.($access : $_viewer_next_url : $_viewer_last_url).'">';
1103         }
1104         if ($show_command) {
1105                 print $fh $_command;
1106         }
1107         if ($show_command_cursor) {
1108                 print $fh '<span class="inp">_</span>';
1109         }
1110         if ($show_command_link) {
1111                 print $fh '</a>';
1112         }
1113         print $fh "<br>\n</div>\n";
1114
1115         print $fh '<div id="underlinks">'."\n";
1116
1117         unless (($frame == 0) && $Static) {
1118                 print $fh '<a href="'.$_base_url.'">Once again</a> | ';
1119         }
1120         if ($prev_available) {
1121                 print $fh '<a href="'.$_viewer_prev_url.'">Before</a> | ';
1122         }
1123         unless ($frame == $last_frame) {
1124                 print $fh '<a href="'.$_viewer_last_url.'">Now</a> | ';
1125         }
1126         print $fh '<a href="'.$_goto_url.'">GOTO</a>'."\n";
1127         print $fh '<span style="float: right;">'."\n";
1128         if ($text_mode != TEXT_MODE->{'normal'}) {
1129                 print $fh '<a href="'.$_viewer_url.'">Without</a> | ';
1130         }
1131         print $fh '<a href="'.$_info_path.'">Info</a> | ';
1132         print $fh '<a href="'.$_bbcode_path.'">BB</a>';
1133         print $fh "\n</span>\n";
1134
1135         print $fh "</div>\n</div>\n";
1136
1137         print_html_body_end($fh);
1138         print_html_end($fh);
1139
1140
1141         unless (ref($file)) {
1142                 close ($fh);
1143         }
1144         else {
1145                 truncate ($fh , tell($fh));
1146         }
1147
1148         return 1;
1149 }
1150
1151
1152 sub write_index {
1153         (
1154                 my $mode,
1155                 my $state,
1156                 my $settings
1157         ) = @_;
1158
1159         if ($mode eq viewer) {
1160                 my %frame_data     = read_data_file(join_path(PATH_SEPARATOR(), DATA_PATH(), 0));
1161                 my %next_frame_data= read_data_file(join_path(PATH_SEPARATOR(), DATA_PATH(), 1));
1162                 my %default        = read_data_file(DATA_DEFAULT_PATH());
1163
1164                 %frame_data     = merge_settings(\%default,      \%frame_data);
1165                 %next_frame_data= merge_settings(\%default, \%next_frame_data);
1166
1167                 print_viewer_page(
1168                         WWW_INDEX_PATH(),
1169                         {
1170                                 'frame' => 0,
1171                                 'access' => 1,
1172                                 'password_ok' => 0,
1173                                 'timer_unlocked' => 3, # not relevant
1174                                 'timer' => 0, # not relevant
1175                                 'static' => 1,
1176                                 'show_command' => 1
1177                         },
1178                         $state,
1179                         $settings,
1180                         \%frame_data,
1181                         \%next_frame_data
1182                 );
1183         }
1184         else {
1185                 # TO DO !
1186         }
1187 }
1188
1189
1190 1