Lib/perllib/suncgi.pm

   1 package suncgi;
   2
   3 #=========================================================
   4 # $Id$
   5 # Standardrutiner for cgi-bin-programmering.
   6 # Dokumentasjon ligger som pod på slutten av fila.
   7 # (C)opyright 1999–2004 Øyvind A. Holm <sunny@sunbase.org>
   8 # Lisens: GNU General Public License ♥
   9 #=========================================================
  10
  11 require Exporter;
  12 @ISA = qw(Exporter);
  13
  14 # @EXPORT {{{
  15 @EXPORT = qw{
  16         %Opt %Cookie
  17         @cookies_done
  18         get_cookie set_cookie delete_cookie split_cookie
  19         content_type create_file curr_local_time curr_utc_time D deb_pr
  20         escape_dangerous_chars file_mdate get_cgivars get_countervalue HTMLdie
  21         HTMLwarn HTMLerror inc_counter increase_counter log_access print_header p_footer tab_print tab_str
  22         Tabs url_encode print_doc sec_to_string
  23         h_print utf8_print utf8_to_entity conv_print widechar
  24
  25         $has_args $query_string
  26         $log_requests $ignore_double_ip
  27         $curr_utc $CharSet $Tabs $Border $Footer $WebMaster $base_url $Url
  28         $css_default
  29         $doc_lang $doc_align $doc_width
  30         $debug_file $error_file $log_dir $Method $request_log_file $emptyrequest_log_file
  31         $DTD_HTML4FRAMESET $DTD_HTML4LOOSE $DTD_HTML4STRICT
  32 };
  33 # }}}
  34
  35 @EXPORT_OK = qw{
  36         print_footer
  37 };
  38 # %EXPORT_TAGS = tag => [...];  # define names for sets of symbols
  39
  40 use Fcntl ':flock';
  41 use strict;
  42
  43 $suncgi::Tabs = "";
  44 $suncgi::curr_utc = time;
  45 $suncgi::log_requests = 0; # 1 = Logg alle POST og GET, 0 = Drit i det
  46 $suncgi::ignore_double_ip = 0; # 1 = Skipper flere etterfølgende besøk fra samme IP, 0 = Nøye då
  47
  48 $suncgi::rcs_id = '$Id$';
  49 push(@main::rcs_array, $suncgi::rcs_id);
  50
  51 $suncgi::this_counter = "";
  52
  53 $suncgi::DTD_HTML4FRAMESET = qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">\n};
  54 $suncgi::DTD_HTML4LOOSE = qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">\n};
  55 $suncgi::DTD_HTML4STRICT = qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">\n};
  56
  57 $suncgi::STD_LANG = "no";
  58 $suncgi::STD_BACKGROUND = "";
  59 $suncgi::STD_CHARSET = "ISO-8859-1"; # Hvis $suncgi::CharSet ikke er definert. Latin1 foreløpig, men bare vent. Snart kommer UTF-8 og tar deg, og d̲a̲... Say no more. Vi må bare vente litt til h_print() er lagt inn diverse steder.
  60 $suncgi::STD_DOCALIGN = "left"; # Standard align for dokumentet hvis align ikke er spesifisert
  61 $suncgi::STD_DOCWIDTH = '95%'; # Hvis ikke $suncgi::doc_width er spesifisert
  62 $suncgi::STD_HTMLDTD = $suncgi::DTD_HTML4LOOSE;
  63
  64 $suncgi::CharSet = $suncgi::STD_CHARSET;
  65 $suncgi::css_default = "";
  66 $suncgi::doc_width = $suncgi::STD_DOCWIDTH;
  67 $suncgi::doc_align = $suncgi::STD_DOCALIGN;
  68 $suncgi::doc_lang = $suncgi::STD_LANG;
  69 $suncgi::Border = 0;
  70 $suncgi::Method = "post";
  71
  72 $suncgi::Footer = <<END;
  73         </body>
  74 </html>
  75 END
  76
  77 #### Subrutiner ####
  78
  79 sub content_type {
  80         # {{{
  81         my $ContType = shift;
  82         my $loc_charset;
  83         if (length($suncgi::CharSet)) {
  84                 $loc_charset = $suncgi::CharSet;
  85         } else {
  86                 $loc_charset = $suncgi::STD_CHARSET;
  87                 HTMLwarn("content_type(): \$suncgi::CharSet udefinert. Bruker \"$loc_charset\".");
  88         }
  89         if (length($ContType)) {
  90                 print("Content-Type: $ContType; charset=$loc_charset\n\n");
  91         } else {
  92                 HTMLwarn("Intern feil: \$ContType ble ikke spesifisert til content_type()");
  93         }
  94         # print "Content-Type: $ContType\n\n"; # Til ære for slappe servere som ikke har peiling
  95         # }}}
  96 } # content_type()
  97
  98 sub curr_local_time {
  99         # {{{
 100         my @TA = localtime();
 101         # my $GM = mktime(gmtime());
 102         # my $LO = localtime();
 103         # my $utc_diff = ($GM-$LO)/3600;
 104
 105         # - # &deb_pr("curr_local_time(): gmtime = \"$GM\", localtime = \"$LO\"");
 106         my $LocalTime = sprintf("%04u-%02u-%02uT%02u:%02u:%02u", $TA[5]+1900, $TA[4]+1, $TA[3], $TA[2], $TA[1], $TA[0]);
 107         # &deb_pr("curr_local_time(): Returnerer \"$LocalTime\"");
 108         return($LocalTime);
 109         # }}}
 110 } # curr_local_time()
 111
 112 sub create_file {
 113         # {{{
 114         my $file_name = shift;
 115         local *LocFP;
 116         return if (-e $file_name);
 117         open(LocFP, ">$file_name") || HTMLdie("create_file(): $file_name: Klarte ikke å lage fila: $!");
 118         close(LocFP);
 119         # }}}
 120 } # create_file()
 121
 122 sub curr_utc_time {
 123         # {{{
 124         my @TA = gmtime(time);
 125         my $UtcTime = sprintf("%04u-%02u-%02uT%02u:%02u:%02uZ", $TA[5]+1900, $TA[4]+1, $TA[3], $TA[2], $TA[1], $TA[0]);
 126         # &deb_pr("curr_utc_time(): Returnerer \"$UtcTime\"");
 127         return($UtcTime);
 128         # }}}
 129 } # curr_utc_time()
 130
 131 sub D {
 132         # {{{
 133         return unless $main::Debug;
 134         my $Msg = shift;
 135         my @call_info = caller;
 136         $Msg =~ s/^(.*?)\s+$/$1/;
 137         my $err_msg = "";
 138         if (-e $suncgi::debug_file) {
 139                 open(DebugFP, "+<$suncgi::debug_file") || ($err_msg = "Klarte ikke å åpne debugfila for lesing/skriving");
 140         } else {
 141                 open(DebugFP, ">$suncgi::debug_file") || ($err_msg = "Klarte ikke å lage debugfila");
 142         }
 143         unless(length($err_msg)) {
 144                 flock(DebugFP, LOCK_EX);
 145                 seek(DebugFP, 0, 2) || ($err_msg = "Kan ikke seek’e til slutten av debugfila");
 146         }
 147         if (length($err_msg)) {
 148                 print(<<END);
 149 Content-type: text/html
 150
 151 $suncgi::DTD_HTML4STRICT
 152 <html>
 153         <!-- $suncgi::rcs_id -->
 154         <head>
 155                 <title>Intern feil i D()</title>
 156         </head>
 157         <body>
 158                 <h1>Intern feil i D()</h1>
 159                 <p>${err_msg}: <samp>$!</samp>
 160                 <p>Litt info:
 161                 <p>\$main::Debug = "$main::Debug"
 162                 <br>\${suncgi::debug_file} = "${suncgi::debug_file}"
 163                 <br>\${suncgi::error_file} = "${suncgi::error_file}"
 164         </body>
 165 </html>
 166 END
 167                 exit();
 168         }
 169         my $deb_time = time;
 170         my $Fil = $call_info[1];
 171         $Fil =~ s#\\#/#g;
 172         $Fil =~ s#^.*/(.*?)$#$1#;
 173         print(DebugFP "$deb_time $Fil:$call_info[2] $$ $Msg\n");
 174         close(DebugFP);
 175         # }}}
 176 } # D()
 177
 178 sub deb_pr {
 179         # {{{
 180         return unless $main::Debug;
 181         my $Msg = shift;
 182         my @call_info = caller;
 183         $Msg =~ s/^(.*?)\s+$/$1/;
 184         my $deb_time = curr_utc_time();
 185         my $Fil = $call_info[1];
 186         $Fil =~ s#\\#/#g;
 187         $Fil =~ s#^.*/(.*?)$#$1#;
 188         my $warn_str = "$deb_time $$ $Fil:$call_info[2] $Msg\n";
 189         my $err_msg = "";
 190         if (-e $suncgi::debug_file) {
 191                 open(DebugFP, "+<$suncgi::debug_file") || ($err_msg = "Klarte ikke å åpne debugfila for lesing/skriving");
 192         } else {
 193                 open(DebugFP, ">$suncgi::debug_file") || ($err_msg = "Klarte ikke å lage debugfila");
 194         }
 195         unless(length($err_msg)) {
 196                 flock(DebugFP, LOCK_EX);
 197                 seek(DebugFP, 0, 2) || ($err_msg = "Kan ikke seek’e til slutten av debugfila");
 198         }
 199         if (length($err_msg)) {
 200                 print <<END;
 201 Content-type: text/html
 202
 203 $suncgi::DTD_HTML4STRICT
 204 <html>
 205         <!-- $suncgi::rcs_id -->
 206         <head>
 207                 <title>Intern feil i deb_pr()</title>
 208         </head>
 209         <body>
 210                 <h1>Intern feil i deb_pr()</h1>
 211                 <p>${err_msg}: <samp>$!</samp>
 212                 <p>Litt info:
 213                 <p>\$main::Debug = "$main::Debug"
 214                 <br>\${suncgi::debug_file} = "${suncgi::debug_file}"
 215                 <br>\${suncgi::error_file} = "${suncgi::error_file}"
 216                 <br>\$warn_str = "$warn_str"
 217         </body>
 218 </html>
 219 END
 220                 exit();
 221         }
 222         print(DebugFP $warn_str);
 223         # print("$warn_str<br>\n");
 224         close(DebugFP);
 225         # }}}
 226 } # deb_pr()
 227
 228 sub escape_dangerous_chars {
 229         # {{{
 230         my $string = shift;
 231
 232         $string =~ s/([;\\<>\*\|`&\$!#\(\)\[\]\{\}'"])/\\$1/g;
 233         return $string;
 234         # }}}
 235 } # escape_dangerous_chars()
 236
 237 sub file_mdate {
 238         # {{{
 239         my($FileName) = @_;
 240         my(@TA);
 241         my @StatArray = stat($FileName);
 242         return($StatArray[9]);
 243         # }}}
 244 } # file_mdate()
 245
 246 sub get_cgivars {
 247         # {{{
 248         my ($in, %in);
 249         my ($name, $value) = ("", "");
 250         $in = "";
 251         # FIXME: Noe byr meg imot her...
 252         foreach my $var_name ('HTTP_USER_AGENT', 'REMOTE_ADDR', 'REMOTE_HOST', 'HTTP_REFERER', 'CONTENT_TYPE', 'CONTENT_LENGTH', 'QUERY_STRING') {
 253                 defined($ENV{$var_name}) || ($ENV{$var_name} = "");
 254         }
 255         my $user_method = defined($ENV{REQUEST_METHOD}) ? $ENV{REQUEST_METHOD} : "";
 256         # length($user_method) || ($user_method = "");
 257
 258         # length($ENV{REQUEST_METHOD}) ||
 259         $suncgi::has_args = ($#ARGV > -1) ? 1 : 0;
 260         if ($suncgi::has_args) {
 261                 $in = $ARGV[0];
 262         } elsif (($user_method =~ /^get$/i) ||
 263                  ($user_method =~ /^head$/i)) {
 264                 $in = $ENV{QUERY_STRING};
 265         } elsif ($user_method =~ /^post$/i) {
 266                 if ($ENV{CONTENT_TYPE} =~ m#^(application/x-www-form-urlencoded|text/xml)$#i) {
 267                         length($ENV{CONTENT_LENGTH}) || HTMLdie("Ingen Content-Length vedlagt POST-forespørselen.");
 268                         my $Len = $ENV{CONTENT_LENGTH};
 269                         read(STDIN, $in, $Len) || HTMLwarn("get_cgivars(): Feil under read() fra STDIN: $!");
 270                 } else {
 271                         HTMLdie("Usupportert Content-Type: \"$ENV{CONTENT_TYPE}\"") if length($ENV{CONTENT_TYPE});
 272                         exit;
 273                 }
 274         } else {
 275                 if (length($user_method)) {
 276                         HTMLdie("Programmet ble kalt med ukjent REQUEST_METHOD: \"$user_method\"");
 277                         exit;
 278                 }
 279         }
 280         defined($suncgi::request_log_file) || ($suncgi::request_log_file = "");
 281         defined($suncgi::emptyrequest_log_file) || ($suncgi::emptyrequest_log_file = "");
 282         if (length($suncgi::request_log_file) && $suncgi::log_requests) {
 283                 local *ReqFP;
 284                 my $loc_in = $in;
 285                 unless (length($suncgi::emptyrequest_log_file)) { # For bakoverkompatibilitet før suncgi.pm,v 1.29
 286                         $suncgi::emptyrequest_log_file = "$suncgi::request_log_file.empty";
 287                 }
 288                 my $file_name = length($in) ? $suncgi::request_log_file : "$suncgi::emptyrequest_log_file";
 289                 if (-e $file_name) {
 290                         open(ReqFP, "+<$file_name") || HTMLdie("$file_name: Klarte ikke å åpne loggfila for r+w: $!");
 291                 } else {
 292                         open(ReqFP, ">$file_name") || HTMLdie("$file_name: Klarte ikke å lage loggfila: $!");
 293                 }
 294                 flock(ReqFP, LOCK_EX);
 295                 seek(ReqFP, 0, 2) || HTMLdie("$file_name: Klarte ikke å seeke til slutten: $!");
 296                 print(ReqFP "$suncgi::curr_utc\t$ENV{REMOTE_ADDR}\t$in\n") || HTMLwarn("$file_name: Klarte ikke å skrive til loggfila: $!");
 297                 close(ReqFP);
 298         }
 299         $suncgi::query_string = $in;
 300         foreach (split("[&;]", $in)) {
 301                 s/\+/ /g;
 302                 my ($name, $value) = ("", "");
 303                 ($name, $value) = split('=', $_, 2);
 304                 $name =~ s/%(..)/chr(hex($1))/ge;
 305                 $value =~ s/%(..)/chr(hex($1))/ge;
 306                 $in{$name} .= "\0" if defined($in{$name});
 307                 $in{$name} .= $value;
 308                 # Den under her er veldig grei å ha upåvirket av perldeboff(1).
 309                 deb_pr("get_cgivars(): $name = \"$value\"");
 310         }
 311         return %in;
 312         # }}}
 313 } # get_cgivars()
 314
 315 sub get_cookie {
 316         # {{{
 317         my $env_str = defined($ENV{'HTTP_COOKIE'}) ? $ENV{'HTTP_COOKIE'} : "";
 318         my ($chip, $val);
 319         foreach (split(/; /, $env_str)) {
 320                 # split cookie at each ; (cookie format is name=value; name=value; etc...)
 321                 # Convert plus to space (in case of encoding (not necessary, but recommended)
 322                 s/\+/ /g;
 323                 # Split into key and value.
 324                 my ($chip, $val) = ("", "");
 325                 ($chip, $val) = split(/=/,$_,2); # splits on the first =.
 326                 # Convert %XX from hex numbers to alphanumeric
 327                 $chip =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
 328                 $val =~ s/%([A-Fa-f0-9]{2})/pack("c",hex($1))/ge;
 329                 # Associate key and value
 330                 $suncgi::Cookie{$chip} .= "\1" if (defined($suncgi::Cookie{$chip})); # \1 is the multiple separator
 331                 $suncgi::Cookie{$chip} .= $val;
 332                 deb_pr("get_cookie(): $chip=$val");
 333         }
 334         # }}}
 335 } # get_cookie()
 336
 337 sub set_cookie {
 338         # {{{
 339         # $expires must be in unix time format, if defined. If not defined it sets the expiration to December 31, 1999.
 340         # If you want no expiration date set, set $expires = -1 (this causes the cookie to be deleted when user closes
 341         # his/her browser).
 342
 343         my ($expires, $domain, $path, $sec) = @_;
 344         my (@days) = ("Sun","Mon","Tue","Wed","Thu","Fri","Sat");
 345         my (@months) = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec");
 346         my ($seconds,$min,$hour,$mday,$mon,$year,$wday);
 347         if ($expires > 0) {
 348                 # get date info if expiration set.
 349                 ($seconds,$min,$hour,$mday,$mon,$year,$wday) = gmtime($expires);
 350                 $seconds = "0" . $seconds if $seconds < 10; # formatting of date variables
 351                 $min = "0" . $min if $min < 10;
 352                 $hour = "0" . $hour if $hour < 10;
 353         }
 354         my (@secure) = ("","secure"); # add security to the cookie if defined.  I’m not too sure how this works.
 355         if (!defined $expires) {
 356                 # if expiration not set, expire at 12/31/1999
 357                 $expires = " expires\=Fri, 31-Dec-1999 00:00:00 GMT;";
 358         } elsif ($expires == -1) {
 359                 # if expiration set to -1, then eliminate expiration of cookie.
 360                 $expires = "";
 361         } else {
 362                 $year += 1900;
 363                 $expires = "expires\=$days[$wday], $mday-$months[$mon]-$year $hour:$min:$seconds GMT; "; # form expiration from value passed to function.
 364         }
 365         if (!defined $domain) {
 366                 # set domain of cookie.  Default is current host.
 367                 $domain = $ENV{'SERVER_NAME'};
 368         }
 369         if (!defined $path) {
 370                 # set default path = "/"
 371                 $path = "/";
 372         }
 373         (!defined($sec) || !length($sec)) || ($sec = "0");
 374         while (my ($Key, $Value) = each %suncgi::Cookie) {
 375                 defined($Value) || ($Value = "");
 376                 $Value =~ s/ /+/g; #convert plus to space.
 377                 defined($sec) || ($sec = 0);
 378                 my $cookie_str = "Set-Cookie: $Key\=$Value; $expires path\=$path; domain\=$domain; $secure[$sec]\n";
 379                 deb_pr($cookie_str);
 380                 print($cookie_str);
 381                 push(@suncgi::cookies_done, $cookie_str);
 382                 undef $suncgi::Cookie{key};
 383                 # print cookie to browser,
 384                 # this must be done b̲e̲f̲o̲r̲e̲ you print any content type headers.
 385         }
 386         undef %suncgi::Cookie;
 387         # }}}
 388 } # set_cookie()
 389
 390 sub delete_cookie {
 391         # {{{
 392         # To delete a cookie, simply pass delete_cookie the name of the cookie to delete.
 393         # You may pass delete_cookie more than 1 name at a time.
 394         my (@to_delete) = @_;
 395         my ($name);
 396         foreach $name (@to_delete) {
 397                 undef $suncgi::Cookie{$name}; # Undefines cookie so if you call set_cookie, it doesn’t reset the cookie.
 398                 print("Set-Cookie: $name=; expires=Thu, 01-Jan-1970 00:00:00 GMT;\n");
 399                 # This also must be done before you print any content type headers.
 400         }
 401         # }}}
 402 } # delete_cookie()
 403
 404 sub split_cookie {
 405         # {{{
 406         # Splits a multi-valued parameter into a list of the constituent parameters
 407
 408         my ($param) = @_;
 409         my (@params) = split ("\1", $param);
 410         return (wantarray ? @params : $params[0]);
 411         # }}}
 412 } # split_cookie()
 413
 414 sub get_countervalue {
 415         # {{{
 416         my $counter_file = shift;
 417         my $counter_value = 0;
 418         local *TmpFP;
 419         # &deb_pr("get_countervalue(): Åpner $counter_file for lesing+flock");
 420         unless (-e $counter_file) {
 421                 open(TmpFP, ">$counter_file") || (HTMLwarn("$counter_file i get_countervalue(): Klarte ikke å lage fila: $!"), return(0));
 422                 flock(TmpFP, LOCK_EX);
 423                 print(TmpFP "0\n");
 424                 close(TmpFP);
 425         }
 426         open(TmpFP, "<$counter_file") || (HTMLwarn("$counter_file i get_countervalue(): Kan ikke åpne fila for lesing: $!"), return(0));
 427         flock(TmpFP, LOCK_EX);
 428         $counter_value = <TmpFP>;
 429         chomp($counter_value);
 430         close(TmpFP);
 431         # &deb_pr("get_countervalue(): $counter_file: Fila er lukket, returnerer fra subrutina med \"$counter_value\"");
 432         return $counter_value;
 433         # }}}
 434 } # get_countervalue()
 435
 436 sub HTMLdie {
 437         # {{{
 438         my($Msg,$Title) = @_;
 439         my $utc_str = curr_utc_time;
 440         my $msg_str = "";
 441
 442         deb_pr("HDIE: $Msg");
 443         $Title || ($Title = "Intern feil");
 444         if (!$main::Debug && !$main::Utv) {
 445                 $msg_str = "<p>En intern feil har oppst&aring;tt. Feilen er loggf&oslash;rt, og vil bli fikset snart.";
 446         } else {
 447                 chomp($msg_str = $Msg);
 448         }
 449         h_print(<<END);
 450 Content-type: text/html
 451
 452 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN" "http://www.w3.org/TR/REC-html40/strict.dtd">
 453
 454 <html lang="no">
 455         <!-- $suncgi::rcs_id -->
 456         <!-- $main::rcs_id -->
 457         <head>
 458                 <!-- \x7B\x7B\x7B -->
 459                 <title>$Title</title>
 460                 <style type="text/css">
 461                         <!--
 462                         body { background: white; color: black; font-family: sans-serif; }
 463                         a:link { color: blue; }
 464                         a:visited { color: maroon; }
 465                         a:active { color: fuchsia; }
 466                         b.krise { color: red; }
 467                         h1 { color: red; }
 468                         -->
 469                 </style>
 470                 <meta http-equiv="Content-Type" content="text/html; charset=$suncgi::CharSet">
 471 END
 472         h_print(<<END) if defined($suncgi::WebMaster);
 473                 <meta name="author" content="$suncgi::WebMaster">
 474 END
 475         h_print(<<END);
 476                 <meta name="copyright" content="&#169; &#216;yvind A. Holm">
 477                 <meta name="description" content="CGI error">
 478                 <meta name="date" content="$utc_str">
 479 END
 480         h_print(<<END) if defined($suncgi::WebMaster);
 481                 <link rev="made" href="mailto:$suncgi::WebMaster">
 482 END
 483         h_print(<<END);
 484                 <!-- \x7D\x7D\x7D -->
 485         </head>
 486         <body>
 487                 <h1>$Title</h1>
 488                 <blockquote>
 489                         $msg_str
 490                 </blockquote>
 491         </body>
 492 </html>
 493 END
 494         if (length(${suncgi::error_file})) {
 495                 unless (-e $suncgi::error_file) {
 496                         open(ErrorFP, ">$suncgi::error_file");
 497                         close(ErrorFP);
 498                 }
 499                 open(ErrorFP, "+<${suncgi::error_file}") or exit;
 500                 flock(ErrorFP, LOCK_EX);
 501                 seek(ErrorFP, 0, 2) or exit;
 502                 $Msg =~ s/\\/\\\\/g;
 503                 $Msg =~ s/\n/\\n/g;
 504                 $Msg =~ s/\t/\\t/g;
 505                 printf(ErrorFP "%s HDIE %s\n", $utc_str, $Msg);
 506                 close(ErrorFP);
 507         }
 508         exit;
 509         # }}}
 510 } # HTMLdie()
 511
 512 sub HTMLwarn {
 513         # {{{
 514         my $Msg = shift;
 515         my $utc_str = curr_utc_time();
 516         my @call_info = caller;
 517
 518         my $Fil = $call_info[1];
 519         $Fil =~ s#\\#/#g;
 520         $Fil =~ s#^.*/(.*?)$#$1#;
 521         $Msg =~ s/\\/\\\\/g;
 522         $Msg =~ s/\n/\\n/g;
 523         $Msg =~ s/\t/\\t/g;
 524         my $warn_str = "$utc_str $Fil:$call_info[2] WARN $Msg\n";
 525
 526         deb_pr($warn_str);
 527         # Gjør det så stille og rolig som mulig.
 528         if ($main::Utv || $main::Debug) {
 529                 print_header("CGI warning");
 530                 h_print("<p><b>HTMLwarn(): $warn_str</b>\n");
 531         }
 532         if (-e ${suncgi::error_file}) {
 533                 open(ErrorFP, ">>${suncgi::error_file}") or return;
 534         } else {
 535                 open(ErrorFP, ">${suncgi::error_file}") or return;
 536         }
 537         print(ErrorFP $warn_str);
 538         close(ErrorFP);
 539         # }}}
 540 } # HTMLwarn()
 541
 542 sub HTMLerror {
 543         # Skriver en melding til brukeren, er ment som en mer anonym HTMLdie(). Får se om det er en god ting å ha. {{{
 544         my $Txt = shift;
 545         print_header("Feil");
 546         h_print($Txt);
 547         exit;
 548         # }}}
 549 } # HTMLerror()
 550
 551 sub increase_counter {
 552         # Øker kun med 1 hvis IP’en er forskjellig fra forrige gang. Hvis parameter 2 er !0, øker den uanskvett. {{{
 553         my ($counter_file, $ignore_ip) = @_;
 554         my $last_ip = "";
 555         my @call_info = caller;
 556         HTMLwarn("suncgi::increase_counter() er avlegs. inc_counter() svinger. Kalt fra $call_info[1]:$call_info[2]") if $main::Debug;
 557         $ignore_ip = 0 unless defined($ignore_ip);
 558         my $ip_file = "$counter_file.ip";
 559         my $user_ip = $ENV{REMOTE_ADDR};
 560         local *TmpFP;
 561         create_file($counter_file);
 562         create_file($ip_file);
 563         open(TmpFP, "+<$ip_file") || (HTMLwarn("$ip_file i increase_counter(): Kan ikke åpne fila for lesing og skriving: $!"), return(0));
 564         flock(TmpFP, LOCK_EX);
 565         $last_ip = <TmpFP>;
 566         chomp($last_ip);
 567         my $new_ip = ($last_ip eq $user_ip) ? 0 : 1;
 568         $new_ip = 1 if ($ignore_ip || $suncgi::ignore_double_ip);
 569         if ($new_ip) {
 570                 seek(TmpFP, 0, 0) || (HTMLwarn("$ip_file: Kan ikke gå til begynnelsen av fila: $!"), close(TmpFP), return(0));
 571                 print(TmpFP "$user_ip\n");
 572         }
 573         open(TmpFP, "+<$counter_file") || (HTMLwarn("$counter_file i increase_counter(): Kan ikke åpne fila for lesing og skriving: $!"), return(0));
 574         flock(TmpFP, LOCK_EX);
 575         my $counter_value = <TmpFP>;
 576         if ($new_ip) {
 577                 seek(TmpFP, 0, 0) || (HTMLwarn("$counter_file: Kan ikke gå til begynnelsen av fila: $!"), close(TmpFP), return(0));
 578                 printf(TmpFP "%u\n", $counter_value+1);
 579         }
 580         close(TmpFP);
 581         return($counter_value + ($new_ip ? 1 : 0));
 582         # }}}
 583 } # increase_counter()
 584
 585 sub inc_counter {
 586         # {{{
 587         my ($counter_file, $Value) = @_;
 588         my $last_ip = "";
 589         $Value = 1 unless defined($Value);
 590         local *TmpFP;
 591         create_file($counter_file);
 592         open(TmpFP, "+<$counter_file") || (HTMLwarn("$counter_file i inc_counter(): Kan ikke åpne fila for lesing og skriving: $!"), return(0));
 593         flock(TmpFP, LOCK_EX);
 594         my $counter_value = <TmpFP>;
 595         seek(TmpFP, 0, 0) || (HTMLwarn("$counter_file: Kan ikke gå til begynnelsen av fila: $!"), close(TmpFP), return(0));
 596         $counter_value += $Value;
 597         print(TmpFP "$counter_value\n");
 598         close(TmpFP);
 599         return($counter_value);
 600         # }}}
 601 } # inc_counter()
 602
 603 sub log_access {
 604         # {{{
 605         my ($Base, $no_counter) = @_;
 606         my $log_dir = length(${suncgi::log_dir}) ? ${suncgi::log_dir} : $suncgi::STD_LOGDIR;
 607         my $File = "$log_dir/$Base.log";
 608         my $Countfile = "$log_dir/$Base.count";
 609         create_file($File);
 610         open(LogFP, "+<$File") || (HTMLwarn("$File: Can’t open access log for read/write: $!"), return);
 611         flock(LogFP, LOCK_EX);
 612         seek(LogFP, 0, 2) || (HTMLwarn("$Countfile: Can’t seek to EOF: $!"), close(LogFP), return);
 613         foreach my $var_name ('HTTP_USER_AGENT', 'REMOTE_ADDR', 'REMOTE_HOST', 'HTTP_REFERER') {
 614                 defined($ENV{$var_name}) || ($ENV{$var_name} = "");
 615         }
 616         my $Agent = $ENV{HTTP_USER_AGENT};
 617         $Agent =~ s/\n/\\n/g; # Vet aldri hva som kommer
 618         printf(LogFP "%u\t%s\t%s\t%s\t%s\n", time, $ENV{REMOTE_ADDR}, $ENV{REMOTE_HOST}, $ENV{HTTP_REFERER}, $Agent);
 619         close(LogFP);
 620         $suncgi::this_counter = inc_counter($Countfile, 1) unless $no_counter;
 621         # }}}
 622 } # log_access()
 623
 624 sub print_doc {
 625         # {{{
 626         my ($file_name, $page_num) = @_;
 627         my $in_header = 1;
 628         my %doc_val;
 629
 630         open(FromFP, "<$file_name") || HTMLdie("$file_name: Kan ikke åpne fila for lesing: $!");
 631         LINE: while (<FromFP>) {
 632                 chomp;
 633                 next LINE if /^#\s/;
 634                 last unless length;
 635                 if (/^(\S+)\s+(.*)$/) {
 636                         $doc_val{$1} = $2;
 637                 } else {
 638                         HTMLwarn("$file_name: Ugyldig headerinfo i linje $.: \"$_\"");
 639                 }
 640         }
 641         $doc_val{title} || HTMLwarn("$file_name: Mangler title");
 642         $doc_val{owner} || HTMLwarn("$file_name: Mangler owner");
 643         $doc_val{lang} || HTMLwarn("$file_name: Mangler lang");
 644         $doc_val{id} || HTMLwarn("$file_name: Mangler id");
 645         # $doc_val{} || HTMLwarn("$file_name: Mangler ");
 646         if ($main::Debug) {
 647                 print_header("er i print_doc"); # debug
 648                 while (my ($act_name,$act_time) = each %doc_val) {
 649                         h_print("<br>\"$act_name\"\t\"$act_time\"\n");
 650                 }
 651         }
 652         # my ($DocTitle, $html_version, $Language, $user_background, $Refresh, $no_body, $Description, $Keywords, @StyleSheet) = @_;
 653         print_header($doc_val{title}, "", $doc_val{lang}, $doc_val{background}, $doc_val{refresh}, $doc_val{no_body}, $doc_val{description}, $doc_val{keywords});
 654         while (<FromFP>) {
 655                 chomp;
 656                 h_print("$_\n");
 657         }
 658         h_print(<<END);
 659         </body>
 660 </html>
 661 END
 662         close(FromFP);
 663         # }}}
 664 } # print_doc()
 665
 666 sub p_footer {
 667         # {{{
 668         my $no_endhtml = shift;
 669         defined($no_endhtml) || ($no_endhtml = 0);
 670         my $Retval = "";
 671         my ($validator_str, $array_str) = ("&nbsp;", "");
 672         if ($main::Utv) {
 673                 my $query_enc = url_encode($suncgi::query_string);
 674                 my $url_enc = url_encode($suncgi::Url);
 675                 # FIXME: Hardkoding av URL
 676                 $validator_str = <<END;
 677                                         <a href="$suncgi::Url?$suncgi::query_string">URL</a>&nbsp;
 678                                         <a href="http://jigsaw.w3.org/css-validator/validator?uri=$url_enc%3F$query_enc"><img border="0" src="images/vcss.png" alt="[CSS-validator]" height="31" width="88"></a>
 679                                         <a href="http://validator.w3.org/check?uri=$url_enc%3F$query_enc;ss=1;outline=1"><img border="0" src="images/valid-html401.png" alt="[HTML-validator]" height="31" width="88"></a>
 680 END
 681                 $array_str .= <<END . join("\n$suncgi::Tabs<br>", @main::rcs_array) . <<END;
 682                         <tr>
 683                                 <td colspan="2" align="center">
 684                                         <table cellpadding="10" cellspacing="0" border="5">
 685                                                 <tr>
 686                                                         <td width="100%">
 687 END
 688
 689                                                         </td>
 690                                                 </tr>
 691                                         </table>
 692                                 </td>
 693                         </tr>
 694 END
 695         }
 696
 697         $Retval = <<END;
 698                 <table width="$suncgi::doc_width" cellpadding="0" cellspacing="0" border="$suncgi::Border">
 699                         <tr>
 700                                 <td colspan="2">
 701                                         <hr>
 702                                 </td>
 703                         </tr>
 704                         <tr>
 705                                 <td align="left">
 706                                         <small>&lt;<code><a href="mailto:$suncgi::WebMaster">$suncgi::WebMaster</a></code>&gt;
 707                                         <br>&#169; &#216;yvind A. Holm</small>
 708                                 </td>
 709                                 <td align="right" valign="middle">
 710 $validator_str
 711                                 </td>
 712                         </tr>
 713 $array_str
 714                 </table>
 715 END
 716         $Retval .= <<END unless ($no_endhtml);
 717         </body>
 718 </html>
 719 END
 720         return $Retval;
 721         # }}}
 722 } # p_footer()
 723
 724 sub print_footer {
 725         # {{{
 726         my ($footer_width, $footer_align, $no_vh, $no_end) = @_;
 727
 728         # &deb_pr("Går inn i print_footer(\"$footer_width\", \"$footer_align\", \"$no_vh\", \"$no_end\")");
 729         defined($footer_width) || ($footer_width = "");
 730         unless (length($footer_width)) {
 731                 $footer_width = length($suncgi::doc_width) ? $suncgi::doc_width : $suncgi::STD_DOCWIDTH;
 732         }
 733         unless (length($footer_align)) {
 734                 $footer_align = length($suncgi::doc_align) ? $suncgi::doc_align : $suncgi::STD_DOCALIGN;
 735         }
 736         $no_vh = 0 unless defined($no_vh);
 737         $no_end = 0 unless defined($no_end);
 738         my $rcs_str = ${main::rcs_date}; # FIXME: Er ikke nødvendigvis denne som skal brukes.
 739         $rcs_str =~ s/ /&nbsp;/g;
 740         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>";
 741         my $count_str = length($suncgi::this_counter) ? "Du er bes&oslash;kende nummer $suncgi::this_counter p&aring; denne siden." : "&nbsp;";
 742
 743         # FIXME: Hardkoding av URL her pga av at ${suncgi::Url} har skifta navn.
 744         # FIXME: I resten av HTML’en er det brukt <div align="center">.
 745         h_print(<<END);
 746 <table width="$footer_width" cellpadding="0" cellspacing="0" border="$suncgi::Border" align="$footer_align">
 747         <tr>
 748                 <td colspan="3">
 749                         <hr>
 750                 </td>
 751         </tr>
 752         <tr>
 753                 <td align="center">
 754                         <table cellpadding="0" cellspacing="0" border="$suncgi::Border">
 755                                 <tr>
 756                                         <td align="center">
 757                                                 <small>$rcs_str</small>
 758                                         </td>
 759                                 </tr>
 760                         </table>
 761                 </td>
 762                 <td width="100%" align="center">
 763                         $count_str
 764                 </td>
 765                 <td align="right">
 766                         $vh_str
 767                 </td>
 768         </tr>
 769 </table>
 770 END
 771         unless ($no_end) {
 772                 h_print(<<END);
 773         </body>
 774 </html>
 775 END
 776         }
 777         exit; # FIXME: Sikker på det?
 778         # }}}
 779 } # print_footer()
 780
 781 sub print_header {
 782         # {{{
 783         my ($DocTitle, $RefreshStr, $style_sheet, $head_script, $body_attr, $html_version, $head_lang, $no_body) = @_;
 784         # &deb_pr("Går inn i print_header(), \$DocTitle=\"$DocTitle\"");
 785         if ($suncgi::header_done) {
 786                 # &deb_pr(__LINE__ . "Yo! print_header() ble kjørt selv om \$suncgi::header_done = $suncgi::header_done");
 787                 h_print("\n<!-- debug: print_header($DocTitle) selv om \$suncgi::header_done -->\n");
 788                 return;
 789         } else {
 790                 $suncgi::header_done = 1;
 791         }
 792         # FIXME: Kanskje dette kan gjøres via referanser istedenfor.
 793         defined($DocTitle) || ($DocTitle = ""); # FIXME: Midlertidig
 794         defined($RefreshStr) || ($RefreshStr = "");
 795         defined($style_sheet) || ($style_sheet = "");
 796         defined($head_script) || ($head_script = "");
 797         defined($body_attr) || ($body_attr = "");
 798         defined($html_version) || ($html_version = $Suncgi::DTD_HTML4LOOSE);
 799         defined($head_lang) || ($head_lang = "");
 800         defined($no_body) || ($no_body = 0);
 801         $style_sheet = $suncgi::css_default unless length($style_sheet);
 802         $head_lang = $suncgi::STD_LANG unless length($head_lang);
 803         $html_version = $suncgi::DTD_HTML4LOOSE unless defined($html_version);
 804         $no_body = 0 unless length($no_body);
 805         my $DocumentTime = curr_utc_time();
 806         length($RefreshStr) && ($RefreshStr = qq{\t\t<meta http-equiv="refresh" content="$RefreshStr" url="$suncgi::Url">});
 807
 808         content_type("text/html");
 809         print($html_version);
 810         print("\n<html lang=\"$head_lang\">\n");
 811         $head_script = "" unless defined($head_script);
 812         if (@main::rcs_array) {
 813                 foreach(@main::rcs_array) {
 814                         h_print("\t<!-- $_ -->\n");
 815                 }
 816         }
 817         h_print(<<END);
 818         <head>
 819                 <!-- \x7B\x7B\x7B -->
 820                 <title>$DocTitle</title>
 821                 <meta http-equiv="Content-Type" content="text/html; charset=$suncgi::CharSet">
 822 END
 823         h_print($RefreshStr) if length($RefreshStr);
 824         h_print(<<END);
 825                 <meta name="author" content="&#216;yvind A. Holm">
 826                 <meta name="copyright" content="&#169; &#216;yvind A. Holm">
 827                 <meta name="date" content="$DocumentTime">
 828 END
 829         h_print(<<END) if defined($suncgi::WebMaster);
 830                 <link rev="made" href="mailto:$suncgi::WebMaster">
 831 END
 832         h_print($style_sheet) if length($style_sheet);
 833         h_print($head_script) if length($head_script);
 834         h_print("\t\t<!-- \x7D\x7D\x7D -->\n");
 835         h_print("\t</head>\n");
 836         unless ($no_body) {
 837                 h_print("\t<body$body_attr>\n");
 838         }
 839         # }}}
 840 } # print_header()
 841
 842 sub tab_print {
 843         # {{{
 844         my @Txt = @_;
 845         my @call_info = caller;
 846         # HTMLwarn("Hm, tab_print() ble brukt. Synderen er $call_info[1], linje$call_info[2]. ☠ og snyte.") if $main::Debug;
 847
 848         unless($suncgi::header_done) {
 849                 print_header("tab_print()-header");
 850                 h_print("\n<!-- debug: tab_print() før print_header(). Tar saken i egne hender. -->\n");
 851         }
 852
 853         foreach (@Txt) {
 854                 s/^(.*)/${suncgi::Tabs}$1/gm;
 855                 # Det jøkke sæ med denslags konvertering i disse nesten-UTF-8-tider.
 856                 # s/([\x7f-\xff])/sprintf("&#%u;", ord($1))/ge;
 857                 h_print("$_");
 858         }
 859         # }}}
 860 } # tab_print()
 861
 862 sub tab_str {
 863         # {{{
 864         my @Txt = @_;
 865         my $RetVal = "";
 866
 867         foreach (@Txt) {
 868                 s/^(.*)/${suncgi::Tabs}$1/gm;
 869                 s/([\x7f-\xff])/sprintf("&#%u;", ord($1))/ge;
 870                 $RetVal .= "$_";
 871         }
 872         return $RetVal;
 873         # }}}
 874 } # tab_str()
 875
 876 sub Tabs {
 877         # {{{
 878         my $Value = shift;
 879
 880         # FIXME: Finpussing seinere.
 881         if ($Value > 0) {
 882                 for (1..$Value) {
 883                         $suncgi::Tabs =~ s/(.*)/$1\t/;
 884                 }
 885         } elsif ($Value < 0) {
 886                 $Value = 0 - $Value;
 887                 for (1..$Value) {
 888                         $suncgi::Tabs =~ s/^(.*)\t/$1/;
 889                 }
 890         } else {
 891                 HTMLwarn("Intern feil: Tabs() ble kalt med \$Value = 0");
 892         }
 893         # }}}
 894 } # Tabs()
 895
 896 sub url_encode {
 897         # {{{
 898         my $String = shift;
 899
 900         defined($String) || ($String = "");
 901         $String =~ s/([\x00-\x20"#%&\.\/;<>?{}|\\\\^~`\[\]\x7F-\xFF])/
 902                    sprintf ('%%%X', ord($1))/eg;
 903
 904         return $String;
 905         # }}}
 906 } # url_encode()
 907
 908 sub sec_to_string {
 909         # {{{
 910         my ($Seconds, $Sep, $Sep2, $Gmt) = @_;
 911         defined($Sep)  || ($Sep = "");
 912         defined($Sep2) || ($Sep2 = "");
 913         defined($Gmt)  || ($Gmt = 0);
 914         $Sep = "T" unless length($Sep);
 915         $Sep2 = "-" unless length($Sep2);
 916         my @TA = $Gmt ? gmtime($Seconds) : localtime($Seconds);
 917         my($DateString) = sprintf("%04u%s%02u%s%02u%s%02u:%02u:%02u%s", $TA[5]+1900, $Sep2, $TA[4]+1, $Sep2, $TA[3], $Sep, $TA[2], $TA[1], $TA[0], $Gmt ? "Z" : "");
 918         return($DateString);
 919         # }}}
 920 } # sec_to_string()
 921
 922 sub utf8_print {
 923         # Konverterer en UTF-8-streng til 7-bits HTML og sender den til stdout. FIXME: Overlange sekvenser godtas. {{{
 924         # Halv-FIXME: Ikke helt oppdatert i henhold til RFC 3629, godtar 6-byters sekvenser. Men det er jo sikkert greit nok foreløpig.
 925         # Forøvrig er jeg ikke så forbanna glad i den RFC’en.
 926         # Henta fra SunbaseCGI.pm,v 1.14 2004/01/29 04:40:33
 927         my $Txt = shift;
 928         my @call_info = caller;
 929
 930         HTMLwarn("utf8_print(), for helsike? Avlegs! Gjort i $call_info[1], linje$call_info[2]. ☠ og snyte.") if $main::Debug;
 931
 932         if ($suncgi::CharSet =~ /^UTF-8$/i) {
 933                 $Txt =~ s/([\xFC-\xFD][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1)/ge;
 934                 $Txt =~ s/([\xF8-\xFB][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1)/ge;
 935                 $Txt =~ s/([\xF0-\xF7][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1)/ge;
 936                 $Txt =~ s/([\xE0-\xEF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1)/ge;
 937                 $Txt =~ s/([\xC0-\xDF][\x80-\xBF])/utf8_to_entity($1)/ge;
 938         } elsif ($suncgi::CharSet =~ /^ISO-8859-1$/i) {
 939                 # NOP, bare sunn paranoia
 940         } else {
 941                 HTMLwarn("utf8_print(): Ukjent tegnsett: \"$suncgi::CharSet\"");
 942         }
 943         print($Txt);
 944         # }}}
 945 } # utf8_print()
 946
 947 sub h_print {
 948         # Det er håp om at dette skal bli den standardiserte utskriftsrutina for HTML. {{{
 949         # Forhåpentligvis medfører den skroting av ting som tab_print(),
 950         # utf8_print() og standard print() osv. $from_charset kan spesifiseres hvis
 951         # det er noe annet enn UTF-8 som skal skrives ut. Der er det bare
 952         # ISO-8859-1 som støttes, noe annet gidder jeg ikke å surre med.
 953         # $use_entities settes til !0 hvis 8-bits tegn IKKE skal konverteres til
 954         # numeriske entities.
 955
 956         my ($Txt, $from_charset, $no_entities) = @_;
 957         # deb_pr(join("|", "Går inn i h_print(", @_, ")"));
 958         defined($from_charset) || ($from_charset = "UTF-8");
 959         defined($no_entities) || ($no_entities = 0);
 960         length($from_charset) || ($from_charset = "UTF-8");
 961         length($no_entities) || ($no_entities = 0);
 962
 963         unless ($suncgi::header_done) {
 964                 HTMLwarn("h_print() uten at print_header() er kjørt.");
 965                 print_header("");
 966         }
 967         if ($from_charset =~ /^UTF-8$/i) {
 968                 if ($suncgi::CharSet =~ /^UTF-8$/i) {
 969                         unless ($no_entities) {
 970                                 $Txt =~ s/([\xFC-\xFD][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1)/ge;
 971                                 $Txt =~ s/([\xF8-\xFB][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1)/ge;
 972                                 $Txt =~ s/([\xF0-\xF7][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1)/ge;
 973                                 $Txt =~ s/([\xE0-\xEF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1)/ge;
 974                                 $Txt =~ s/([\xC0-\xDF][\x80-\xBF])/utf8_to_entity($1)/ge;
 975                         }
 976                 } elsif ($suncgi::CharSet =~ /^ISO-8859-1$/i) {
 977                         $Txt =~ s/([\xFC-\xFD][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1, $no_entities)/ge;
 978                         $Txt =~ s/([\xF8-\xFB][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1, $no_entities)/ge;
 979                         $Txt =~ s/([\xF0-\xF7][\x80-\xBF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1, $no_entities)/ge;
 980                         $Txt =~ s/([\xE0-\xEF][\x80-\xBF][\x80-\xBF])/utf8_to_entity($1, $no_entities)/ge;
 981                         $Txt =~ s/([\xC0-\xDF][\x80-\xBF])/utf8_to_entity($1, $no_entities)/ge;
 982                 } else {
 983                         HTMLwarn("h_print(): Ukjent CharSet: \"$suncgi::CharSet\"");
 984                 }
 985         } elsif ($from_charset =~ /^ISO-8859-1$/i) {
 986                 if ($suncgi::CharSet =~ /^UTF-8$/) {
 987                         $Txt =~ s/([\xA0-\xFF])/widechar(ord($1), $no_entities)/ge;
 988                 } elsif ($suncgi::CharSet =~ /^ISO-8859-1$/) {
 989                         # NOP, bare for å kunne sjekke om det er ulovlige ting på gang.
 990                         unless ($no_entities) {
 991                                 $Txt =~ s/([\xA0-\xFF])/sprintf("&#%u;", ord($1))/ge;
 992                         }
 993                 } else {
 994                         HTMLwarn("Ukjent tegnsett: \"$suncgi::CharSet\"");
 995                 }
 996         } else {
 997                 HTMLwarn("h_print(): Ukjent tegnsett: \"$from_charset\"");
 998         }
 999         print($Txt);
1000         # }}}
1001 } # h_print()
1002
1003 sub utf8_to_entity {
1004         # Konverterer en UTF-8-sekvens til en numerisk HTML-entitet eller ISO-8859-1. Brukes av h_print() og utf8_print() {{{
1005         # utf8_to_entity() er henta fra «u2h,v 1.7 2002/11/20 00:48:10 sunny»
1006         # Da het den decode_char()
1007         # Og så ble den henta derfra (SunbaseCGI.pm,v 1.14 2004/01/29 04:40:33) og hit.
1008
1009         my ($Msg, $use_latin1) = @_;
1010         my ($allow_invalid, $use_decimal) =
1011            (             0,            1);
1012         my $Val = "";
1013
1014         if ($Msg =~ /^([\x20-\x7F])$/) {
1015                 $Val = ord($1);
1016         } elsif ($Msg =~ /^([\xC0-\xDF])([\x80-\xBF])/) {
1017                 if (!$allow_invalid && $Msg =~ /^[\xC0-\xC1]/) {
1018                         $Val = 0xFFFD;
1019                 } else {
1020                         $Val = ((ord($1) & 0x1F) << 6) | (ord($2) & 0x3F);
1021                 }
1022         } elsif ($Msg =~ /^([\xE0-\xEF])([\x80-\xBF])([\x80-\xBF])/) {
1023                 if (!$allow_invalid && $Msg =~ /^\xE0[\x80-\x9F]/) {
1024                         $Val = 0xFFFD;
1025                 } else {
1026                         $Val = ((ord($1) & 0x0F) << 12) |
1027                                ((ord($2) & 0x3F) <<  6) |
1028                                ( ord($3) & 0x3F);
1029                 }
1030         } elsif ($Msg =~ /^([\xF0-\xF7])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])/) {
1031                 if (!$allow_invalid && $Msg =~ /^\xF0[\x80-\x8F]/) {
1032                         $Val = 0xFFFD;
1033                 } else {
1034                         $Val = ((ord($1) & 0x07) << 18) |
1035                                ((ord($2) & 0x3F) << 12) |
1036                                ((ord($3) & 0x3F) <<  6) |
1037                                ( ord($4) & 0x3F);
1038                 }
1039         } elsif ($Msg =~ /^([\xF8-\xFB])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])/) {
1040                 if (!$allow_invalid && $Msg =~ /^\xF8[\x80-\x87]/) {
1041                         $Val = 0xFFFD;
1042                 } else {
1043                         $Val = ((ord($1) & 0x03) << 24) |
1044                                ((ord($2) & 0x3F) << 18) |
1045                                ((ord($3) & 0x3F) << 12) |
1046                                ((ord($4) & 0x3F) <<  6) |
1047                                ( ord($5) & 0x3F);
1048                 }
1049         } elsif ($Msg =~ /^([\xFC-\xFD])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])/) {
1050                 if (!$allow_invalid && $Msg =~ /^\xFC[\x80-\x83]/) {
1051                         $Val = 0xFFFD;
1052                 } else {
1053                         $Val = ((ord($1) & 0x01) << 30) |
1054                                ((ord($2) & 0x3F) << 24) |
1055                                ((ord($3) & 0x3F) << 18) |
1056                                ((ord($4) & 0x3F) << 12) |
1057                                ((ord($5) & 0x3F) <<  6) |
1058                                ( ord($6) & 0x3F);
1059                 }
1060         }
1061         unless ($allow_invalid) {
1062                 if (($Val >= 0xD800 && $Val <= 0xDFFF) || ($Val eq 0xFFFE) || ($Val eq 0xFFFF)) {
1063                         $Val = 0xFFFD;
1064                 }
1065         }
1066         # return("-") if ($Val eq 0x2010); # Vetta fan hvorfor den mangler i masse fonter, så man får seife litt. Den er egentlig ufattelig stygg den der, men hva i helsike skal man gjøre? FIXME: Er det verdt bråket? ☠!!!
1067         # deb_pr("utf8_to_entity(): \$Val = \"$Val\" før retval");
1068         my $Retval = $use_latin1
1069                 ? (
1070                         ($Val <= 0xFF)
1071                         ? chr($Val)
1072                         : sprintf("&#%u;", $Val)
1073                 ) : (
1074                         sprintf("&#%u;", $Val)
1075                 );
1076         # deb_pr("utf8_to_entity() returnerer \"$Retval\"");
1077         return($Retval);
1078         # }}}
1079 } # utf8_to_entity()
1080
1081 sub conv_print {
1082         # Skriver ut strenger som er i andre tegnsett enn UTF-8 og konverterer dem til numeriske HTML-entities. {{{
1083         my ($from_charset, $Txt) = @_;
1084
1085         if ($from_charset =~ /(latin1|iso-8859-1>)/i) {
1086                 $Txt =~ s/([\xA0-\xFF])/sprintf("&#%u;", ord($1))/ge;
1087         } else {
1088                 HTMLwarn("conv_print(): Ukjent tegnsett: \"$from_charset\"");
1089         }
1090         print($Txt);
1091         # }}}
1092 } # conv_print()
1093
1094 sub widechar {
1095         # Konverterer en numerisk tegnverdi til en UTF-8-sekvens. Forsåvidt det motsatte av utf8_to_entity(). {{{
1096         # Henta fra "h2u,v 1.5 2002/11/20 00:09:40" og forandra litt på.
1097         my ($Val, $no_entities) = @_;
1098         my $allow_illegal = 0;
1099         if ($Val < 0x80) {
1100                 return(sprintf($no_entities ? "%c" : "&#%u;", $Val));
1101         } elsif ($Val < 0x800) {
1102                 return(sprintf($no_entities ? "%c%c" : "&#%u;", 0xC0 | ($Val >> 6),
1103                                        0x80 | ($Val & 0x3F)));
1104         } elsif ($Val < 0x10000) {
1105                 unless ($allow_illegal) {
1106                         if  (($Val >= 0xD800 && $Val <= 0xDFFF) || ($Val eq 0xFFFE) || ($Val eq 0xFFFF)) {
1107                                 $Val = 0xFFFD;
1108                         }
1109                 }
1110                 return(sprintf($no_entities ? "%c%c%c" : "&#%u;", 0xE0 |  ($Val >> 12),
1111                                          0x80 | (($Val >>  6) & 0x3F),
1112                                          0x80 |  ($Val        & 0x3F)));
1113         } elsif ($Val < 0x200000) {
1114                 return(sprintf($no_entities ? "%c%c%c%c" : "&#%u;", 0xF0 |  ($Val >> 18),
1115                                            0x80 | (($Val >> 12) & 0x3F),
1116                                            0x80 | (($Val >>  6) & 0x3F),
1117                                            0x80 |  ($Val        & 0x3F)));
1118         } elsif ($Val < 0x4000000) {
1119                 return(sprintf($no_entities ? "%c%c%c%c%c" : "&#%u;", 0xF8 |  ($Val >> 24),
1120                                              0x80 | (($Val >> 18) & 0x3F),
1121                                              0x80 | (($Val >> 12) & 0x3F),
1122                                              0x80 | (($Val >>  6) & 0x3F),
1123                                              0x80 | ( $Val        & 0x3F)));
1124         } elsif ($Val < 0x80000000) {
1125                 return(sprintf($no_entities ? "%c%c%c%c%c%c" : "&#%u;", 0xFC |  ($Val >> 30),
1126                                                0x80 | (($Val >> 24) & 0x3F),
1127                                                0x80 | (($Val >> 18) & 0x3F),
1128                                                0x80 | (($Val >> 12) & 0x3F),
1129                                                0x80 | (($Val >>  6) & 0x3F),
1130                                                0x80 | ( $Val        & 0x3F)));
1131         } else {
1132                 return widechar(0xFFFD);
1133         }
1134         # }}}
1135 } # widechar()
1136
1137 1;
1138
1139 __END__
1140
1141 # POD {{{
1142
1143 =head1 NAME
1144
1145 suncgi — HTML-rutiner for bruk i index.cgi
1146
1147 =head1 REVISION
1148
1149 S<$Id$>
1150
1151 =head1 SYNOPSIS
1152
1153 use suncgi;
1154
1155 =head1 DESCRIPTION
1156
1157 Inneholder en del rutiner som brukes av F<index.cgi>.
1158 Inneholder generelle HTML-rutiner som brukes hele tiden.
1159
1160 =head1 COPYRIGHT
1161
1162 (C)opyright 1999–2004 Øyvind A. Holm E<lt>F<sunny@sunbase.org>E<gt>
1163
1164 Lisens: GNU General Public License ♥
1165
1166 =head1 VARIABLER
1167
1168 =head2 Nødvendige variabler
1169
1170 Når man bruker dette biblioteket, er det en del variabler som må defineres
1171 under kjøring:
1172
1173 =over 4
1174
1175 =item I<${suncgi::Url}>
1176
1177 URL’en til index.cgi.
1178 Normalt sett blir denne satt til navnet på scriptet, for eksempel "I<index.cgi>" eller lignende.
1179 Før ble I<${suncgi::Url}> satt til full URL med F<httpZ<>://> og greier, men det gikk dårlig hvis ting for eksempel ble kjørt under F<httpsZ<>://>
1180
1181 =item I<${suncgi::WebMaster}>
1182
1183 Emailadressen til den som eier dokumentet.
1184 Denne blir ikke satt inn på copyrighter og sånn.
1185
1186 =item I<${suncgi::error_file}>
1187
1188 Filnavn på en fil som er skrivbar av den som kjører scriptet (som oftest I<nobody>).
1189 Alle feilmeldinger og warnings havner her.
1190
1191 =item I<${suncgi::log_dir}>
1192
1193 Navn på directory der logging fra blant annet I<log_access()> havner.
1194 Brukeren I<nobody> (eller hva nå httpd måtte kjøre under) skal ha skrive/leseaksess der.
1195
1196 =back
1197
1198 NB: Disse må ikke være I<my>’et, de må være globale så de kan bli brukt av alle modulene.
1199
1200 =head2 Valgfrie variabler
1201
1202 Disse variablene er ikke nødvendige å definere, bare hvis man gidder:
1203
1204 =over 4
1205
1206 =item I<${suncgi::doc_width}>
1207
1208 Bredden på dokumentet i pixels.
1209 I<$suncgi::STD_DOCWIDTH> som default.
1210
1211 =item I<${CharSet}>
1212
1213 Tegnsett som brukes.
1214 Er I<$suncgi::STD_CHARSET> som default, "I<ISO-8859-1>".
1215
1216 =item I<${main::BackGround}>
1217
1218 Bruker denne som default bakgrunn til I<print_background()>.
1219 Hvis den ikke er definert, brukes I<$suncgi::STD_BACKGROUND>, en tom greie.
1220
1221 =item I<${main::Debug}>
1222
1223 Skriver ut en del debuggingsinfo.
1224
1225 =item I<${main::Utv}>
1226
1227 Beslektet med I<${main::Debug}>, men hvis denne er definert, sitter man lokalt og tester.
1228 Eneste forskjellen hovedsaklig er at feilmeldinger går til skjerm i tillegg til errorfila.
1229
1230 =item I<${suncgi::Border}>
1231
1232 Brukes mest til debugging. Setter I<border> i alle E<lt>tableE<gt>’es.
1233
1234 =back
1235
1236 =head1 SUBRUTINER
1237
1238 =head2 content_type()
1239
1240 Brukes omtrent bare av F<print_header()>, men kan kalles separat hvis det er speisa content-typer ute og går, som for eksempel C<application/x-tar> og lignende.
1241
1242 =head2 curr_local_time()
1243
1244 Returnerer tidspunktet akkurat nå, lokal tid. Formatet er i henhold til S<ISO 8601>, dvs.
1245 I<YYYY>-I<MM>-I<DD>TI<HH>:I<MM>:I<SS>+I<HHMM>
1246
1247 B<FIXME:> Finn en måte å returnere differansen mellom UTC og lokal tid.
1248 Foreløpig droppes +0200 og sånn. Det liker vi I<ikke>. Ikke baser noen
1249 programmer på formatet foreløpig.
1250
1251 =head2 create_file()
1252
1253 Lager en fil hvis den ikke eksisterer fra før.
1254
1255 =head2 curr_utc_time()
1256
1257 Returnerer tidspunktet akkurat nå i UTC.
1258 Brukes av blant annet F<print_header()> til å sette rett tidspunkt inn i headeren.
1259 Formatet på datoen er i henhold til S<ISO 8601>, dvs. I<YYYY>-I<MM>-I<DD>TI<HH>:I<MM>:I<SS>Z
1260
1261 =head2 D()
1262
1263 En debuggingsrutine som kjøres hvis ${main::Debug} ikke er 0.
1264 Den forlanger at ${suncgi::error_file} er definert, det skal være en fil der all debuggingsinformasjonen skrives til.
1265
1266 For at debugging skal bli lettere, kan man slenge denne inn på enkelte steder.
1267 Eksempel:
1268
1269         # deb_pr("sort_dir(): Det er $Elements elementer her.");
1270
1271 B<FIXME:> Mer pod seinere.
1272
1273 =head2 deb_pr()
1274
1275 Samme som D(), men skal skiftes ut etterhvert. Det var det den het før.
1276
1277 =head2 escape_dangeours_chars()
1278
1279 Brukes hvis man skal utføre en systemkommando og man får med kommandolinja å gjøre.
1280 Eksempel:
1281
1282         $cmd_line = escape_dangerous_chars("$cmd_line");
1283         system("$cmd_line");
1284
1285 Tegn som kan rote til denne kommandoen får en backslash foran seg.
1286
1287 =head2 file_mdate()
1288
1289 Returnerer tidspunktet fila sist ble modifisert i sekunder siden S<1970-01-01 00:00:00 UTC>.
1290 Brukes hvis man skal skrive ting som «sist oppdatert da og da».
1291
1292 =head2 get_cgivars()
1293
1294 Leser inn alle verdier sendt med GET eller POST requests og returnerer en
1295 hash med verdiene. Fungerer på denne måten:
1296
1297         %Opt = get_cgivars;
1298         my $Document = $Opt{doc};
1299         my $user_name = $Opt{username};
1300
1301 Alle verdiene ligger nå i de respektive variablene og kan (mis)brukes Vilt & Uhemmet™.
1302
1303 Funksjonen leser både 'I<&>' (ampersand) og 'I<;>' (semikolon) som skilletegn i GET/POST, scripts bør sende 'I<;>' så det ikke blir kluss med entities.
1304 Eksempel:
1305
1306         index.cgi?doc=login;username=suttleif;pwd=hemmelig
1307
1308 B<FIXME:> Denne må utvides litt med flere Content-type’er.
1309
1310 =head2 get_countervalue()
1311
1312 Skriver ut verdien av en teller, angi filnavn.
1313 Fila skal inneholde et tall i standard ASCII-format.
1314
1315 =head2 HTMLdie()
1316
1317 Tilsvarer F<die()> i standard Perl, men sender HTML-output så man ikke får Internal Server Error.
1318 Funksjonen tar to parametere, I<$Msg> som havner i E<lt>titleE<gt>E<lt>/titleE<gt> og E<lt>h1E<gt>E<lt>/h1E<gt>, og I<$Msg> som blir skrevet ut som beskjed.
1319
1320 Hvis hverken I<${main::Utv}> eller I<${main::Debug}> er sann, skrives meldinga til I<${suncgi::error_file}> og en standardmelding blir skrevet ut.
1321 Folk får ikke vite mer enn de har godt av.
1322
1323 =head2 HTMLwarn()
1324
1325 En lightversjon av I<HTMLdie()>, den skriver kun til I<${suncgi::error_file}>.
1326 Når det oppstår feil, men ikke trenger å rive ned hele systemet.
1327 Brukes til småting som tellere som ikke virker og sånn.
1328
1329 B<FIXME:> Muligens det burde vært lagt inn at $suncgi::WebMaster fikk mail hver gang ting går på trynet.
1330
1331 =head2 increase_counter()
1332
1333 Øker telleren i en spesifisert fil med en.
1334 Fila skal inneholde et tall i ASCII-format.
1335 I tillegg lages en fil som heter F<{fil}.ip> som inneholder IP’en som brukeren er tilkoblet fra.
1336 Hvis IP’en er den samme som i fila, oppdateres ikke telleren.
1337 Hvis parameter 2 er I<!0>, øker telleren uanskvett.
1338
1339 =head2 log_access()
1340
1341 Logger aksess til en fil. Filnavnet skal være uten extension, rutina tar seg av det.
1342 I tillegg øker den en teller i fila I<$Base.count> unntatt hvis parameter 2 != 0.
1343
1344 Forutsetter at I<${suncgi::log_dir}> er definert. Hvis ikke, settes den til
1345 I<$suncgi::STD_LOGDIR>.
1346
1347 B<FIXME:> Skriv mer her.
1348
1349 Med nærmere ettertanke — hvorfor det, egentlig?
1350 Bruker jo aldri den POD’en likevel.
1351
1352 =head2 print_doc()
1353
1354 Leser inn et dokument og konverterer det til HTML.
1355 Dette blir en av de mest sentrale rutinene i en hjemmeside, i og med at det skal ta seg av HTML-output’en.
1356 Istedenfor å fylle opp scriptene med HTML-koder, gjøres et kall til F<print_doc()> som skriver ut sidene og genererer HTML.
1357
1358 Formatet på fila består av to deler:
1359 Header og HTML.
1360 De første linjene består av ting som tittel, keywords, html-versjon, evt. refresh og så videre.
1361 Her har vi et eksempel på en fil (Ingen space i begynnelsen på hver linje, det er til ære for F<pod> at det er sånn):
1362
1363  title Velkommen til snaddersida
1364  keywords snadder, stilig, kanontøfft, extremt, tjobing
1365  htmlversion html4strict
1366  author jeg@er.snill.edu
1367
1368  <table width="<=docwidth>">
1369         <tr>
1370                 <td colspan="2" align="center">
1371                         Han dæven sjteiki
1372                 </td>
1373         </tr>
1374         <tr>
1375                 <td>
1376                         Så tøfft dette var.
1377                 </td>
1378                 <td>
1379                         Nemlig. Mailadressen min er <=author>
1380                 </td>
1381         </tr>
1382  </table>
1383  <=footer>
1384
1385 Rutina tar to parametere:
1386
1387 =over 4
1388
1389 =item I<$file_name> (nødvendig)
1390
1391 Fil som skal skrives ut. Denne har som standard extension F<*.shtml> .
1392
1393 =item I<$page_num> (valgfri)
1394
1395 Denne brukes hvis det er en "kjede" med dokumenter, og det skal lages en
1396 "framover" og "bakover"-button.
1397
1398 Alt F<print_footer()> gjør, er å lete opp plassen i fila som ting skal
1399 skrives ut fra. Grunnen til dette er at et dokument kan inneholde flere
1400 dokumenter som separeres med E<lt>=pageE<gt>.
1401
1402 =back
1403
1404 B<FIXME:> Skriver mer på denne seinere. Og gjør greia ferdig. Support for
1405 E<lt>=pageE<gt> må legges inn.
1406
1407 Alt kan legges inn i en fil:
1408
1409         title Eksempel på datafil
1410         lang no
1411         ext html
1412         cvsroot :pserver:bruker@host.no:/cvsroot
1413         ftp ftp://black.host.no
1414
1415         <=page index>
1416         <p>Bla bla bla
1417
1418         <=page support>
1419         <p>Supportpreik
1420
1421         <=page contact>
1422         <p>Kontaktpreik osv
1423
1424 =head2 p_footer()
1425
1426 Returnerer footer i HTML.
1427 Brukes mest til debugging for å få validatorknapp og liste over moduler som brukes.
1428
1429 =head2 print_footer()
1430
1431 Skriver ut en footer med en E<lt>hrE<gt> først. Funksjonen tar disse
1432 parameterne:
1433
1434 =over 4
1435
1436 =item I<$footer_width>
1437
1438 Bredden på footeren i pixels.
1439 Hvis den ikke er definert, brukes I<${doc_width}>.
1440 Og hvis den heller ikke er definert, brukes I<$suncgi::STD_DOCWIDTH> som default.
1441
1442 =item I<$footer_align>
1443
1444 Kan være I<left>, I<center> eller I<right>.
1445 Brukes av E<lt>tableE<gt>.
1446 Hvis udefinert, brukes I<$suncgi::doc_align>.
1447 Hvis den ikke er definert, brukes I<$suncgi::STD_DOCALIGN>.
1448
1449 =item I<$no_vh>
1450
1451 I<0> eller udefinert:
1452 Skriver I<Valid HTML>-logoen nederst i høyre hjørne.
1453 I<1>: Dropper den.
1454
1455 =item I<$no_end>
1456
1457 Tar ikke med E<lt>/bodyE<gt>E<lt>/htmlE<gt> på slutten hvis I<1>.
1458
1459 =back
1460
1461 =head2 print_header()
1462
1463 Parametere i print_header():
1464
1465  1. Tittelen på dokumentet.
1466  2. Antall sekunder på hver refresh, 0 disabler refresh.
1467  3. Style sheet.
1468  4. Evt. scripts, havner mellom </style> og </head>.
1469  5. Evt. attributter i <body>, f.eks. " onLoad=\"myfunc()\"".
1470     Husk spacen i begynnelsen.
1471  6. HTML-versjon. F.eks. $suncgi::DTD_HTML4STRICT.
1472     Default er $suncgi::DTD_HTML4LOOSE.
1473  7. Språk. Default "no".
1474  8. no_body. 0 = Skriv <body>, 1 = Ikke skriv.
1475
1476 =head2 tab_print()
1477
1478 Skriver ut på samme måte som print, men setter inn I<$suncgi::Tabs> først på hver linje.
1479 Det er for å få riktige innrykk.
1480 Det forutsetter at I<$suncgi::Tabs> er oppdatert til enhver tid.
1481
1482 =head2 tab_str()
1483
1484 Fungerer på samme måte som I<tab_print()>, men returnerer en streng med innholdet istedenfor å skrive det ut.
1485 Muligens det burde vært implementert i I<tab_print()> på en eller annen måte, men blir ikke det tungvint?
1486
1487 Vi lar det være sånn foreløpig.
1488
1489 =head2 Tabs()
1490
1491 Øker/minsker verdien av I<${suncgi::Tabs}>.
1492 Den kan ta ett parameter, en verdi som er negativ eller positiv alt ettersom man skal fjerne eller legge til TAB’er.
1493 Hvis man skriver
1494
1495         Tabs(-2);
1496
1497 fjernes to spacer, hvis man skriver
1498
1499         Tabs(5);
1500
1501 legges 5 TAB’er til.
1502 Hvis ingen parametere spesifiseres, brukes 1 som default, altså en TAB legges til.
1503
1504 =head2 url_encode()
1505
1506 Konverterer en streng til format for bruk i URL’er.
1507
1508 =head2 sec_to_string()
1509
1510 Konverterer til leselig datoformat.
1511
1512 =head1 BUGS
1513
1514 print_doc() er ikke ferdig, ellers svinger det visst.
1515
1516 pod’en er m̶u̶l̶i̶g̶e̶n̶s̶ ute av sync med Tingenes Tilstand™.
1517 Men det er vel sånt som forventes.
1518
1519 =cut
1520
1521 # }}}
1522
1523 #### End of file $Id$ ####