X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=e41a314f3d09e47f2d524abca9ba690d5df97d32;hp=957507fa52aa2700fee2095d8cb0b39339a1139e;hb=633dc05b0519d86762bd084d872d34f9183237e0;hpb=b04e153c27986d315a3eacae5440b2bdc554c40d diff --git a/Web.pm b/Web.pm index 957507f..e41a314 100644 --- a/Web.pm +++ b/Web.pm @@ -1,5 +1,3 @@ -#! /usr/bin/perl -# # $Id$ # Common functions for HTML/XHTML output generation # Copyright (C) 2003 Jan Kratochvil @@ -20,161 +18,219 @@ package My::Web; require 5.6.0; # at least 'use warnings;' but we need some 5.6.0+ modules anyway -use vars qw($VERSION); -$VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; +our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; +our $CVS_ID=q$Id$; use strict; use warnings; -use WebConfig; # for %WebConfig +use Exporter; +sub Wrequire ($); +sub Wuse ($@); +our $W; +our @EXPORT=qw(&Wrequire &Wuse &a_href &a_href_cz &vskip &img ¢erimg &rightimg $W &top_dir &top_dir_disk); +our @ISA=qw(Exporter); + +BEGIN +{ + sub Wrequire ($) + { + my($file)=@_; + +# print STDERR "Wrequire $file\n"; + $file=~s#/#::#g; + $file=~s/[.]pm$//; + my $class=$file; + $file=~s#::#/#g; + $file.=".pm"; + my $aref=($W->{"packages_used"}{$Apache::Registry::curstash}||=[]); + push @$aref,$class + if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries. + CORE::require $file; + 1; # Otherwise 'require' would already file above. + } + + sub Wuse ($@) + { + my($file,@list)=@_; + +# print STDERR "Wuse $file\n"; + Wrequire $file; + local $Exporter::ExportLevel=$Exporter::ExportLevel+1; + $file->import(@list); + 1; + } +} + +BEGIN { Wuse 'WebConfig'; } # for %WebConfig require CGI; # for &escapeHTML require Image::Size; # for &imgsize use File::Basename; # &basename +use Carp qw(cluck confess); +use URI::Escape; +require HTTP::BrowserDetect; +require HTTP::Negotiate; +require Geo::IP; +require CGI; + + +# Undo 'www/engine/httpd-restart' as it may use obsolete Perl for 'mod_perl' +delete $ENV{"PERLLIB"}; +delete $ENV{"LD_LIBRARY_PATH"}; + + +#our $W; + # $W->{"title"} + # $W->{"head"} + # $W->{"head_css"} + # $W->{"force_charset"} + # %{$W->{"packages_used"} + # $W->{"heading_done"} + # $W->{"footer_passed"} + # %{$W->{"headers"}} + # %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key + # @{$W->{"packages_used"}{$Apache::Registry::curstash}}} + # %{$W->{"args"}} - -my %Args; - # $Args{"title"} - # $Args{"force_charset"} - -my $cvs_id_html; sub init ($%) { my($class,%args)=@_; - %WebConfig=(%WebConfig,%args); # override %WebConfig settings + my $packages_used_save=$W->{"packages_used"}; + $W={ %WebConfig,%args }; # override %WebConfig settings + $W->{"packages_used"}=$packages_used_save; + + $W->{"__PACKAGE__"}||="Apache::ROOT".$Apache::Registry::curstash; + + $W->{"top_dir"}||=eval '$'.$W->{"__PACKAGE__"}.'::top_dir'; + + do { $W->{$_}=0 if !defined $W->{$_}; } for ("detect_ent"); + do { $W->{$_}=0 if !defined $W->{$_}; } for ("detect_js"); + do { $W->{$_}=1 if !defined $W->{$_}; } for ("have_css"); # AFAIK it does not hurt anyone. + do { $W->{$_}=1 if !defined $W->{$_}; } for ("heading"); + do { $W->{$_}=1 if !defined $W->{$_}; } for ("footer"); + do { $W->{$_}=1 if !defined $W->{$_}; } for ("footer_delimit"); + do { $W->{$_}=1 if !defined $W->{$_}; } for ("footer_mailme"); + do { $W->{$_}=1 if !defined $W->{$_}; } for ("footer_ids"); + do { $W->{$_}=1 if !defined $W->{$_}; } for ("indexme"); + do { $W->{$_}="" if !defined $W->{$_}; } for ("head"); + do { $W->{$_}="" if !defined $W->{$_}; } for ("head_css"); + + my $footer_any=0; + for (qw(footer_mailme footer_ids)) { + $W->{$_}=0 if !$W->{"footer"}; + $footer_any=1 if $W->{$_}; + } + $W->{"footer"}=0 if !$footer_any; + $W->{"footer_delimit"}=0 if !$W->{"footer"}; + + $W->{"r"}=Apache->request(); + + $W->{"QUERY_STRING"}=$W->{"r"}->args() || ""; + if ($W->{"QUERY_STRING"}=~/[&]amp;have_ent/) + { $W->{"have_ent"}=0; } + elsif ($W->{"QUERY_STRING"}=~ /[&]have_ent/) + { $W->{"have_ent"}=1; } + else + { delete $W->{"have_ent"}; } + if ($W->{"detect_ent"} && !defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") { + $W->{"head"}.='{"web_hostname_sub"}}()."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0] + ."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect') + .'" />'."\n"; + } + $W->{"QUERY_STRING"}=~s/([&])amp;/$1/g; + $W->{"r"}->args($W->{"QUERY_STRING"}); + $ENV{"QUERY_STRING"}=$W->{"QUERY_STRING"}; + # Do not: $W->{"r"}->args() + # as it parses only QUERY_STRING (not POST data). + $W->{"args"}={ CGI->new()->Vars() }; + for (keys(%{$W->{"args"}})) { + my @vals=split /\x00/,$W->{"args"}{$_}; + next if @vals<=1; + $W->{"args"}{$_}=[@vals]; + } + + do { $W->{$_}=$ENV{"HTTP_ACCEPT"} if !defined $W->{$_}; } for ("accept"); + do { $W->{$_}=$ENV{"HTTP_USER_AGENT"} if !defined $W->{$_}; } for ("user_agent"); + + $W->{"browser"}=HTTP::BrowserDetect->new($W->{"user_agent"}); + + if (!defined $W->{"have_style"}) { + $W->{"have_style"}=(!$W->{"browser"}->netscape() || $W->{"browser"}->major>4 ? 1 : 0); + } - undef $WebConfig{"viewcvs"} if $ENV{"SCRIPT_NAME"} && $WebConfig{"viewcvs"} eq $ENV{"SCRIPT_NAME"}; - my @cvs_id_split=split / +/,$::CVS_ID; - if (@cvs_id_split==8) { - $cvs_id_split[2]="" - ."" - .$cvs_id_split[2].""; - $cvs_id_split[1]="".$cvs_id_split[1].""; - $cvs_id_split[5]="".$cvs_id_split[5].""; + $W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0); + if ($W->{"detect_js"} && !$W->{"have_js"}) { + $W->{"head"}.=''."\n"; } - $cvs_id_html=join " ",@cvs_id_split; + + do { args_check(%$_) if $_; } for ($W->{"args_check"}); + + return $W; } -sub print_project ($) +sub top_dir_disk () { -my($class,$ListItem)=@_; - - print "

