jsonfmt.py: Don't sort the JSON, use the new -s/--sort option for that
[sunny256-utils.git] / Lib / perllib / suncgi.pm
blobff233b112035e0799d1239ea2d000aff102bf480
1 package suncgi;
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 #=========================================================
11 require Exporter;
12 @ISA = qw(Exporter);
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
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
33 # }}}
35 @EXPORT_OK = qw{
36 print_footer
38 # %EXPORT_TAGS = tag => [...]; # define names for sets of symbols
40 use Fcntl ':flock';
41 use strict;
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å
48 $suncgi::rcs_id = '$Id$';
49 push(@main::rcs_array, $suncgi::rcs_id);
51 $suncgi::this_counter = "";
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};
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;
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";
72 $suncgi::Footer = <<END;
73 </body>
74 </html>
75 END
77 #### Subrutiner ####
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\".");
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()");
94 # print "Content-Type: $ContType\n\n"; # Til ære for slappe servere som ikke har peiling
95 # }}}
96 } # content_type()
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;
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()
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()
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()
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");
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");
147 if (length($err_msg)) {
148 print(<<END);
149 Content-type: text/html
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>
167 exit();
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()
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");
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");
199 if (length($err_msg)) {
200 print <<END;
201 Content-type: text/html
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>
220 exit();
222 print(DebugFP $warn_str);
223 # print("$warn_str<br>\n");
224 close(DebugFP);
225 # }}}
226 } # deb_pr()
228 sub escape_dangerous_chars {
229 # {{{
230 my $string = shift;
232 $string =~ s/([;\\<>\*\|`&\$!#\(\)\[\]\{\}'"])/\\$1/g;
233 return $string;
234 # }}}
235 } # escape_dangerous_chars()
237 sub file_mdate {
238 # {{{
239 my($FileName) = @_;
240 my(@TA);
241 my @StatArray = stat($FileName);
242 return($StatArray[9]);
243 # }}}
244 } # file_mdate()
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} = "");
255 my $user_method = defined($ENV{REQUEST_METHOD}) ? $ENV{REQUEST_METHOD} : "";
256 # length($user_method) || ($user_method = "");
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;
274 } else {
275 if (length($user_method)) {
276 HTMLdie("Programmet ble kalt med ukjent REQUEST_METHOD: \"$user_method\"");
277 exit;
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";
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: $!");
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);
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\"");
311 return %in;
312 # }}}
313 } # get_cgivars()
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");
334 # }}}
335 } # get_cookie()
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).
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;
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.
365 if (!defined $domain) {
366 # set domain of cookie. Default is current host.
367 $domain = $ENV{'SERVER_NAME'};
369 if (!defined $path) {
370 # set default path = "/"
371 $path = "/";
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.
386 undef %suncgi::Cookie;
387 # }}}
388 } # set_cookie()
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.
401 # }}}
402 } # delete_cookie()
404 sub split_cookie {
405 # {{{
406 # Splits a multi-valued parameter into a list of the constituent parameters
408 my ($param) = @_;
409 my (@params) = split ("\1", $param);
410 return (wantarray ? @params : $params[0]);
411 # }}}
412 } # split_cookie()
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);
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()
436 sub HTMLdie {
437 # {{{
438 my($Msg,$Title) = @_;
439 my $utc_str = curr_utc_time;
440 my $msg_str = "";
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);
449 h_print(<<END);
450 Content-type: text/html
452 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN" "http://www.w3.org/TR/REC-html40/strict.dtd">
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; }
469 </style>
470 <meta http-equiv="Content-Type" content="text/html; charset=$suncgi::CharSet">
472 h_print(<<END) if defined($suncgi::WebMaster);
473 <meta name="author" content="$suncgi::WebMaster">
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">
480 h_print(<<END) if defined($suncgi::WebMaster);
481 <link rev="made" href="mailto:$suncgi::WebMaster">
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>
494 if (length(${suncgi::error_file})) {
495 unless (-e $suncgi::error_file) {
496 open(ErrorFP, ">$suncgi::error_file");
497 close(ErrorFP);
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);
508 exit;
509 # }}}
510 } # HTMLdie()
512 sub HTMLwarn {
513 # {{{
514 my $Msg = shift;
515 my $utc_str = curr_utc_time();
516 my @call_info = caller;
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";
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");
532 if (-e ${suncgi::error_file}) {
533 open(ErrorFP, ">>${suncgi::error_file}") or return;
534 } else {
535 open(ErrorFP, ">${suncgi::error_file}") or return;
537 print(ErrorFP $warn_str);
538 close(ErrorFP);
539 # }}}
540 } # HTMLwarn()
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()
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");
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);
580 close(TmpFP);
581 return($counter_value + ($new_ip ? 1 : 0));
582 # }}}
583 } # increase_counter()
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()
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} = "");
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()
624 sub print_doc {
625 # {{{
626 my ($file_name, $page_num) = @_;
627 my $in_header = 1;
628 my %doc_val;
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 $.: \"$_\"");
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");
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");
658 h_print(<<END);
659 </body>
660 </html>
662 close(FromFP);
663 # }}}
664 } # print_doc()
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>
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%">
689 </td>
690 </tr>
691 </table>
692 </td>
693 </tr>
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>
716 $Retval .= <<END unless ($no_endhtml);
717 </body>
718 </html>
720 return $Retval;
721 # }}}
722 } # p_footer()
724 sub print_footer {
725 # {{{
726 my ($footer_width, $footer_align, $no_vh, $no_end) = @_;
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;
733 unless (length($footer_align)) {
734 $footer_align = length($suncgi::doc_align) ? $suncgi::doc_align : $suncgi::STD_DOCALIGN;
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;";
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>
771 unless ($no_end) {
772 h_print(<<END);
773 </body>
774 </html>
777 exit; # FIXME: Sikker på det?
778 # }}}
779 } # print_footer()
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;
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">});
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");
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">
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">
829 h_print(<<END) if defined($suncgi::WebMaster);
830 <link rev="made" href="mailto:$suncgi::WebMaster">
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");
839 # }}}
840 } # print_header()
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;
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");
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("$_");
859 # }}}
860 } # tab_print()
862 sub tab_str {
863 # {{{
864 my @Txt = @_;
865 my $RetVal = "";
867 foreach (@Txt) {
868 s/^(.*)/${suncgi::Tabs}$1/gm;
869 s/([\x7f-\xff])/sprintf("&#%u;", ord($1))/ge;
870 $RetVal .= "$_";
872 return $RetVal;
873 # }}}
874 } # tab_str()
876 sub Tabs {
877 # {{{
878 my $Value = shift;
880 # FIXME: Finpussing seinere.
881 if ($Value > 0) {
882 for (1..$Value) {
883 $suncgi::Tabs =~ s/(.*)/$1\t/;
885 } elsif ($Value < 0) {
886 $Value = 0 - $Value;
887 for (1..$Value) {
888 $suncgi::Tabs =~ s/^(.*)\t/$1/;
890 } else {
891 HTMLwarn("Intern feil: Tabs() ble kalt med \$Value = 0");
893 # }}}
894 } # Tabs()
896 sub url_encode {
897 # {{{
898 my $String = shift;
900 defined($String) || ($String = "");
901 $String =~ s/([\x00-\x20"#%&\.\/;<>?{}|\\\\^~`\[\]\x7F-\xFF])/
902 sprintf ('%%%X', ord($1))/eg;
904 return $String;
905 # }}}
906 } # url_encode()
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()
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;
930 HTMLwarn("utf8_print(), for helsike? Avlegs! Gjort i $call_info[1], linje$call_info[2]. ☠ og snyte.") if $main::Debug;
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\"");
943 print($Txt);
944 # }}}
945 } # utf8_print()
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.
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);
963 unless ($suncgi::header_done) {
964 HTMLwarn("h_print() uten at print_header() er kjørt.");
965 print_header("");
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;
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\"");
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;
993 } else {
994 HTMLwarn("Ukjent tegnsett: \"$suncgi::CharSet\"");
996 } else {
997 HTMLwarn("h_print(): Ukjent tegnsett: \"$from_charset\"");
999 print($Txt);
1000 # }}}
1001 } # h_print()
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.
1009 my ($Msg, $use_latin1) = @_;
1010 my ($allow_invalid, $use_decimal) =
1011 ( 0, 1);
1012 my $Val = "";
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);
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);
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);
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);
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);
1061 unless ($allow_invalid) {
1062 if (($Val >= 0xD800 && $Val <= 0xDFFF) || ($Val eq 0xFFFE) || ($Val eq 0xFFFF)) {
1063 $Val = 0xFFFD;
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
1070 ($Val <= 0xFF)
1071 ? chr($Val)
1072 : sprintf("&#%u;", $Val)
1073 ) : (
1074 sprintf("&#%u;", $Val)
1076 # deb_pr("utf8_to_entity() returnerer \"$Retval\"");
1077 return($Retval);
1078 # }}}
1079 } # utf8_to_entity()
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) = @_;
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\"");
1090 print($Txt);
1091 # }}}
1092 } # conv_print()
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;
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);
1134 # }}}
1135 } # widechar()
1139 __END__
1141 # POD {{{
1143 =head1 NAME
1145 suncgi — HTML-rutiner for bruk i index.cgi
1147 =head1 REVISION
1149 S<$Id$>
1151 =head1 SYNOPSIS
1153 use suncgi;
1155 =head1 DESCRIPTION
1157 Inneholder en del rutiner som brukes av F<index.cgi>.
1158 Inneholder generelle HTML-rutiner som brukes hele tiden.
1160 =head1 COPYRIGHT
1162 (C)opyright 1999–2004 Øyvind A. Holm E<lt>F<sunny@sunbase.org>E<gt>
1164 Lisens: GNU General Public License ♥
1166 =head1 VARIABLER
1168 =head2 Nødvendige variabler
1170 Når man bruker dette biblioteket, er det en del variabler som må defineres
1171 under kjøring:
1173 =over 4
1175 =item I<${suncgi::Url}>
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<>://>
1181 =item I<${suncgi::WebMaster}>
1183 Emailadressen til den som eier dokumentet.
1184 Denne blir ikke satt inn på copyrighter og sånn.
1186 =item I<${suncgi::error_file}>
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.
1191 =item I<${suncgi::log_dir}>
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.
1196 =back
1198 NB: Disse må ikke være I<my>’et, de må være globale så de kan bli brukt av alle modulene.
1200 =head2 Valgfrie variabler
1202 Disse variablene er ikke nødvendige å definere, bare hvis man gidder:
1204 =over 4
1206 =item I<${suncgi::doc_width}>
1208 Bredden på dokumentet i pixels.
1209 I<$suncgi::STD_DOCWIDTH> som default.
1211 =item I<${CharSet}>
1213 Tegnsett som brukes.
1214 Er I<$suncgi::STD_CHARSET> som default, "I<ISO-8859-1>".
1216 =item I<${main::BackGround}>
1218 Bruker denne som default bakgrunn til I<print_background()>.
1219 Hvis den ikke er definert, brukes I<$suncgi::STD_BACKGROUND>, en tom greie.
1221 =item I<${main::Debug}>
1223 Skriver ut en del debuggingsinfo.
1225 =item I<${main::Utv}>
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.
1230 =item I<${suncgi::Border}>
1232 Brukes mest til debugging. Setter I<border> i alle E<lt>tableE<gt>’es.
1234 =back
1236 =head1 SUBRUTINER
1238 =head2 content_type()
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.
1242 =head2 curr_local_time()
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>
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.
1251 =head2 create_file()
1253 Lager en fil hvis den ikke eksisterer fra før.
1255 =head2 curr_utc_time()
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
1261 =head2 D()
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.
1266 For at debugging skal bli lettere, kan man slenge denne inn på enkelte steder.
1267 Eksempel:
1269 # deb_pr("sort_dir(): Det er $Elements elementer her.");
1271 B<FIXME:> Mer pod seinere.
1273 =head2 deb_pr()
1275 Samme som D(), men skal skiftes ut etterhvert. Det var det den het før.
1277 =head2 escape_dangeours_chars()
1279 Brukes hvis man skal utføre en systemkommando og man får med kommandolinja å gjøre.
1280 Eksempel:
1282 $cmd_line = escape_dangerous_chars("$cmd_line");
1283 system("$cmd_line");
1285 Tegn som kan rote til denne kommandoen får en backslash foran seg.
1287 =head2 file_mdate()
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».
1292 =head2 get_cgivars()
1294 Leser inn alle verdier sendt med GET eller POST requests og returnerer en
1295 hash med verdiene. Fungerer på denne måten:
1297 %Opt = get_cgivars;
1298 my $Document = $Opt{doc};
1299 my $user_name = $Opt{username};
1301 Alle verdiene ligger nå i de respektive variablene og kan (mis)brukes Vilt & Uhemmet™.
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:
1306 index.cgi?doc=login;username=suttleif;pwd=hemmelig
1308 B<FIXME:> Denne må utvides litt med flere Content-type’er.
1310 =head2 get_countervalue()
1312 Skriver ut verdien av en teller, angi filnavn.
1313 Fila skal inneholde et tall i standard ASCII-format.
1315 =head2 HTMLdie()
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.
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.
1323 =head2 HTMLwarn()
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.
1329 B<FIXME:> Muligens det burde vært lagt inn at $suncgi::WebMaster fikk mail hver gang ting går på trynet.
1331 =head2 increase_counter()
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.
1339 =head2 log_access()
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.
1344 Forutsetter at I<${suncgi::log_dir}> er definert. Hvis ikke, settes den til
1345 I<$suncgi::STD_LOGDIR>.
1347 B<FIXME:> Skriv mer her.
1349 Med nærmere ettertanke — hvorfor det, egentlig?
1350 Bruker jo aldri den POD’en likevel.
1352 =head2 print_doc()
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.
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):
1363 title Velkommen til snaddersida
1364 keywords snadder, stilig, kanontøfft, extremt, tjobing
1365 htmlversion html4strict
1366 author jeg@er.snill.edu
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>
1385 Rutina tar to parametere:
1387 =over 4
1389 =item I<$file_name> (nødvendig)
1391 Fil som skal skrives ut. Denne har som standard extension F<*.shtml> .
1393 =item I<$page_num> (valgfri)
1395 Denne brukes hvis det er en "kjede" med dokumenter, og det skal lages en
1396 "framover" og "bakover"-button.
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>.
1402 =back
1404 B<FIXME:> Skriver mer på denne seinere. Og gjør greia ferdig. Support for
1405 E<lt>=pageE<gt> må legges inn.
1407 Alt kan legges inn i en fil:
1409 title Eksempel på datafil
1410 lang no
1411 ext html
1412 cvsroot :pserver:bruker@host.no:/cvsroot
1413 ftp ftp://black.host.no
1415 <=page index>
1416 <p>Bla bla bla
1418 <=page support>
1419 <p>Supportpreik
1421 <=page contact>
1422 <p>Kontaktpreik osv
1424 =head2 p_footer()
1426 Returnerer footer i HTML.
1427 Brukes mest til debugging for å få validatorknapp og liste over moduler som brukes.
1429 =head2 print_footer()
1431 Skriver ut en footer med en E<lt>hrE<gt> først. Funksjonen tar disse
1432 parameterne:
1434 =over 4
1436 =item I<$footer_width>
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.
1442 =item I<$footer_align>
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>.
1449 =item I<$no_vh>
1451 I<0> eller udefinert:
1452 Skriver I<Valid HTML>-logoen nederst i høyre hjørne.
1453 I<1>: Dropper den.
1455 =item I<$no_end>
1457 Tar ikke med E<lt>/bodyE<gt>E<lt>/htmlE<gt> på slutten hvis I<1>.
1459 =back
1461 =head2 print_header()
1463 Parametere i print_header():
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.
1476 =head2 tab_print()
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.
1482 =head2 tab_str()
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?
1487 Vi lar det være sånn foreløpig.
1489 =head2 Tabs()
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
1495 Tabs(-2);
1497 fjernes to spacer, hvis man skriver
1499 Tabs(5);
1501 legges 5 TAB’er til.
1502 Hvis ingen parametere spesifiseres, brukes 1 som default, altså en TAB legges til.
1504 =head2 url_encode()
1506 Konverterer en streng til format for bruk i URL’er.
1508 =head2 sec_to_string()
1510 Konverterer til leselig datoformat.
1512 =head1 BUGS
1514 print_doc() er ikke ferdig, ellers svinger det visst.
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.
1519 =cut
1521 # }}}
1523 #### End of file $Id$ ####