Web.pm

   1 # $Id$
   2 # Common functions for HTML/XHTML output generation
   3 # Copyright (C) 2003 Jan Kratochvil <project-www.jankratochvil.net@jankratochvil.net>
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; exactly version 2 of June 1991 is required
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the Free Software
  16 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18
  19 package My::Web;
  20 require 5.6.0;  # at least 'use warnings;' but we need some 5.6.0+ modules anyway
  21 our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
  22 our $CVS_ID=q$Id$;
  23 use strict;
  24 use warnings;
  25
  26 use Exporter;
  27 sub Wrequire ($);
  28 sub Wuse ($@);
  29 our $W;
  30 our @EXPORT=qw(&Wrequire &Wuse &a_href &a_href_cz &vskip &img &centerimg &rightimg $W &top_dir &top_dir_disk);
  31 our @ISA=qw(Exporter);
  32
  33 BEGIN
  34 {
  35         sub Wrequire ($)
  36         {
  37         my($file)=@_;
  38
  39 #               print STDERR "Wrequire $file\n";
  40                 $file=~s#/#::#g;
  41                 $file=~s/[.]pm$//;
  42                 my $class=$file;
  43                 $file=~s#::#/#g;
  44                 $file.=".pm";
  45                 my $aref=($W->{"packages_used"}{$Apache::Registry::curstash}||=[]);
  46                 push @$aref,$class
  47                                 if !{ map(($_=>1),@$aref) }->{$class};  # Prevent duplicated entries.
  48                 CORE::require $file;
  49                 1;      # Otherwise 'require' would already file above.
  50         }
  51
  52         sub Wuse ($@)
  53         {
  54         my($file,@list)=@_;
  55
  56 #               print STDERR "Wuse $file\n";
  57                 Wrequire $file;
  58                 local $Exporter::ExportLevel=$Exporter::ExportLevel+1;
  59                 $file->import(@list);
  60                 1;
  61         }
  62 }
  63
  64 BEGIN { Wuse 'WebConfig'; }     # for %WebConfig
  65 require CGI;    # for &escapeHTML
  66 require Image::Size;    # for &imgsize
  67 use File::Basename;     # &basename
  68 use Carp qw(cluck confess);
  69 use URI::Escape;
  70 require HTTP::BrowserDetect;
  71 require HTTP::Negotiate;
  72 my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; }
  73 require CGI;
  74 require Apache2;
  75
  76
  77 # Undo 'www/engine/httpd-restart' as it may use obsolete Perl for 'mod_perl'
  78 delete $ENV{"PERLLIB"};
  79 delete $ENV{"LD_LIBRARY_PATH"};
  80
  81
  82 #our $W;
  83                 # $W->{"title"}
  84                 # $W->{"head"}
  85                 # $W->{"head_css"}
  86                 # $W->{"force_charset"}
  87                 # %{$W->{"packages_used"}
  88                 # $W->{"heading_done"}
  89                 # $W->{"footer_passed"}
  90                 # %{$W->{"headers"}}
  91                 # %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key
  92                 # @{$W->{"packages_used"}{$Apache::Registry::curstash}}}
  93                 # %{$W->{"args"}}
  94
  95 sub init ($%)
  96 {
  97 my($class,%args)=@_;
  98
  99         print STDERR "$class->init ".$ENV{"REQUEST_URI"}."\n";
 100
 101         my $packages_used_save=$W->{"packages_used"};
 102         $W={ %WebConfig,%args };        # override %WebConfig settings
 103         $W->{"packages_used"}=$packages_used_save;
 104
 105         $W->{"__PACKAGE__"}||="Apache::ROOT".$Apache::Registry::curstash;
 106
 107         $W->{"top_dir"}||=eval '$'.$W->{"__PACKAGE__"}.'::top_dir';
 108
 109         do { $W->{$_}=0  if !defined $W->{$_}; } for ("detect_ent");
 110         do { $W->{$_}=0  if !defined $W->{$_}; } for ("detect_js");
 111         do { $W->{$_}=1  if !defined $W->{$_}; } for ("have_css");      # AFAIK it does not hurt anyone.
 112         do { $W->{$_}=1  if !defined $W->{$_}; } for ("heading");
 113         do { $W->{$_}=1  if !defined $W->{$_}; } for ("footer");
 114         do { $W->{$_}=1  if !defined $W->{$_}; } for ("footer_delimit");
 115         do { $W->{$_}=1  if !defined $W->{$_}; } for ("footer_mailme");
 116         do { $W->{$_}=1  if !defined $W->{$_}; } for ("footer_ids");
 117         do { $W->{$_}=1  if !defined $W->{$_}; } for ("indexme");
 118         do { $W->{$_}="" if !defined $W->{$_}; } for ("head");
 119         do { $W->{$_}="" if !defined $W->{$_}; } for ("head_css");
 120
 121         my $footer_any=0;
 122         for (qw(footer_mailme footer_ids)) {
 123                 $W->{$_}=0 if !$W->{"footer"};
 124                 $footer_any=1 if $W->{$_};
 125                 }
 126         $W->{"footer"}=0 if !$footer_any;
 127         $W->{"footer_delimit"}=0 if !$W->{"footer"};
 128
 129         $W->{"r"}=Apache->request();
 130
 131         $W->{"QUERY_STRING"}=$W->{"r"}->args() || "";
 132            if ($W->{"QUERY_STRING"}=~/[&]amp;have_ent/)
 133                 { $W->{"have_ent"}=0; }
 134         elsif ($W->{"QUERY_STRING"}=~    /[&]have_ent/)
 135                 { $W->{"have_ent"}=1; }
 136         else
 137                 { delete $W->{"have_ent"}; }
 138         if ($W->{"detect_ent"} && !defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") {
 139                 $W->{"head"}.='<meta http-equiv="Refresh" content="0; URL='
 140                                 .CGI::escapeHTML("http://".&{$W->{"web_hostname_sub"}}()."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0]
 141                                                 ."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect')
 142                                 .'" />'."\n";
 143                 }
 144         $W->{"QUERY_STRING"}=~s/([&])amp;/$1/g;
 145         $W->{"r"}->args($W->{"QUERY_STRING"});
 146         $ENV{"QUERY_STRING"}=$W->{"QUERY_STRING"};
 147         # Do not: $W->{"r"}->args()
 148         # as it parses only QUERY_STRING (not POST data).
 149         $W->{"args"}={ CGI->new()->Vars() };
 150         for (keys(%{$W->{"args"}})) {
 151                 my @vals=split /\x00/,$W->{"args"}{$_};
 152                 next if @vals<=1;
 153                 $W->{"args"}{$_}=[@vals];
 154                 }
 155
 156         do { $W->{$_}=$ENV{"HTTP_ACCEPT"} if !defined $W->{$_}; } for ("accept");
 157         do { $W->{$_}=$ENV{"HTTP_USER_AGENT"} if !defined $W->{$_}; } for ("user_agent");
 158
 159         $W->{"browser"}=HTTP::BrowserDetect->new($W->{"user_agent"});
 160
 161         if (!defined $W->{"have_style"}) {
 162                 $W->{"have_style"}=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0);
 163                 }
 164
 165         $W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0);
 166         if ($W->{"detect_js"} && !$W->{"have_js"}) {
 167                 $W->{"head"}.='<script type="text/javascript" src="'.top_dir('/have_js.js.pl').'"></script>'."\n";
 168                 }
 169
 170         do { args_check(%$_) if $_; } for ($W->{"args_check"});
 171
 172         return $W;
 173 }
 174
 175 sub top_dir_disk ()
 176 {
 177         do { return $_ if $_; } for ($W->{"top_dir"});
 178         return $INC[0]; # fallback
 179 }
 180
 181 sub top_dir (;$)
 182 {
 183 my($in)=@_;
 184
 185         if (my $uri=$ENV{"REQUEST_URI"}) {
 186                 if ($W->{"args"}{"Wabs"}) {
 187                         # FIXME: $in may not be defined here!
 188                         # to prevent: Use of uninitialized value in ...
 189                         if ($in=~m#^/#) {
 190                                 $in=~s#^/*##;
 191                                 }
 192                         else {
 193                                 $in=$ENV{"REQUEST_URI"}."/".$in;
 194                                 $in=~tr#/#/#s;
 195                                 1 while $in=~s#/(?:[^/]+)/\Q..\E/#/#g
 196                                 }
 197                         return "http://".&{$W->{"web_hostname_sub"}}()."/".(defined $in ? $in : "");
 198                         }
 199                 $uri.="Index" if $uri=~m#/$#;
 200                 if (defined $in) {
 201                         my($inpath,$inquery)=split /[?]/,$in,2;
 202                         $inpath=~tr///cs;
 203                         $uri=~tr///cs;
 204                         for (;;) {
 205                                 my($in1 ,$in2 )=($in =~m#^(/[^/]+)(/.*)$#);
 206                                 my($uri1,$uri2)=($uri=~m#^(/[^/]+)(/.*)$#);
 207                                 last if !defined $in1 || !defined $uri1 || $in1 ne $uri1;
 208                                 $in=$in2;
 209                                 $uri=$uri2;
 210                                 }
 211                         }
 212                 $uri=~s#^/*##;
 213                 $uri=~s#[^/]+#..#g;
 214                 $uri=File::Basename::dirname($uri);
 215                 my $r=$uri.(defined $in ? $in : "");
 216 #               1 while $r=~s#^[.]/##;
 217 #               $r="./$r" if $r=~m#^(?:?.*)$#;  # empty pathname?
 218                 return $r;
 219                 }
 220         return top_dir_disk().$in;
 221 }
 222
 223 sub fatal (;$);
 224
 225 sub args_check (%)
 226 {
 227 my(%tmpl)=@_;
 228
 229         while (my($name,$regex)=each(%tmpl)) {
 230                 my $name_html="Parameter <span class=\"quote\">".CGI::escapeHTML($name)."</span>";
 231                 $W->{"args"}{$name}="" if !defined $W->{"args"}{$name};
 232                 $W->{"args"}{$name}=[ $W->{"args"}{$name} ] if !ref $W->{"args"}{$name} && ref $regex;
 233                 fatal "$name_html passed as multivar although singlevar expected"
 234                                 if ref $W->{"args"}{$name} && !ref $regex;
 235                 $regex=${$regex}[0] if ref $regex;
 236                 for my $val (!ref $W->{"args"}{$name} ? $W->{"args"}{$name} : @{$W->{"args"}{$name}}) {
 237                         $val="" if !defined $val;
 238                         fatal "$name_html <span class=\"quote\">".CGI::escapeHTML($val)."</span>"
 239                                                         ." does not match the required regex <span class=\"quote\">".CGI::escapeHTML($regex)."</span> "
 240                                         if $regex ne "" && $val!~/$regex/;
 241                         }
 242                 }
 243 }
 244
 245 sub vskip (;$)
 246 {
 247 my($height)=@_;
 248
 249         return '<p'.(!defined $height ? "" : ' style="height: '.$height.';"').'>&nbsp;</p>'."\n";
 250 }
 251
 252 sub fatal (;$)
 253 {
 254 my($msg)=@_;
 255
 256         $msg="UNKNOWN" if !$msg;
 257
 258         $W->{"indexme"}=0;      # For the case no heading was sent yet.
 259         My::Web->heading();
 260         print "\n".vskip("3ex")."<hr /><h1 class=\"error\">FATAL ERROR: $msg!</h1>\n"
 261                         ."<p>You can report this problem's details to"
 262                         ." ".a_href("mailto:".$W->{"admin_mail"},"admin of this website").".</p>\n";
 263         footer();
 264 }
 265
 266 sub footer (;$)
 267 {
 268         exit 1 if $W->{"footer_passed"}++;      # deadlock prevention:
 269
 270         print vskip if $W->{"footer_delimit"};
 271
 272         if ($W->{"heading"}) {
 273                 do { &{$_}() if $_; } for ($W->{"footing_delimit"});
 274                 }
 275
 276         print "<hr />\n" if $W->{"footer"};
 277
 278         if ($W->{"footer_mailme"}) {
 279                 print '<form action="'.top_dir('/SendMsg.pl').'" method="post" onsubmit="'
 280                                 ."this.elements['msgscript'].value=this.elements['msghtml'].value;"
 281                                 ."this.elements['msghtml'].value='';"
 282                                 ."this.submit();"
 283                                 .'">'."\n";
 284                         print '<p align="right">'."\n";
 285                                 print '<input name="msgscript" type="hidden" />'."\n";
 286                                 print '<input name="msghtml" type="text" size="32" alt="Message" />'."\n";
 287                                 print '<input name="submit" type="submit" value="Quick Note" />'."\n";
 288                         print '</p>'."\n";
 289                 print '</form>'."\n";
 290                 }
 291
 292         if ($W->{"footer_ids"}) {
 293                 print '<p class="cvs-id">';
 294                 print join("<br />\n",map({ my $package=$_;
 295                         my $cvs_id=(eval('$'.$package."::CVS_ID")
 296 #                                       || $package     # debug
 297                                         );
 298                         if (!$cvs_id) {
 299                                 ();
 300                                 }
 301                         else {
 302                                 $cvs_id='$'.$cvs_id.'$';        # Eaten by 'q' operator.
 303                                 my @cvs_id_split=split / +/,$cvs_id;
 304                                 if (@cvs_id_split==8) {
 305                                         my $file=$package;
 306                                         $file=~s#::#/#g;
 307                                         my $ext;
 308                                         for (qw(.html.pl .pl .pm),"") {
 309                                                 $ext=$_;
 310                                                 last if -r top_dir_disk()."/$file$ext";
 311                                                 cluck "Class file $file not found" if !$ext;
 312                                                 }
 313                                         $file.=$ext;
 314                                         $cvs_id_split[2]=""
 315                                                         .a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $W->{"viewcvs"}))[0]."$file?rev=".$cvs_id_split[2],
 316                                                                         $cvs_id_split[2]);
 317                                         $cvs_id_split[1]=a_href($W->{"viewcvs"}.$file,
 318                                                         ($package!~/^Apache::/ ? $package : $cvs_id_split[1]));
 319                                         $cvs_id_split[5]=&{$W->{"cvs_id_author"}}($cvs_id_split[5]);
 320                                         }
 321                                 join " ",@cvs_id_split;
 322                                 }
 323                         } (
 324                                         $W->{"__PACKAGE__"},
 325                                         __PACKAGE__,
 326                                         @{$W->{"packages_used"}{$Apache::Registry::curstash}},
 327                                         )));
 328                 print "</p>\n";
 329                 }
 330
 331         for my $package (
 332                         $W->{"__PACKAGE__"},
 333                         __PACKAGE__,
 334                         @{$W->{"packages_used"}{$Apache::Registry::curstash}},
 335                         ) {
 336                 my $cvs_id=(eval('$'.$package."::CVS_ID")
 337 #                               || $package     # debug
 338                                 );
 339                 print '<!-- '.$package.' - $'.$cvs_id.'$ -->'."\n" if $cvs_id;
 340                 }
 341
 342         if ($W->{"heading"}) {
 343                 do { &{$_}() if $_; } for ($W->{"footing"});
 344                 }
 345
 346         print "</body></html>\n";
 347         exit(0);
 348 }
 349
 350 sub header (%)
 351 {
 352 my(%pairs)=@_;
 353
 354         while (my($key,$val)=each(%pairs)) {
 355                 do { cluck "Headers already sent"; next; } if $W->{"heading_done"};
 356                 for ($W->{"headers_lc"}{lc $key} || ()) {
 357                         delete $W->{"headers"}{$_};
 358                         }
 359                 $W->{"headers_lc"}{lc $key}=$key;
 360                 $W->{"headers"}{$key}=$val;
 361                 }
 362 }
 363
 364 sub size_display ($)
 365 {
 366 my($size)=@_;
 367
 368            if ($size<4096)
 369                 {}
 370         elsif ($size<1024*1024)
 371                 { $size=sprintf "%.1fK",$size/1024; }
 372         else
 373                 { $size=sprintf "%.1fM",$size/1024/1024; }
 374         $size.="B";
 375         return $size;
 376 }
 377
 378 sub url_is_local ($)
 379 {
 380 my($url)=@_;
 381
 382         return $url!~m#^[a-z]+://#;
 383 }
 384
 385 sub a_href ($;$%)
 386 {
 387 my($url,$contents,%args)=@_;
 388
 389         do { $$_=1 if !defined $$_; } for (\$args{"size"});
 390         if (!defined $contents) {
 391                 $contents=$url;
 392                 $contents=File::Basename::basename($contents) if $args{"basename"};
 393                 $contents=CGI::escapeHTML($contents);
 394                 }
 395         $contents=~s#<a\b[^>]*>##gi;
 396         $contents=~s#</a>##gi;
 397
 398         $url=top_dir($url) if url_is_local $url && $url=~m#^/#;
 399
 400         my $r='<a href="';
 401         my $urlent=CGI::escapeHTML($url);
 402            if ($url eq $urlent)
 403                 { $r.=$url; }
 404         elsif (url_is_local $url)
 405                 { $r.=$urlent; }
 406         elsif (defined $W->{"have_ent"} && !$W->{"have_ent"})   # non-ent client
 407                 { $r.=$url; }
 408         elsif ($W->{"have_ent"})        # ent client
 409                 { $r.=$urlent; }
 410         else    # unknown client, &CGI::escapeHTML should not be needed here
 411                 { $r.=CGI::escapeHTML(top_dir('/Redirect.pl?location='.uri_escape($url))); }
 412         $r.='"';
 413         do { $r.=" $_" if $_; } for ($args{"attr"});
 414         $r.='>'.$contents.'</a>';
 415         if ($args{"size"} && url_is_local($url) && ($args{"size"}>=2 || $url=~/[.](?:gz|Z|rpm|zip|deb|lha)/)) { # Downloadable?
 416                 $url=top_dir_disk().$url if $url=~m#^/#;
 417                 if (!-r $url)
 418                         { cluck "File not readable: $url"; }
 419                 else {
 420                         $r.='&nbsp;('.size_display((stat($url))[7]).')';
 421                         }
 422                 }
 423         return $r;
 424 }
 425
 426 sub remote_ip ()
 427 {
 428         # Do not: PerlModule                 Apache::ForwardedFor
 429         #         PerlPostReadRequestHandler Apache::ForwardedFor
 430         # As 'Apache::ForwardedFor' takes the first of $ENV{"HTTP_X_FORWARDED_FOR"}
 431         # while the contents is '127.0.0.1, 213.220.195.171' if client has its own proxy.
 432         # We must take the last item ourselves.
 433         my $r=$ENV{"HTTP_X_FORWARDED_FOR"} || $W->{"r"}->get_remote_host();
 434         $r=~s/^.*,\s*//;
 435         return $r;
 436 }
 437
 438 sub is_cz ()
 439 {
 440         return 0 if !$have_Geo_IP;
 441         return "CZ" eq Geo::IP->new()->country_code_by_addr(remote_ip());
 442 }
 443
 444 sub a_href_cz ($$;%)
 445 {
 446 my($url,$contents,%args)=@_;
 447
 448         return a_href $url,$contents,%args if is_cz();
 449         return $contents;
 450 }
 451
 452 sub make ($)
 453 {
 454 my($cmd)=@_;
 455
 456         system {'flock'} 'flock','-x',top_dir_disk(),$cmd.' >&2';
 457 }
 458
 459 sub img_size ($$)
 460 {
 461 my($width,$height)=@_;
 462
 463         return ($W->{"have_style"} ? "style=\"border:0;width:${width}px;height:${height}px\"" : "border=\"0\"")
 464                         ." width=\"$width\" height=\"$height\"";
 465 }
 466
 467 sub negotiate_variant (%)
 468 {
 469 my(%args)=@_;
 470
 471         my @fields=("id","qs","content-type","encoding","charset","lang","size");
 472         return [ map(($args{$_}),@fields) ];
 473 }
 474
 475 my @img_variants=(
 476                 { "id"=>"png","qs"=>1.0,"content-type"=>"image/png" },
 477                 { "id"=>"gif","qs"=>0.9,"content-type"=>"image/gif" },
 478                 );
 479 my $img_variants_re='[.](?:'.join('|',"jpeg",map(($_->{"id"}),@img_variants)).')$';
 480
 481 sub img_src ($)
 482 {
 483 my($file_base)=@_;
 484
 485         if (!url_is_local($file_base)) {
 486                 return $file_base if !wantarray();
 487                 return ($file_base,$file_base);
 488                 }
 489         # Known image extension?
 490         if ($file_base=~m#$img_variants_re#o) {
 491                 return $file_base if !wantarray();
 492                 return ($file_base,$file_base) if $file_base!~m#^/#;
 493                 return (top_dir($file_base),top_dir_disk().$file_base);
 494                 }
 495
 496         my $file_base_disk;
 497         my $file_base_uri;
 498         if ($file_base!~m#^/#) {
 499                 $file_base_disk=$file_base_uri=$file_base;
 500                 }
 501         else {
 502                 $file_base_disk=top_dir_disk().$file_base;
 503                 $file_base_uri=top_dir($file_base);
 504                 }
 505
 506         my @nego_variants;
 507         for my $var (@img_variants) {
 508                 my $file=$file_base_disk.".".$var->{"id"};
 509                 # TODO: Somehow quickly check dependencies?
 510                 make('make -s --no-print-directory'
 511                                                 .' -C '."'".File::Basename::dirname($file)."' '".File::Basename::basename($file)."'")
 512                                 if !-f $file;
 513                 push @nego_variants,negotiate_variant(
 514                                 %$var,
 515                                 "size"=>(stat $file)[7],
 516                                 );
 517                 }
 518         # Do not: ,$W->{"r"});
 519         # but should we provide somehow either 'HTTP::Headers' or 'HTTP::Request' ?
 520         my $ext=HTTP::Negotiate::choose(\@nego_variants);
 521         $ext||=$img_variants[0]->{"id"};        # &HTTP::Negotiate::choose failed?
 522
 523         return $file_base_uri.".".$ext if !wantarray();
 524         return ($file_base_uri.".".$ext,$file_base_disk.".".$ext);
 525 }
 526
 527 sub img ($$;%)
 528 {
 529 my($file_base,$alt,%attr)=@_;
 530
 531         my($file_uri,$file_disk)=img_src $file_base;
 532         my($width,$height)=Image::Size::imgsize($file_disk);
 533         $alt=~s/<[^>]*>//g;
 534         $alt=CGI::escapeHTML($alt);
 535         my $content="<img src=\"$file_uri\" alt=\"$alt\" title=\"$alt\" ".img_size($width,$height)
 536                         .(!$attr{"attr"} ? "" : " ".$attr{"attr"})." />";
 537         return a_href img_src($attr{"a_href_img"}),$content if $attr{"a_href_img"};
 538         return a_href $attr{"a_href"},$content if $attr{"a_href"};
 539         return $content;
 540 }
 541
 542 sub centerimg
 543 {
 544         my $r.="";
 545         $r.='<table border="0" width="100%"><tr>'."\n";
 546         @_=( [@_] ) if !ref $_[0];
 547         for (@_) {
 548                 $r.="\t".'<td align="center">'.&{\&img}(@$_).'</td>'."\n";
 549                 }
 550         $r.='</tr></table>'."\n";
 551         return $r;
 552 }
 553
 554 sub rightimg
 555 {
 556 my($text,@args_img)=@_;
 557
 558         # Workaround bug of 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)':
 559         return <<"HERE";
 560 <table border="0" width="100%">
 561         <col width="@{[ (!$W->{"browser"}->ie() ? "1*" : "90%" ) ]}" />
 562         <col width="@{[ (!$W->{"browser"}->ie() ? "0*" : "10%" ) ]}" />
 563         <tr>
 564                 <td align="left">
 565                         @{[ $text ]}
 566                 </td>
 567                 <td align="right">
 568                         @{[ &{\&img}(@args_img) ]}
 569                 </td>
 570         </tr>
 571 </table>
 572 HERE
 573 }
 574
 575 sub readfile ($$)
 576 {
 577 my($class,$filename)=@_;
 578
 579         local *F;
 580         open F,$filename or die "Cannot open \"$filename\": $!";
 581         local $/=undef();
 582         my $data=<F>;
 583         close F;
 584         return $data;
 585 }
 586
 587 sub arr_keys (@)
 588 {
 589 my(@arr)=@_;
 590
 591         my @r=();
 592         while (@arr) {
 593                 push @r,shift @arr;     # key
 594                 shift @arr;     # val
 595                 }
 596         return @r;
 597 }
 598
 599 sub heading ()
 600 {
 601 my($class)=@_;
 602
 603         return if $W->{"heading_passed"}++;
 604
 605         # $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!)
 606         my $client_charset=$W->{"force_charset"} || "us-ascii";
 607         header("Content-Style-Type"=>"text/css");
 608         header("Content-Script-Type"=>"text/javascript");
 609
 610         while (my($key,$val)=each(%{$W->{"headers"}})) {
 611                 $W->{"r"}->header_out($key,$val);
 612                 }
 613         $W->{"r"}->send_http_header("text/html; charset=$client_charset");      # "Content-type"; do not use header()
 614
 615         return if $W->{"heading_done"}++;
 616         exit if $W->{"r"}->header_only();
 617
 618         if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn
 619                 print '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n";
 620                 }
 621         print '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">'."\n";
 622         print '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en-US">'."\n";
 623         my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ())));
 624         $title=~s#<[^>]*>##g;
 625         print "<head>";
 626         print "<title>$title</title>\n";
 627
 628         if ($W->{"have_css"}) {
 629                 print <<'HERE';
 630 <style type="text/css"><!--
 631 .cvs-id   { font-family: monospace; }
 632 .error    { color: red;   background-color: transparent; }
 633 .quote    { font-family: monospace; }
 634 .nowrap   { white-space: nowrap; }
 635 .centered { text-align: center; }
 636 .tab-bold { font-weight: bold; }
 637 .tab-head { font-weight: bold; }
 638 /*
 639 .tab-head { font-weight: bold; color: yellow; background-color: transparent; }
 640 body {
 641                 background-color: black;
 642                 color: white;
 643                 }
 644 :link    { color: aqua;   background-color: transparent; }
 645 :visited { color: teal;   background-color: transparent; }
 646 h1,h2    { color: yellow; background-color: transparent; }
 647 */
 648 td       { padding: 2px; }
 649 caption  { caption-side: bottom; }
 650 .footer img { vertical-align: middle; }
 651 HERE
 652                 print $W->{"head_css"}."\n";
 653                 print "--></style>\n";
 654                 }
 655
 656         print '<meta name="robots" content="'.($W->{"indexme"} ? "" : "no" ).'index,follow" />'."\n";
 657         print $W->{"head"};
 658         for my $type (qw(prev next index contents start up)) {
 659                 do { print '<link rel="'.$type.'" href="'.$_.'" />'."\n" if $_; } for ($W->{"rel_$type"});
 660                 }
 661         print "</head><body";
 662 #       print ' bgcolor="black" text="white" link="aqua" vlink="teal"'
 663 #                       if $W->{"browser"}->netscape() && (!$W->{"browser"}->major() || $W->{"browser"}->major()<=4);
 664         print ">\n";
 665
 666         if ($W->{"heading"}) {
 667                 do { &{$_}() if $_; } for ($W->{"heading"});
 668                 }
 669 }
 670
 671 1;