".$ListItem->{"name"}."

\n"; - print $ListItem->{"description"}; - print "
\n"; - my @table=( - {"key"=>qr(^download\b.*),"text"=>sub ($) { - $_[0]=~s/^download//; - $_[0]=~s/^-/ /; - return "Download".$_[0]; - }, - "format"=>sub ($) { - my $r; - if ($_[0]=~m#^[a-z]+://#) { - $r="".CGI::escapeHTML($_[0]).""; - } - else { - $r="".CGI::escapeHTML(basename($_[0])).""; - my $size=(stat $_[0])[7]; - die "Cannot stat \"".$_[0]."\": $!" if !defined $size; - if ($size>=1024*1024) { $size=int($size/(1024*1024))." MB"; } - elsif ($size>=1024 ) { $size=int($size/(1024 ))." KB"; } - else { $size=int($size )." B"; } - $r.=" ($size)"; - } - return $r; - }}, - {"key"=>qr(^link\b.*),"text"=>sub ($) { - $_[0]=~s/^link-//; - return $_[0]; - }, - "format"=>sub ($) { - return "".CGI::escapeHTML($_[0]).""; - }}, - {"key"=>"summary","text"=>"Summary"}, - {"key"=>"ownership","text"=>"Ownership"}, - {"key"=>"license","text"=>"License","format"=>sub ($) { - my %known=( - "PD"=>"Public Domain", - "GPL"=>"GNU General Public License", - "LGPL"=>"GNU Lesser General Public License", - ); - return $known{$_[0]}; - }}, - {"key"=>"maintenance","text"=>"Currently maintained?","format"=>sub ($) { - my %known=( - "finished"=>"Project is finished. Possible bug reports welcome although project not actively developed.", - "dead"=>"Project became dead code, some updates would be required. It is no longer used, project is not supported.", - "obsolete"=>"Obsolete as some other existing package superseded this one.", - "merge"=>"Functions of this package should be merged to some other one.", - "update"=>"Package needs updating to be fully usable, patches welcome.", - "accepted"=>"This patch was accepted by the original package author. It has no longer any separate meaning.", - ); - return $known{$_[0]}; - }}, - {"key"=>"reason","text"=>"Reason"}, - {"key"=>"sponsorship","text"=>"Sponsoring Company"}, - {"key"=>"language","text"=>"Programming language","format"=>sub ($) { - return "".CGI::escapeHTML($_[0])."" - if $_[0]=~/^Java\b/; - return "".CGI::escapeHTML($_[0])."" - if $_[0]=~/^PHP\b/; - return undef(); - }}, - ); - print ''."\n"; + do { return $_ if $_; } for ($W->{"top_dir"}); + return $INC[0]; # fallback +} -sub tableit_func +sub top_dir (;$) { -my($tableit,$val,$key,$ListItem)=@_; - - print ""; - if ($tableit->{"format"}) { - my $format=$tableit->{"format"}; - my $valn=&$format($val); - $val=$valn if defined $valn; +my($in)=@_; + + if (my $uri=$ENV{"REQUEST_URI"}) { + $uri.="Index" if $uri=~m#/$#; + if (defined $in) { + my($inpath,$inquery)=split /[?]/,$in,2; + $inpath=~tr///cs; + $uri=~tr///cs; + for (;;) { + my($in1 ,$in2 )=($in =~m#^(/[^/]+)(/.*)$#); + my($uri1,$uri2)=($uri=~m#^(/[^/]+)(/.*)$#); + last if !defined $in1 || !defined $uri1 || $in1 ne $uri1; + $in=$in2; + $uri=$uri2; + } + } + $uri=~s#^/*##; + $uri=~s#[^/]+#..#g; + $uri=File::Basename::dirname($uri); + my $r=$uri.(defined $in ? $in : ""); +# 1 while $r=~s#^[.]/##; +# $r="./$r" if $r=~m#^(?:?.*)$#; # empty pathname? + return $r; } - print "\n"; - delete $ListItem->{$key}; + return top_dir_disk().$in; } - for my $tableit (@table) { - if (!ref $tableit->{"key"}) { - tableit_func($tableit,$ListItem->{$tableit->{"key"}},$tableit->{"key"},$ListItem) if $ListItem->{$tableit->{"key"}}; - } - else { - for my $key (keys(%$ListItem)) { - my $keyregex=$tableit->{"key"}; - next if $key!~/$keyregex/; - tableit_func($tableit,$ListItem->{$key},$key,$ListItem); - } +sub fatal (;$); + +sub args_check (%) +{ +my(%tmpl)=@_; + + while (my($name,$regex)=each(%tmpl)) { + my $name_html="Parameter ".CGI::escapeHTML($name).""; + $W->{"args"}{$name}="" if !defined $W->{"args"}{$name}; + $W->{"args"}{$name}=[ $W->{"args"}{$name} ] if !ref $W->{"args"}{$name} && ref $regex; + fatal "$name_html passed as multivar although singlevar expected" + if ref $W->{"args"}{$name} && !ref $regex; + $regex=${$regex}[0] if ref $regex; + for my $val (!ref $W->{"args"}{$name} ? $W->{"args"}{$name} : @{$W->{"args"}{$name}}) { + $val="" if !defined $val; + fatal "$name_html ".CGI::escapeHTML($val)."" + ." does not match the required regex ".CGI::escapeHTML($regex)." " + if $regex ne "" && $val!~/$regex/; } } - print "
"; - if (!ref $tableit->{"text"}) { - print $tableit->{"text"}; - } - else { - my $textfunc=$tableit->{"text"}; - my $key=$key; - print &$textfunc($key); - } - print ":$val
\n"; - print "

 

\n"; } -# $args{"ListItem"}=\%...; -sub init_project ($%) +sub vskip (;$) { -my($class,%args)=@_; +my($height)=@_; - my $ListItem=$args{"ListItem"}; - my $name=$ListItem->{"name"}; - $name=~s#]*>([^<]*)#$1#g; - init($class, - "title"=>$name, - %args); - heading(); - $class->print_project($ListItem); + return ' 

'."\n"; } sub fatal (;$) @@ -183,66 +239,316 @@ my($msg)=@_; $msg="UNKNOWN" if !$msg; -# heading(false/*title*/,false/*indexme*/); // notitle is always safe, don't index the error message - print("\n

 
 

FATAL ERROR: $msg!

\n" + $W->{"indexme"}=0; # For the case no heading was sent yet. + My::Web->heading(); + print "\n".vskip("3ex")."

FATAL ERROR: $msg!

\n" ."

You can report this problem's details to" - ." admin of this website.

\n"); -# footer(); + ." ".a_href("mailto:".$W->{"admin_mail"},"admin of this website").".

\n"; + footer(); } -my $footer_passed; sub footer (;$) { -my($delimit)=@_; + exit 1 if $W->{"footer_passed"}++; # deadlock prevention: - $delimit=1 if !defined $delimit; + print vskip if $W->{"footer_delimit"}; - exit(1) if $footer_passed++; # deadlock prevention: + if ($W->{"heading"}) { + do { &{$_}() if $_; } for ($W->{"footing_delimit"}); + } - if (0) { - print "

 

\n" if $delimit; - print "
\n

$cvs_id_html

\n"; + print "
\n" if $W->{"footer"}; + + if ($W->{"footer_mailme"}) { + print '
'."\n"; + print '

'."\n"; + print ''."\n"; + print ''."\n"; + print ''."\n"; + print '

'."\n"; + print '
'."\n"; } + + if ($W->{"footer_ids"}) { + print '

'; + print join("
\n",map({ my $package=$_; + my $cvs_id=(eval('$'.$package."::CVS_ID") +# || $package # debug + ); + if (!$cvs_id) { + (); + } + else { + $cvs_id='$'.$cvs_id.'$'; # Eaten by 'q' operator. + my @cvs_id_split=split / +/,$cvs_id; + if (@cvs_id_split==8) { + my $file=$package; + $file=~s#::#/#g; + my $ext; + for (qw(.html.pl .pl .pm),"") { + $ext=$_; + last if -r top_dir_disk()."/$file$ext"; + cluck "Class file $file not found" if !$ext; + } + $file.=$ext; + $cvs_id_split[2]="" + .a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $W->{"viewcvs"}))[0]."$file?rev=".$cvs_id_split[2], + $cvs_id_split[2]); + $cvs_id_split[1]=a_href($W->{"viewcvs"}.$file, + ($package!~/^Apache::/ ? $package : $cvs_id_split[1])); + $cvs_id_split[5]=&{$W->{"cvs_id_author"}}($cvs_id_split[5]); + } + join " ",@cvs_id_split; + } + } ( + $W->{"__PACKAGE__"}, + __PACKAGE__, + @{$W->{"packages_used"}{$Apache::Registry::curstash}}, + ))); + print "

\n"; + } + + for my $package ( + $W->{"__PACKAGE__"}, + __PACKAGE__, + @{$W->{"packages_used"}{$Apache::Registry::curstash}}, + ) { + my $cvs_id=(eval('$'.$package."::CVS_ID") +# || $package # debug + ); + print ''."\n" if $cvs_id; + } + + if ($W->{"heading"}) { + do { &{$_}() if $_; } for ($W->{"footing"}); + } + print "\n"; exit(0); } -my $heading_done; - -my %headers; -my %headers_lc; # maps lc($headers_key)=>$headers_key sub header (%) { my(%pairs)=@_; while (my($key,$val)=each(%pairs)) { - do { warn "Headers already sent"; next; } if $heading_done; - for ($headers_lc{lc $key} || ()) { - delete $headers{$_}; + do { cluck "Headers already sent"; next; } if $W->{"heading_done"}; + for ($W->{"headers_lc"}{lc $key} || ()) { + delete $W->{"headers"}{$_}; } - $headers_lc{lc $key}=$key; - $headers{$key}=$val; + $W->{"headers_lc"}{lc $key}=$key; + $W->{"headers"}{$key}=$val; } } +sub size_display ($) +{ +my($size)=@_; + + if ($size<4096) + {} + elsif ($size<1024*1024) + { $size=sprintf "%.1fK",$size/1024; } + else + { $size=sprintf "%.1fM",$size/1024/1024; } + $size.="B"; + return $size; +} + +sub url_is_local ($) +{ +my($url)=@_; + + return $url!~m#^[a-z]+://#; +} + +sub a_href ($;$%) +{ +my($url,$contents,%args)=@_; + + do { $$_=1 if !defined $$_; } for (\$args{"size"}); + $contents=CGI::escapeHTML($url) if !defined $contents; + $contents=~s#]*>##gi; + $contents=~s###gi; + + $url=top_dir($url) if url_is_local $url && $url=~m#^/#; + + my $r='{"have_ent"}) # non-ent client + { $r.=$url; } + elsif ($W->{"have_ent"}) # ent client + { $r.=$urlent; } + else # unknown client, &CGI::escapeHTML should not be needed here + { $r.=CGI::escapeHTML(top_dir('/Redirect.pl?location='.uri_escape($url))); } + $r.='"'; + do { $r.=" $_" if $_; } for ($args{"attr"}); + $r.='>'.$contents.''; + if ($args{"size"} && url_is_local($url) && $url=~/[.](?:gz|Z|rpm|zip|deb|lha)/) { # Downloadable? + $url=top_dir_disk().$url if $url=~m#^/#; + if (!-r $url) + { cluck "File not readable: $url"; } + else { + $r.=' ('.size_display((stat($url))[7]).')'; + } + } + return $r; +} + +sub remote_ip () +{ + # Do not: PerlModule Apache::ForwardedFor + # PerlPostReadRequestHandler Apache::ForwardedFor + # As 'Apache::ForwardedFor' takes the first of $ENV{"HTTP_X_FORWARDED_FOR"} + # while the contents is '127.0.0.1, 213.220.195.171' if client has its own proxy. + # We must take the last item ourselves. + my $r=$ENV{"HTTP_X_FORWARDED_FOR"} || $W->{"r"}->get_remote_host(); + $r=~s/^.*,\s*//; + return $r; +} + +sub is_cz () +{ + return "CZ" eq Geo::IP->new()->country_code_by_addr(remote_ip()); +} + +sub a_href_cz ($$;%) +{ +my($url,$contents,%args)=@_; + + return a_href $url,$contents,%args if is_cz(); + return $contents; +} + +sub make ($) +{ +my($cmd)=@_; + + system {'flock'} 'flock','-x',top_dir_disk(),$cmd.' >&2'; +} + sub img_size ($$) { my($width,$height)=@_; - return((1 #$have_style TODO:dyn - ? "style=\"border:0;width:${width}px;height:${height}px\"" : "border=\"0\"") - ." width=\"$width\" height=\"$height\""); + return ($W->{"have_style"} ? "style=\"border:0;width:${width}px;height:${height}px\"" : "border=\"0\"") + ." width=\"$width\" height=\"$height\""; +} + +sub negotiate_variant (%) +{ +my(%args)=@_; + + my @fields=("id","qs","content-type","encoding","charset","lang","size"); + return [ map(($args{$_}),@fields) ]; +} + +my @img_variants=( + { "id"=>"png","qs"=>1.0,"content-type"=>"image/png" }, + { "id"=>"gif","qs"=>0.9,"content-type"=>"image/gif" }, + ); +my $img_variants_re='[.](?:'.join('|',"jpeg",map(($_->{"id"}),@img_variants)).')$'; + +sub img_src ($) +{ +my($file_base)=@_; + + if (!url_is_local($file_base)) { + return $file_base if !wantarray(); + return ($file_base,$file_base); + } + # Known image extension? + if ($file_base=~m#$img_variants_re#o) { + return $file_base if !wantarray(); + return ($file_base,$file_base) if $file_base!~m#^/#; + return (top_dir($file_base),top_dir_disk().$file_base); + } + + my $file_base_disk; + my $file_base_uri; + if ($file_base!~m#^/#) { + $file_base_disk=$file_base_uri=$file_base; + } + else { + $file_base_disk=top_dir_disk().$file_base; + $file_base_uri=top_dir($file_base); + } + + my @nego_variants; + for my $var (@img_variants) { + my $file=$file_base_disk.".".$var->{"id"}; + # TODO: Somehow quickly check dependencies? + make('make -s --no-print-directory' + .' -C '."'".File::Basename::dirname($file)."' '".File::Basename::basename($file)."'") + if !-f $file; + push @nego_variants,negotiate_variant( + %$var, + "size"=>(stat $file)[7], + ); + } + # Do not: ,$W->{"r"}); + # but should we provide somehow either 'HTTP::Headers' or 'HTTP::Request' ? + my $ext=HTTP::Negotiate::choose(\@nego_variants); + $ext||=$img_variants[0]->{"id"}; # &HTTP::Negotiate::choose failed? + + return $file_base_uri.".".$ext if !wantarray(); + return ($file_base_uri.".".$ext,$file_base_disk.".".$ext); } -sub img ($$;$) +sub img ($$;%) { -my($file,$alt,$attrs)=@_; +my($file_base,$alt,%attr)=@_; - (my $file_det=$file)=~s/[.]mng$/.gif/; - my($width,$height)=Image::Size::imgsize($file_det); + my($file_uri,$file_disk)=img_src $file_base; + my($width,$height)=Image::Size::imgsize($file_disk); + $alt=~s/<[^>]*>//g; $alt=CGI::escapeHTML($alt); - return("\"$alt\""); + my $content="\"$alt\""; + return a_href img_src($attr{"a_href_img"}),$content if $attr{"a_href_img"}; + return a_href $attr{"a_href"},$content if $attr{"a_href"}; + return $content; +} + +sub centerimg +{ + my $r.=""; + $r.=''."\n"; + @_=( [@_] ) if !ref $_[0]; + for (@_) { + $r.="\t".''."\n"; + } + $r.='
'.&{\&img}(@$_).'
'."\n"; + return $r; +} + +sub rightimg +{ +my($text,@args_img)=@_; + + # Workaround bug of 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)': + return <<"HERE"; + + ie() ? "1*" : "90%" ) ]}" /> + ie() ? "0*" : "10%" ) ]}" /> + + + + +
+ @{[ $text ]} + + @{[ &{\&img}(@args_img) ]} +
+HERE } sub readfile ($$) @@ -257,37 +563,48 @@ my($class,$filename)=@_; return $data; } -sub heading (;$$) +sub arr_keys (@) { -my($class,$showtitle,$indexme)=@_; +my(@arr)=@_; - $showtitle=1 if !defined $showtitle; - $indexme=1 if !defined $indexme; + my @r=(); + while (@arr) { + push @r,shift @arr; # key + shift @arr; # val + } + return @r; +} + +sub heading () +{ +my($class)=@_; + + return if $W->{"heading_passed"}++; # $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!) - my $client_charset=$Args{"force_charset"} || "us-ascii"; - header("Content-type"=>"text/html; charset=$client_charset"); + my $client_charset=$W->{"force_charset"} || "us-ascii"; header("Content-Style-Type"=>"text/css"); + header("Content-Script-Type"=>"text/javascript"); - if ($ENV{"SERVER_SOFTWARE"}) { - while (my($key,$val)=each(%headers)) { - print "$key: $val\n"; - } - print "\n"; + while (my($key,$val)=each(%{$W->{"headers"}})) { + $W->{"r"}->header_out($key,$val); } + $W->{"r"}->send_http_header("text/html; charset=$client_charset"); # "Content-type"; do not use header() - return if $heading_done++; + return if $W->{"heading_done"}++; + exit if $W->{"r"}->header_only(); if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn print ''."\n"; } print ''."\n"; print ''."\n"; - print ''.CGI::escapeHTML($WebConfig{"title_prefix"}) - .join("",map({ ': '.CGI::escapeHTML($_); } ($WebConfig{"title"} || ()))) - .''."\n"; + my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ()))); + $title=~s#<[^>]*>##g; + print ""; + print "$title\n"; - if (1) { # || $have_css) # TODO:dyn + if ($W->{"have_css"}) { print <<'HERE'; \n"; } - print ''."\n"; - print $_ for ($WebConfig{"head"} || ()); + print ''."\n"; + print $W->{"head"}; + for my $type (qw(prev next index contents start up)) { + do { print ''."\n" if $_; } for ($W->{"rel_$type"}); + } print "{"browser"}->netscape() && $W->{"browser"}->major<=4; print ">\n"; -# if ($showtitle) -# print("

" -# ."Energie & Peníze") -# ."

\n"); + + if ($W->{"heading"}) { + do { &{$_}() if $_; } for ($W->{"heading"}); + } } 1;