Lib/perllib/tricgi.pm

   1 package tricgi;
   2
   3 =head1 NAME
   4
   5 tricgi - HTML-rutiner for bruk i index.cgi
   6
   7 =head1 REVISION
   8
   9 S<$Id: tricgi.pm,v 1.12 1999/07/05 13:33:59 sunny Exp $>
  10
  11 =head1 SYNOPSIS
  12
  13 require tricgi;
  14
  15 =head1 DESCRIPTION
  16
  17 Inneholder en del rutiner som brukes av F<index.cgi>. Inneholder generelle
  18 HTML-rutiner som brukes hele tiden.
  19
  20 =head1 COPYRIGHT
  21
  22 (C)opyright 1999 ?yvind A. Holm E<lt>F<sunny@tritech.no>E<gt>
  23
  24 Denne modulen er eiendom tilh?rende ?yvind A. Holm. Dispensasjon for bruk
  25 er gitt til Tritech A/S E<lt>F<http://www.tritech.no>E<gt> inntil videre.
  26
  27 =cut
  28
  29 require 5.003;
  30
  31 =head1 VARIABLER
  32
  33 =head2 N?dvendige variabler
  34
  35 N?r man bruker dette biblioteket, er det en del variabler som m? defineres
  36 under kj?ring:
  37
  38 =over 4
  39
  40 =item I<${main::Url}>
  41
  42 URL'en til index.cgi. Normalt sett blir denne satt til navnet p? scriptet,
  43 for eksempel "I<index.cgi>" eller lignende. F?r ble I<${main::Url}> satt
  44 til full URL med F<httpZ<>://> og greier, men det gikk d?rlig hvis ting
  45 for eksempel ble kj?rt under F<httpsZ<>://>
  46
  47 =item I<${main::WebMaster}>
  48
  49 Emailadressen til den som eier dokumentet. Denne blir ikke satt inn p?
  50 copyrighter og s?nn, der er det F<tritech@tritech.no> som hersker.
  51
  52 =item I<${main::error_file}>
  53
  54 Filnavn p? en fil som er skrivbar av den som kj?rer scriptet (som oftest
  55 I<nobody>). Alle feilmeldinger og warnings havner her.
  56
  57 =item I<${main::log_dir}>
  58
  59 Navn p? directory der logging fra blant annet I<&log_access()> havner.
  60 Brukeren I<nobody> (eller hva n? httpd m?tte kj?re under) skal ha
  61 skrive/leseaksess der.
  62
  63 =back
  64
  65 NB: Disse m? ikke v?re I<my>'et, de m? v?re globale s? de kan bli brukt av
  66 alle modulene.
  67
  68 =head2 Valgfrie variabler
  69
  70 Disse variablene er ikke n?dvendige ? definere, bare hvis man gidder:
  71
  72 =over 4
  73
  74 =item I<${main::doc_width}>
  75
  76 Bredden p? dokumentet i pixels. I<$STD_DOCWIDTH> som default.
  77
  78 =item I<${main::CharSet}>
  79
  80 Tegnsett som brukes. Er I<$STD_CHARSET> som default, "I<ISO-8859-1>".
  81
  82 =item I<${main::BackGround}>
  83
  84 Bruker denne som default bakgrunn til I<&print_background()>. Hvis den
  85 ikke er definert, brukes I<$STD_BACKGROUND>, en tom greie.
  86
  87 =item I<${main::Debug}>
  88
  89 Skriver ut en del debuggingsinfo.
  90
  91 =item I<${main::FONTB}>
  92 =item I<${main::FONTE}>
  93
  94 Disse to definerer fontene som skal brukes. I alle omr?der med tekst
  95 legges disse inn, for eksempel:
  96
  97         $tricgi::tab_print("<h1>${FONTB}Dette er en snadderheader${FONTE}</h1>\n";
  98
  99 Normalt sett er $FONTB og $FONTE satt til disse verdiene s?nn omtrent:
 100
 101         $FONTB = '<font face="arial, helvetica">';
 102         $FONTE = '</font>';
 103
 104 Dette er som kjent bare lov i HTML n?r minst I<$DTD_HTML4LOOSE> brukes.
 105
 106 =item I<${main::Utv}>
 107
 108 Beslektet med I<${main::Debug}>, men hvis denne er definert, sitter man
 109 lokalt og tester. Ikke helt klargjort hvordan disse to skal fungere i
 110 forhold til hverandre, men n?r sida ligger offentlig, skal hverken
 111 I<${main::Debug}> eller I<${main::Utv}>
 112
 113 =item I<${main::Border}>
 114
 115 Brukes mest til debugging. Setter I<border> i alle E<lt>tableE<gt>'es.
 116
 117 =back
 118
 119 =cut
 120
 121 ###########################################################################
 122 #### Variabler og moduler
 123 ###########################################################################
 124
 125 # use Time::Local; # curr_local_time() sin greie.
 126
 127 my $Tabs = "";
 128
 129 my $rcs_header = '$Header: /home/sunny/tmp/cvs/perllib/tricgi.pm,v 1.12 1999/07/05 13:33:59 sunny Exp $';
 130 my $rcs_id = '$Id: tricgi.pm,v 1.12 1999/07/05 13:33:59 sunny Exp $';
 131 my $rcs_date = '$Date: 1999/07/05 13:33:59 $';
 132
 133 # $cvs_* skal ut av sirkulasjon etterhvert. Forel?pig er de merket med "GD" (Gammel Drit) for ? finne dem.
 134 my $cvs_header = '$Header: /home/sunny/tmp/cvs/perllib/tricgi.pm,v 1.12 1999/07/05 13:33:59 sunny Exp $ GD';
 135 my $cvs_id = '$Id: tricgi.pm,v 1.12 1999/07/05 13:33:59 sunny Exp $ GD';
 136 my $cvs_date = '$Date: 1999/07/05 13:33:59 $ GD';
 137
 138 my $this_counter = "";
 139
 140 my $FALSE = 0;
 141 my $TRUE = 1;
 142
 143 my $DTD_HTML4FRAMESET = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Frameset//EN\"\n\"http://www.w3.org/TR/REC-html40/frameset.dtd\">\n";
 144 my $DTD_HTML4LOOSE = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\"\n\"http://www.w3.org/TR/REC-html40/loose.dtd\">\n";
 145 my $DTD_HTML4STRICT = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0//EN\"\n\"http://www.w3.org/TR/REC-html40/strict.dtd\">\n";
 146
 147 my $STD_BACKGROUND = "";
 148 my $STD_CHARSET = "ISO-8859-1"; # Hvis $main::CharSet ikke er definert
 149 my $STD_DOCALIGN = "center"; # Standard align for dokumentet hvis align ikke er spesifisert
 150 my $STD_DOCWIDTH = "500"; # Hvis ikke $main::doc_width er spesifisert
 151 my $STD_HTMLDTD = $DTD_HTML4LOOSE;
 152 my $STD_LOGDIR = "/usr/local/www/APACHE_LOG/default"; # FIXME: Litt skummelt kanskje. Mulig "/var/log/etellerannet" skulle v?rt istedenfor, men n?ye d?.
 153
 154 ###########################################################################
 155 #### Subrutiner
 156 ###########################################################################
 157
 158 =head1 SUBRUTINER
 159
 160 =cut
 161
 162 ###########################################################################
 163
 164 =head2 &content_type()
 165
 166 Brukes omtrent bare av F<&print_header()>, men kan kalles
 167 separat hvis det er speisa content-typer ute og g?r, som for eksempel
 168 C<application/x-tar> og lignende.
 169
 170 =cut
 171
 172 sub content_type {
 173         my $ContType = shift;
 174         my $CharSet = $STD_CHARSET unless length(${main::CharSet});
 175         if (length($ContType)) {
 176                 print "Content-Type: $ContType; charset=$CharSet\n\n" ;
 177         } else {
 178                 &HTMLwarn("Intern feil: \$ContType ble ikke spesifisert til &content_type()");
 179         }
 180         # print "Content-Type: $ContType\n\n"; # Til ?re for slappe servere som ikke har peiling
 181 } # content_type()
 182
 183 ###########################################################################
 184
 185 =head2 &curr_local_time()
 186
 187 Returnerer tidspunktet akkurat n?, lokal tid. Formatet er i henhold til S<ISO 8601>, dvs.
 188 I<YYYY>-I<MM>-I<DD>TI<HH>:I<MM>:I<SS>+I<HHMM>
 189
 190 B<FIXME:> Finn en m?te ? returnere differansen mellom UTC og lokal tid.
 191 Forel?pig droppes +0200 og s?nn. Det liker vi I<ikke>. Ikke baser noen
 192 programmer p? formatet forel?pig.
 193
 194 =cut
 195
 196 sub curr_local_time {
 197         my @TA = localtime();
 198         # my $GM = mktime(gmtime());
 199         # my $LO = localtime();
 200         # my $utc_diff = ($GM-$LO)/3600;
 201
 202         # - &deb_pr(__LINE__ . ": curr_local_time(): gmtime = \"$GM\", localtime = \"$LO\"");
 203         my $LocalTime = sprintf("%04u-%02u-%02uT%02u:%02u:%02u", $TA[5]+1900, $TA[4]+1, $TA[3], $TA[2], $TA[1], $TA[0]);
 204         &deb_pr(__LINE__ . ": curr_local_time(): Returnerer \"$LocalTime\"");
 205         return($LocalTime);
 206 } # curr_local_time()
 207
 208 ###########################################################################
 209
 210 =head2 &curr_utc_time()
 211
 212 Returnerer tidspunktet akkurat n? i UTC. Brukes av blant annet
 213 F<&print_header()> til ? sette rett tidspunkt inn i headeren. Formatet p?
 214 datoen er i henhold til S<ISO 8601>, dvs.
 215 I<YYYY>-I<MM>-I<DD>TI<HH>:I<MM>:I<SS>Z
 216
 217 =cut
 218
 219 sub curr_utc_time {
 220         my @TA = gmtime(time);
 221         my $UtcTime = sprintf("%04u-%02u-%02uT%02u:%02u:%02uZ", $TA[5]+1900, $TA[4]+1, $TA[3], $TA[2], $TA[1], $TA[0]);
 222         &deb_pr(__LINE__ . ": curr_utc_time(): Returnerer \"$UtcTime\"");
 223         return($UtcTime);
 224 } # curr_utc_time()
 225
 226 ###########################################################################
 227
 228 =head2 &deb_pr()
 229
 230 En debuggingsrutine som kj?res hvis ${main::Debug} ikke er 0. Den
 231 forlanger at ${main::$error_file} er definert, det skal v?re en fil der
 232 all debuggingsinformasjonen skrives til.
 233
 234 For at debugging skal bli lettere, kan man slenge denne inn p? enkelte
 235 steder. Eksempel:
 236
 237         &deb_pr(__LINE__ . ": sort_dir(): Det er $Elements elementer her.");
 238
 239 Hvis dette formatet brukes (fram til og med __LINE__) kan man filtrere fila
 240 gjennom denne perlsnutten for ? kommentere ut alle debuggingsmeldingene:
 241
 242         #!/usr/bin/perl
 243
 244         while (<>) {
 245                 s/(&deb_pr\(__LINE__)/# $1/g;
 246                 print;
 247         }
 248
 249 For ? ta bort utkommenteringen, filtrer fila gjennom dette scriptet:
 250
 251         #!/usr/bin/perl
 252
 253         while (<>) {
 254                 s/# (&deb_pr\(__LINE__)/$1/g;
 255                 print;
 256         }
 257
 258 Dette er bare n?dvendig hvis det ligger str?dd med debuggingsmeldinger p?
 259 steder som b?r g? raskest mulig. Rutina sjekker verdien av
 260 I<${main::Debug}>, hvis den er 0, returnerer den med en gang.
 261
 262 B<FIXME:> Mer pod seinere.
 263
 264 =cut
 265
 266 sub deb_pr {
 267         return unless ${main::Debug};
 268         my $Msg = shift;
 269         my $err_msg = "";
 270         if (-e ${main::debug_file}) {
 271                 $err_msg = "Klarte ikke ? ?pne debugfila for lesing/skriving" unless open(DebugFP, "+<${main::debug_file}");
 272         } else {
 273                 $err_msg = "Klarte ikke ? lage debugfila" unless open(DebugFP, "+>${main::debug_file}");
 274         }
 275         unless(length($err_msg)) {
 276                 flock(DebugFP, LOCK_EX);
 277                 $err_msg = "Kan ikke seek'e til slutten av debugfila" unless seek(DebugFP, 0, 2);
 278         }
 279         if (length($err_msg)) {
 280                 print <<END;
 281 Content-type: text/html
 282
 283 ${DTD_HTML4STRICT}
 284 <html>
 285         <!-- ${rcs_id} -->
 286         <head>
 287                 <title>Intern feil i deb_pr()</title>
 288         </head>
 289         <body>
 290                 <h1>Intern feil i deb_pr()</h1>
 291                 <p>${err_msg}: <samp>$!</samp>
 292                 <p>Litt info:
 293                 <p>\${main::Debug} = "${main::Debug}"
 294                 <br>\${main::error_file} = "${main::error_file}"
 295         </body>
 296 </html>
 297 END
 298                 exit();
 299         }
 300         print(DebugFP "$$ $Msg\n");
 301         close(DebugFP);
 302 } # deb_pr()
 303
 304 ###########################################################################
 305
 306 =head2 &escape_dangeours_chars()
 307
 308 Brukes hvis man skal utf?re en systemkommando og man f?r med kommandolinja
 309 ? gj?re. Eksempel:
 310
 311         $cmd_line = &escape_dangerous_chars("$cmd_line");
 312         system("$cmd_line");
 313
 314 Tegn som kan rote til denne kommandoen f?r en backslash foran seg.
 315
 316 =cut
 317
 318 sub escape_dangerous_chars {
 319         my $string = shift;
 320
 321         $string =~ s/([;\\<>\*\|`&\$!#\(\)\[\]\{\}'"])/\\$1/g;
 322         return $string;
 323 } # escape_dangerous_chars()
 324
 325 ###########################################################################
 326
 327 =head2 &file_mdate()
 328
 329 Returnerer tidspunktet fila sist ble modifisert i sekunder siden
 330 S<1970-01-01 00:00:00 UTC>. Brukes hvis man skal skrive ting som "sist
 331 oppdatert da og da".
 332
 333 =cut
 334
 335 sub file_mdate {
 336         my($FileName) = @_;
 337         my(@TA);
 338         @StatArray = stat($FileName);
 339         return($StatArray[9]);
 340 } # file_mdate()
 341
 342 ###########################################################################
 343
 344 =head2 &get_cgivars()
 345
 346 Leser inn alle verdier sendt med GET eller POST requests og returnerer en
 347 hash med verdiene. Fungerer p? denne m?ten:
 348
 349         %Opt = &get_cgivars;
 350         my $Document = $Opt{doc};
 351         my $user_name = $Opt{username};
 352
 353 Alle verdiene ligger n? i de respektive variablene og kan (mis)brukes Vilt
 354 & UhemmetZ<>(tm).
 355
 356 Funksjonen leser b?de 'I<&>' (ampersand) og 'I<;>' (semikolon) som
 357 skilletegn i GET/POST, scripts b?r sende 'I<;>' s? det ikke blir kluss med
 358 entities. Eksempel:
 359
 360         index.cgi?doc=login;username=suttleif;pwd=hemmelig
 361
 362 B<FIXME:> Denne m? utvides litt med flere Content-type'er.
 363
 364 =cut
 365
 366 sub get_cgivars {
 367         local($in, %in);
 368         local($name, $value);
 369
 370         my $has_args = ($#ARGV > -1) ? $TRUE : $FALSE;
 371         if ($has_args) {
 372                 $in = $ARGV[0];
 373         } elsif (($ENV{'REQUEST_METHOD'} eq 'GET') ||
 374                  ($ENV{'REQUEST_METHOD'} eq 'HEAD')) {
 375                 $in = $ENV{'QUERY_STRING'};
 376         } elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
 377                 if ($ENV{'CONTENT_TYPE'} =~ m#^application/x-www-form-urlencoded$#i) {
 378                         length($ENV{'CONTENT_LENGTH'}) || &HTMLdie("Ingen Content-Length vedlagt POST-foresp&oslash;rselen.");
 379                         read(STDIN, $in, $ENV{'CONTENT_LENGTH'});
 380                 } else {
 381                         &HTMLdie("Usupportert Content-Type: \"$ENV{'CONTENT_TYPE'}\"");
 382                 }
 383         } else {
 384                 &HTMLdie("Programmet ble kalt med ukjent REQUEST_METHOD: \"$ENV{'REQUEST_METHOD'}\"");
 385         }
 386         foreach (split("[&;]", $in)) {
 387                 s/\+/ /g;
 388                 ($name, $value) = split('=', $_, 2);
 389                 $name =~ s/%(..)/chr(hex($1))/ge;
 390                 $value =~ s/%(..)/chr(hex($1))/ge;
 391                 $in{$name} .= "\0" if defined($in{$name});
 392                 $in{$name} .= $value;
 393                 &deb_pr(__LINE__ . ": get_cgivars(): $name = \"$value\"");
 394         }
 395         return %in;
 396 } # get_cgivars()
 397
 398 ###########################################################################
 399
 400 =head2 &get_counter()
 401
 402 Skriver ut verdien av en teller, angi filnavn. Fila skal inneholde et tall
 403 i standard ASCII-format.
 404
 405 =cut
 406
 407 # FIXME: Skal my TmpFP brukes?
 408 sub get_countervalue {
 409         my $counter_file = shift;
 410         my $counter_value = 0;
 411         &deb_pr(__LINE__ . ": get_countervalue(): ?pner $counter_file for lesing+flock");
 412         open(TmpFP, "<$counter_file") || (&HTMLwarn("$counter_file i get_counter(): Kan ikke ?pne fila for lesing: $!"), return(0));
 413         flock(TmpFP, LOCK_EX);
 414         $counter_value = <TmpFP>;
 415         chomp($counter_value);
 416         close(TmpFP);
 417         &deb_pr(__LINE__ . ": get_countervalue(): $counter_file: Fila er lukket, returnerer fra subrutina med \"$counter_value\"");
 418         return $counter_value;
 419 } # get_countervalue()
 420
 421 ###########################################################################
 422
 423 =head2 &HTMLdie()
 424
 425 Tilsvarer F<die()> i standard Perl, men sender HTML-output s? man ikke f?r
 426 Internal Server Error. Funksjonen tar to parametere, I<$Msg> som havner i
 427 E<lt>titleE<gt>E<lt>/titleE<gt> og E<lt>h1E<gt>E<lt>/h1E<gt>, og I<$Msg>
 428 som blir skrevet ut som beskjed.
 429
 430 Hvis hverken I<${main::$Utv}> eller I<${main::Debug}> er sann, skrives meldinga til
 431 I<${main::error_file}> og en standardmelding blir skrevet ut. Folk f?r ikke vite
 432 mer enn de har godt av.
 433
 434 =cut
 435
 436 sub HTMLdie {
 437         my($Msg,$Title) = @_;
 438         my $curr_utc = &curr_utc_time;
 439         my $msg_str;
 440
 441         &deb_pr(__LINE__ . ": HDIE: $Msg");
 442         $Title || ($Title = "Intern feil");
 443         if (!${main::Debug} && !${main::Utv}) {
 444                 $msg_str = "<p>En intern feil har oppst&aring;tt. Feilen er loggf&oslash;rt, og vil bli fikset snart.";
 445         } else {
 446                 chomp($msg_str = $Msg);
 447         }
 448         my $CharSet = $STD_CHARSET unless length($CharSet);
 449         print <<END;
 450 Content-type: text/html
 451
 452 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN"
 453 "http://www.w3.org/TR/REC-html40/strict.dtd">
 454
 455 <html lang="no">
 456         <!-- $rcs_id -->
 457         <!-- ${main::rcs_id} -->
 458         <head>
 459                 <title>$Title</title>
 460                 <style type="text/css">
 461                         body { background: white; color: black; }
 462                         a:link { color: blue; }
 463                         a:visited { color: maroon; }
 464                         a:active { color: fuchsia; }
 465                         b.krise { color: red; }
 466                         h1 { color: red; }
 467                 </style>
 468                 <meta http-equiv="Content-Type" content="text/html; charset=$CharSet">
 469                 <meta name="author" content="tritech\@tritech.no">
 470                 <meta name="copyright" content="&copy; Tritech A/S http://www.tritech.no">
 471                 <meta name="description" content="CGI error">
 472                 <meta name="date" content="$curr_utc">
 473                 <link rev="made" href="mailto:tritech\@tritech.no">
 474         </head>
 475         <body>
 476                 <h1>$Title</h1>
 477                 <blockquote>
 478                         $msg_str
 479                 </blockquote>
 480         </body>
 481 </html>
 482 END
 483         if (length(${main::error_file})) {
 484                 system("touch ${main::error_file}") unless (-e ${main::error_file});
 485                 open(ErrorFP, "+<${main::error_file}") or exit;
 486                 flock(ErrorFP, LOCK_EX);
 487                 seek(ErrorFP, 0, 2) or exit;
 488                 $Msg =~ s/\\/\\\\/g;
 489                 $Msg =~ s/\n/\\n/g;
 490                 $Msg =~ s/\t/\\t/g;
 491                 printf(ErrorFP "%s HDIE %s\n", &curr_utc_time, $Msg);
 492                 close(ErrorFP);
 493         }
 494         exit;
 495 } # HTMLdie()
 496
 497 ###########################################################################
 498
 499 =head2 &HTMLwarn()
 500
 501 En lightversjon av I<&HTMLdie()>, den skriver kun til
 502 I<${main::error_file}>. N?r det oppst?r feil, men ikke trenger ? rive ned
 503 hele systemet. Brukes til sm?ting som tellere som ikke virker og s?nn.
 504
 505 B<FIXME:> Muligens det burde v?rt lagt inn at ${main::WebMaster} fikk mail om
 506 hver gang ting g?r p? trynet.
 507
 508 =cut
 509
 510 sub HTMLwarn {
 511         local($Msg) = shift;
 512         my $curr_utc = &curr_utc_time;
 513
 514         &deb_pr(__LINE__ . ": WARN: $Msg");
 515         # Gj?r det s? stille og rolig som mulig.
 516         if (${main::Utv} || ${main::Debug}) {
 517                 &print_header("CGI warning");
 518                 &tab_print("<p><font size=\"+1\"><b>HTMLwarn(): $Msg</font></n>\n");
 519         }
 520         if (-e ${main::error_file}) {
 521                 open(ErrorFP, ">>${main::error_file}") or return;
 522         } else {
 523                 open(ErrorFP, ">${main::error_file}") or return;
 524         }
 525         $Msg =~ s/\\/\\\\/g;
 526         $Msg =~ s/\n/\\n/g;
 527         $Msg =~ s/\t/\\t/g;
 528         print(ErrorFP "$curr_utc WARN $Msg\n");
 529         close(ErrorFP);
 530 } # HTMLwarn()
 531
 532 ###########################################################################
 533
 534 =head2 &increase_counter()
 535
 536 ?ker telleren i en spesifisert fil med en. Fila skal inneholde et tall i
 537 ASCII-format. I tillegg lages en fil som heter F<{fil}.ip> som inneholder
 538 IP'en som brukeren er tilkoblet fra. Hvis IP'en er den samme som i fila,
 539 oppdateres ikke telleren.
 540
 541 =cut
 542
 543 # FIXME: my TmpFP?
 544 sub increase_counter {
 545         my $counter_file = shift;
 546         my $ip_file = "$counter_file.ip";
 547         my $user_ip = $ENV{REMOTE_ADDR};
 548         system("touch $counter_file") unless (-e $counter_file);
 549         system("touch $ip_file") unless (-e $ip_file);
 550         open(TmpFP, "+<$ip_file") || (&HTMLwarn("$ip_file i increase_counter(): Kan ikke ?pne fila for lesing og skriving: $!"), return(0));
 551         flock(TmpFP, LOCK_EX);
 552         $last_ip = <TmpFP>;
 553         chomp($last_ip);
 554         my $new_ip = ($last_ip eq $user_ip) ? $FALSE : $TRUE;
 555         if ($new_ip) {
 556                 seek(TmpFP, 0, 0) || (&HTMLwarn("$ip_file: Kan ikke g? til begynnelsen av fila: $!"), close(TmpFP), return(0));
 557                 print(TmpFP "$user_ip\n");
 558         }
 559         open(TmpFP, "+<$counter_file") || (&HTMLwarn("$counter_file i increase_counter(): Kan ikke ?pne fila for lesing og skriving: $!"), return(0));
 560         flock(TmpFP, LOCK_EX);
 561         my $counter_value = <TmpFP>;
 562         if ($new_ip) {
 563                 seek(TmpFP, 0, 0) || (&HTMLwarn("$counter_file: Kan ikke g? til begynnelsen av fila: $!"), close(TmpFP), return(0));
 564                 printf(TmpFP "%u\n", $counter_value+1) if ($user_ip ne $last_ip);
 565         }
 566         close(TmpFP);
 567         return($counter_value + ($new_ip ? 1 : 0));
 568 } # increase_counter()
 569
 570 ###########################################################################
 571
 572 =head2 &log_access()
 573
 574 Logger aksess til en fil. Filnavnet skal v?re uten extension, rutina tar seg av det. I tillegg
 575 ?ker den en teller i fila I<$Base.count> unntatt hvis parameter 2 != 0.
 576
 577 Forutsetter at I<${main::log_dir}> er definert. Hvis ikke, settes den til
 578 I<$STD_LOGDIR>.
 579
 580 B<FIXME:> Skriv mer her.
 581
 582 =cut
 583
 584 sub log_access {
 585         my ($Base, $no_counter) = @_;
 586         my $log_dir = length(${main::log_dir}) ? ${main::log_dir} : $STD_LOGDIR;
 587         my $File = "$log_dir/$Base.log";
 588         my $Countfile = "$log_dir/$Base.count";
 589         system("touch $File") unless (-e $File);
 590         open(LogFP, "+<$File") || (&HTMLwarn("$File: Can't open access log for read/write: $!"), return);
 591         flock(LogFP, LOCK_EX);
 592         seek(LogFP, 0, 2) || (&HTMLwarn("$Countfile: Can't seek to EOF: $!"), close(LogFP), return);
 593         my $Agent = $ENV{HTTP_USER_AGENT};
 594         $Agent =~ s/\n/\\n/g; # Vet aldri hva som kommer
 595         printf(LogFP "%u\t%s\t%s\t%s\t%s\n", time, $ENV{REMOTE_ADDR}, $ENV{REMOTE_HOST}, $ENV{HTTP_REFERER}, $Agent);
 596         close(LogFP);
 597         $this_counter = &increase_counter($Countfile) unless $no_counter;
 598 } # log_access()
 599
 600 ###########################################################################
 601
 602 =head2 &print_doc()
 603
 604 Leser inn et dokument og konverterer det til HTML. Dette blir en av de
 605 mest sentrale rutinene i en hjemmeside, i og med at det skal ta seg av
 606 HTML-output'en. Istedenfor ? fylle opp scriptene med HTML-koder, gj?res et
 607 kall til F<&print_doc()> som skriver ut sidene og genererer HTML.
 608
 609 Formatet p? fila best?r av to deler: Header og HTML. De f?rste linjene
 610 best?r av ting som tittel, keywords, html-versjon, evt. refresh og s?
 611 videre. Her har vi et eksempel p? en fil (Ingen space i begynnelsen p?
 612 hver linje, det er til ?re for F<pod> at det er s?nn):
 613
 614  title Velkommen til snaddersida
 615  keywords snadder, stilig, kanont?fft, extremt, tjobing
 616  htmlversion html4strict
 617  author jeg@er.snill.edu
 618
 619  <table width="<=docwidth>">
 620         <tr>
 621                 <td colspan="2" align="center">
 622                         Han d?ven sjteiki
 623                 </td>
 624         </tr>
 625         <tr>
 626                 <td>
 627                         S? t?fft dette var.
 628                 </td>
 629                 <td>
 630                         Nemlig. Mailadressen min er <=author>
 631                 </td>
 632         </tr>
 633  </table>
 634  <=footer>
 635
 636 Rutina tar to parametere:
 637
 638 =over 4
 639
 640 =item I<$file_name> (n?dvendig)
 641
 642 Fil som skal skrives ut. Denne har som standard extension F<*.shtml> .
 643
 644 =item I<$page_num> (valgfri)
 645
 646 Denne brukes hvis det er en "kjede" med dokumenter, og det skal lages en
 647 "framover" og "bakover"-button.
 648
 649 Alt F<&print_footer()> gj?r, er ? lete opp plassen i fila som ting skal
 650 skrives ut fra. Grunnen til dette er at et dokument kan inneholde flere
 651 dokumenter som separeres med E<lt>=pageE<gt>.
 652
 653 =back
 654
 655 B<FIXME:> Skriver mer p? denne seinere. Og gj?r greia ferdig. Support for
 656 <=page> m? legges inn.
 657
 658 Alt kan legges inn i en fil:
 659
 660         title Eksempel p? datafil
 661         lang no
 662         ext html
 663         cvsroot :pserver:bruker@host.no:/cvsroot
 664         ftp ftp://black.tritech.no
 665
 666         <=page index>
 667         <p>Bla bla bla
 668
 669         <=page support>
 670         <p>Supportpreik
 671
 672         <=page contact>
 673         <p>Kontaktpreik osv
 674
 675 =cut
 676
 677 sub print_doc {
 678         my ($file_name, $page_num) = @_;
 679         my $in_header = $TRUE;
 680
 681         open(FromFP, "<$file_name") || &HTMLdie("$file_name: Kan ikke ?pne fila for lesing: $!");
 682         LINE: while (<FromFP>) {
 683                 chomp;
 684                 next LINE if /^#\s/;
 685                 last unless length;
 686                 if (/^(\S+)\s+(.*)$/) {
 687                         $doc_val{$1} = $2;
 688                 } else {
 689                         &HTMLwarn("$file_name: Ugyldig headerinfo i linje $.: \"$_\"");
 690                 }
 691         }
 692         $doc_val{title} || &HTMLwarn("$file_name: Mangler title");
 693         $doc_val{owner} || &HTMLwarn("$file_name: Mangler owner");
 694         $doc_val{lang} || &HTMLwarn("$file_name: Mangler lang");
 695         $doc_val{id} || &HTMLwarn("$file_name: Mangler id");
 696         # $doc_val{} || &HTMLwarn("$file_name: Mangler ");
 697         if (${main::Debug}) {
 698                 &print_header("er i print_doc"); # debug
 699                 while (($act_name,$act_time) = each %doc_val) {
 700                         print("<br>\"$act_name\"\t\"$act_time\"\n");
 701                 }
 702         }
 703         # my ($DocTitle, $html_version, $Language, $user_background, $Refresh, $no_body, $Description, $Keywords, @StyleSheet) = @_;
 704         &print_header($doc_val{title}, "", $doc_val{lang}, $doc_val{background}, $doc_val{refresh}, $doc_val{no_body}, $doc_val{description}, $doc_val{keywords});
 705         while (<FromFP>) {
 706                 chomp;
 707                 &tab_print("$_\n");
 708         }
 709         print <<END;
 710         </body>
 711 </html>
 712 END
 713         close(FromFP);
 714 } # print_doc()
 715
 716 ###########################################################################
 717
 718 =head2 &print_footer()
 719
 720 Skriver ut en footer med en E<lt>hrE<gt> f?rst. Funksjonen tar disse
 721 parameterne:
 722
 723 =over 4
 724
 725 =item I<$footer_width>
 726
 727 Bredden p? footeren i pixels. Hvis den ikke er definert, brukes
 728 I<${main::doc_width}>. Og hvis den heller ikke er definert, brukes
 729 I<$STD_DOCWIDTH> som default.
 730
 731 =item I<$footer_align>
 732
 733 Kan v?re I<left>, I<center> eller I<right>. Brukes av E<lt>tableE<gt>.
 734 Hvis udefinert, brukes I<${main::doc_align}>. Hvis den ikke er definert,
 735 brukes I<$STD_DOCALIGN>.
 736
 737 =item I<$no_vh>
 738
 739 I<$FALSE> eller udefinert: Skriver I<Valid HTML>-logoen nederst i h?yre
 740 hj?rne. I<$TRUE>: Dropper den.
 741
 742 =item I<$no_end>
 743
 744 Tar ikke med E<lt>/bodyE<gt>E<lt>/htmlE<gt> p? slutten hvis I<$TRUE>.
 745
 746 =back
 747
 748 =cut
 749
 750 sub print_footer {
 751         my ($footer_width, $footer_align, $no_vh, $no_end) = @_;
 752
 753         &deb_pr(__LINE__ . ": G?r inn i print_footer(\"$footer_width\", \"$footer_align\", \"$no_vh\", \"$no_end\")");
 754         unless (length($footer_width)) {
 755                 $footer_width = length(${main::doc_width}) ? ${main::doc_width} : $STD_DOCWIDTH;
 756         }
 757         unless (length($footer_align)) {
 758                 $footer_align = length(${main::doc_align}) ? ${main::doc_align} : $STD_DOCALIGN;
 759         }
 760         $no_vh = $FALSE unless length($no_vh);
 761         $no_end = $FALSE unless length($no_end);
 762         my $rcs_str = ${main::rcs_date}; # FIXME: Er ikke n?dvendigvis denne som skal brukes.
 763         $rcs_str =~ s/ /&nbsp;/g;
 764         my $vh_str = $no_vh ? "&nbsp;" : "<a href=\"http://validator.w3.org/check/referer;ss\"><img src=\"${main::GrafDir}/vh40.gif\" height=\"31\" width=\"88\" align=\"right\" border=\"0\" alt=\"Valid HTML 4.0!\"></a>";
 765         my $count_str = length($this_counter) ? "Du er bes&oslash;kende nummer $this_counter p&aring; denne siden." : "&nbsp;";
 766
 767         # FIXME: Hardkoding av URL her pga av at ${main::Url} har skifta navn.
 768         # FIXME: I resten av HTML'en er det brukt <div align="center">.
 769         &tab_print(<<END);
 770 <table width="$footer_width" cellpadding="0" cellspacing="0" border="${main::Border}" align="$footer_align">
 771         <tr>
 772                 <td colspan="3">
 773                         <hr>
 774                 </td>
 775         </tr>
 776         <tr>
 777                 <td align="center">
 778                         <table cellpadding="0" cellspacing="0" border="${main::Border}">
 779                                 <tr>
 780                                         <td align="center">
 781                                                 ${main::FONTB}<small>&copy;&nbsp;<a href="http://www.tritech.no" target="_top">TriTech&nbsp;AS</a>&nbsp;&lt;<code><a href="http://www.tritech.no/index.cgi?doc=kontakt">tritech\@tritech.no</a></code>&gt;</small>${main::FONTE}
 782                                         </td>
 783                                 </tr>
 784                                 <tr>
 785                                         <td align="center">
 786                                                 ${main::FONTB}<small>$rcs_str</small>${main::FONTE}
 787                                         </td>
 788                                 </tr>
 789                         </table>
 790                 </td>
 791                 <td width="100%" align="center">
 792                         $count_str
 793                 </td>
 794                 <td align="right">
 795                         $vh_str
 796                 </td>
 797         </tr>
 798 </table>
 799 END
 800         unless ($no_end) {
 801                 &Tabs(-2);
 802                 &tab_print(<<END);
 803         </body>
 804 </html>
 805 END
 806         }
 807         exit; # FIXME: Sikker p? det?
 808 } # print_footer()
 809
 810 ###########################################################################
 811
 812 =head2 &print_header()
 813
 814 Lager en HTML4-header i henhold til W3C's anbefaling. Den tar disse
 815 parameterne:
 816
 817 =over 4
 818
 819 =item I<$DocTitle>
 820
 821 Det som skal inn i E<lt>titleE<gt>E<lt>/titleE<gt>
 822
 823 =item I<$html_version>
 824
 825 Hvilken DTD som skal brukes i begynnelsen. Bruker I<$DTD_HTML4STRICT> som
 826 default, alts?
 827
 828 S<E<lt>!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
 829 S<"httpZ<>://www.w3.org/TR/REC-html40/loose.dtd"E<gt>>
 830
 831 =item I<$Language>
 832
 833 Landskode p? to bokstaver som havner i E<lt>html langE<gt>. Standardverdi
 834 er "no", det vil si
 835
 836         <html lang="no">
 837
 838 =item I<$user_background>
 839
 840 Bakgrunn som skal brukes. Det er i utgangspunktet en farge (engelsk
 841 fargenavn eller RGB-format "#ffffff"), men hvis extension er lik
 842 .(jpg|jpeg|gif|png) er det et bilde.
 843
 844 =item I<$Refresh>
 845
 846 Antall sekunder mellom hver refresh. Standard I<meta http-equiv> refresh.
 847
 848 =item I<$no_body>
 849
 850 Hvis denne er !I<$FALSE>, skrives ikke E<lt>bodyE<gt> ut. Praktisk hvis
 851 det er merkelig E<lt>bodyE<gt> som skal brukes, eller hvis det skal legges
 852 inn noen javascript-greier der.
 853
 854 =item I<$Description>
 855
 856 Det som skal st? i beskrivelsen i E<lt>metaE<gt>-bestyret.
 857
 858 =item I<$Keywords>
 859
 860 Keywords i E<lt>metaE<gt>. Skal v?re kommaseparert og med etities.
 861
 862 =item I<@StyleSheet>
 863
 864 Array med alt som skal inn style sheets. B<FIXME:> Stygg sak dette her at
 865 den m? v?re p? slutten av parametrene, skulle v?rt en bedre m?te s? den
 866 kan bli sendt som ETT parameter, men det ser vi p? seinere. Er vel ikke s?
 867 n?ye enda. Eventuelt slenger vi koden inn som en streng og ikke som en
 868 array.
 869
 870 BTW blir vel ikke parameterne brukt s? mye til hverdags, hvis
 871 F<&print_doc()> blir ferdig rimelig fort. Der skal som kjent alt
 872 spesifiseres.
 873
 874 B<FIXME:> Det hadde gjort seg med tidligere HTML-versjoner ogs?.
 875
 876 =back
 877
 878 =cut
 879
 880 sub print_header {
 881         my ($DocTitle, $html_version, $Language, $user_background, $Refresh, $no_body, $Description, $Keywords, @StyleSheet) = @_;
 882         my $DocumentTime = &curr_utc_time();
 883         my $BodyStr = "<body>";
 884         my $BackgroundStr;
 885         my $RefreshStr = $Refresh ? "<meta http-equiv=\"refresh\" content=\"$Refresh\" url=\"${main::Url}\">\n\t\t" : "";
 886         my $KeywStr = length($Keywords) ? "<meta name=\"keywords\" content=\"$Keywords\">\n\t\t" : "";
 887         my $CharSet = $STD_CHARSET unless length($CharSet);
 888         my $html_str = sprintf("<html%s>", length($Language) ? " lang=\"$Language\"" : "");
 889         my $DocId_str = length($doc_val{id}) ? <<END : "";
 890         <!-- $doc_val{id} -->
 891 END
 892         if ($header_done) {
 893                 &deb_pr(__LINE__ . ": Yo! print_header() ble kj?rt selv om \$header_done = $header_done. \$DocTitle = \"$DocTitle\"");
 894                 print("\n<!-- debug: print_header(\"$DocTitle\", \"$Refresh\", \"$no_body\", \"$html_version\") selv om \$header_done -->\n");
 895                 return;
 896         } else {
 897                 $header_done = 1;
 898         }
 899         &deb_pr(__LINE__ . ": print_header(): $DocTitle");
 900         unless (length($user_background)) {
 901                 $user_background = length(${main::BackGround}) ? ${main::BackGround} : $STD_BACKGROUND;
 902         }
 903         if (length($user_background)) {
 904                 if ($user_background =~ /\.(jpg|jpeg|gif|png)$/i) {
 905                         $BodyStr = "<body background=\"$user_background\">";
 906                         $BackgroundStr = "";
 907                 } else {
 908                         $BackgroundStr = $user_background;
 909                         $BodyStr = "<body bgcolor=\"$BackgroundStr\">";
 910                 }
 911         } else {
 912                 $BodyStr = "<body>";
 913                 $BackgroundStr = $STD_BACKGROUND;
 914         }
 915         # FIXME: Blir dette brukt til noe fornuftig en gang i tida?
 916         # if (!length($user_background)) {
 917                 # $BackGroundStr = length(if()) {
 918                         # $BackgroundStr = ${main::BackGround};
 919                         # $BodyStr = "<body>";
 920                 # } else {
 921                         # $BackgroundStr = $STD_BACKGROUND;
 922                         # $BodyStr = "<body>";
 923                 # }
 924         # }
 925         &content_type("text/html");
 926         print length($html_version) ? $html_version : $STD_HTMLDTD;
 927         print <<END;
 928
 929 $html_str
 930 $DocId_str      <!-- ${main::rcs_id} -->
 931         <!-- $rcs_id -->
 932 END
 933         &Tabs(2); # html og head
 934
 935         # FIXME: Midlertidig here'ing, det kan gj?res mye g?yere. Tar ikke hensyn til $Tabs heller, men det kommer.
 936         print <<END;
 937         <head>
 938                 <title>$DocTitle</title>
 939                 <meta http-equiv="Content-Type" content="text/html; charset=$CharSet">
 940                 $RefreshStr<meta name="author" content="tritech\@tritech.no">
 941                 $KeywStr<meta name="copyright" content="&copy; TriTech A/S &lt;http://www.tritech.no&gt;">
 942                 <meta name="description" content="$Description">
 943                 <meta name="date" content="$DocumentTime">
 944                 <link rev="made" href="mailto:${main::WebMaster}">
 945 END
 946
 947         print "\t\t<style type=\"text/css\">\n" if scalar @StyleSheet;
 948         &Tabs(1);
 949         foreach (@StyleSheet) {
 950                 printf("%s%s\n", $Tabs, $_);
 951         }
 952         print "\t\t</style>\n" if scalar @StyleSheet;
 953         &Tabs(-2); # style og head
 954         print("$Tabs</head>\n");
 955         unless ($no_body) {
 956                 print("$Tabs$BodyStr\n")
 957                 &Tabs(1);
 958         }
 959 } # print_header()
 960
 961 ###########################################################################
 962
 963 =head2 &tab_print()
 964
 965 Skriver ut p? samme m?te som print, men setter inn I<$Tabs> f?rst p?
 966 hver linje. Det er for ? f? riktige innrykk. Det forutsetter at
 967 I<$Tabs> er oppdatert til enhver tid.
 968
 969 B<FIXME:> Legg inn konvertering av tegn > 0x7f til entities.
 970
 971 =cut
 972
 973 sub tab_print {
 974         my @Txt = @_;
 975
 976         foreach (@Txt) {
 977                 s/^(.*)/${Tabs}$1/gm;
 978                 s/([\x7f-\xff])/sprintf("&#%u;", ord($1))/ge;
 979                 print "$_";
 980         }
 981 } # tab_print()
 982
 983 ###########################################################################
 984
 985 =head2 &tab_str()
 986
 987 Fungerer p? samme m?te som I<&tab_print()>, men returnerer en streng med
 988 innholdet istedenfor ? skrive det ut. Mulignes det burde v?rt implementert
 989 i I<&tab_print()> p? en eller annen m?te, men blir ikke det tungvint?
 990
 991 Vi lar det v?re s?nn forel?pig.
 992
 993 B<FIXME:> Legg inn konvertering av tegn > 0x7f til entities her ogs?.
 994
 995 =cut
 996
 997 sub tab_str {
 998         my @Txt = @_;
 999         my $RetVal = "";
1000
1001         foreach (@Txt) {
1002                 s/^(.*)/${Tabs}$1/gm;
1003                 $RetVal .= "$_";
1004         }
1005         return $RetVal;
1006 } # tab_str()
1007
1008 ###########################################################################
1009
1010 =head2 &Tabs()
1011
1012 ?ker/minsker verdien av I<${tricgi::Tabs}>. Den kan ta ett parameter, en
1013 verdi som er negativ eller positiv alt ettersom man skal fjerne eller
1014 legge til TAB'er. Hvis man skriver
1015
1016         &Tabs(-2);
1017
1018 fjernes to spacer, hvis man skriver
1019
1020         &Tabs(5);
1021
1022 legges 5 TAB'er til. Hvis ingen parametere spesifiseres, brukes 1 som
1023 default, alts? en TAB legges til.
1024
1025 =cut
1026
1027 sub Tabs {
1028         my $Value = shift;
1029
1030         # FIXME: Finpussing seinere.
1031         if ($Value > 0) {
1032                 for (1..$Value) {
1033                         $Tabs =~ s/(.*)/$1\t/;
1034                 }
1035         } elsif ($Value < 0) {
1036                 $Value = 0 - $Value;
1037                 for (1..$Value) {
1038                         $Tabs =~ s/^(.*)\t/$1/;
1039                 }
1040         } else {
1041                 &HTMLwarn("Intern feil: Tabs() ble kalt med \$Value = 0");
1042         }
1043 } # Tabs()
1044
1045 ###########################################################################
1046
1047 =head1 BUGS
1048
1049 Strukturen er ikke helt klar enda, det blir nok mange forandringer
1050 underveis.
1051
1052 Tror ikke tellerfunksjonene er helt i rute.
1053
1054 =cut
1055
1056 1;
1057
1058 __END__
1059
1060 #### End of file $Id: tricgi.pm,v 1.12 1999/07/05 13:33:59 sunny Exp $ ####