X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=0cf0d3c86a82bf96c78feede5c3c74e853eca885;hb=d352d10efbc9a65e73c0dbf60753558b1010dc63;hp=6a4d6ab760a7c83dfd0c643b52e14101c405ba15;hpb=b07844180e9ec343d02f8ce7010e2d615560914f;p=MyWeb.git diff --git a/Web.pm b/Web.pm index 6a4d6ab..0cf0d3c 100644 --- a/Web.pm +++ b/Web.pm @@ -1,6 +1,6 @@ # $Id$ # Common functions for HTML/XHTML output generation -# Copyright (C) 2003 Jan Kratochvil +# Copyright (C) 2003-2005 Jan Kratochvil # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -24,14 +24,28 @@ use strict; use warnings; use Exporter; -sub Wrequire ($); -sub Wuse ($@); +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 &Wprint &input_hidden_persistents); -our @ISA=qw(Exporter Tie::Handle); +our @EXPORT=qw( + &Wrequire &Wuse + &path_web &path_abs_disk + &uri_escaped + &a_href &a_href_cz + &vskip + &img ¢erimg &rightimg + $W + &input_hidden_persistents + &escapeHTML + ); +our @ISA=qw(Tie::Handle Exporter); + +my %packages_used_hash; +my %packages_used_array; BEGIN { + use Carp qw(cluck confess); $W->{"__My::Web_init"}=1; sub Wrequire ($) @@ -44,14 +58,20 @@ BEGIN my $class=$file; $file=~s#::#/#g; $file.=".pm"; - my $who=$W->{"__PACKAGE__"}; - $who||="__My::Web" if $W->{"__My::Web_init"}; - if ($who) { - my $aref=($W->{"packages_used"}{$who}||=[]); - push @$aref,$class - if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries. + my %callers; + for (my $depth=0;defined caller($depth);$depth++) { + $callers{caller($depth)}=1; } - CORE::require $file; + my $selfpkg=__PACKAGE__; + $callers{$selfpkg}=1; + for my $target ($class,__PACKAGE__) { + for my $caller (keys(%callers)) { + next if $caller eq $target; + next if $packages_used_hash{$caller}{$target}++; + push @{$packages_used_array{$caller}},$target; + } + } + eval { CORE::require "$file"; } or confess $@; 1; # Otherwise 'require' would already file above. } @@ -65,10 +85,19 @@ BEGIN $file->import(@list); 1; } + + sub import + { + my($class,@rest)=@_; + + local $Exporter::ExportLevel=$Exporter::ExportLevel+1; + Wrequire("$class"); + return $class->SUPER::import(@rest); + } } -BEGIN { Wuse 'WebConfig'; } # for %WebConfig -require CGI; # for &escapeHTML +use WebConfig; # see also below: Wuse 'WebConfig'; +require CGI; require Image::Size; # for &imgsize use File::Basename; # &basename use Carp qw(cluck confess); @@ -81,9 +110,10 @@ my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; } # I do not know why. use POSIX qw(strftime); use Tie::Handle; -use Apache2::Const qw(HTTP_MOVED_TEMPORARILY); +use Apache2::Const qw(HTTP_MOVED_TEMPORARILY OK); use URI; use URI::QueryParam; +use Cwd; #our $W; @@ -94,32 +124,58 @@ use URI::QueryParam; # $W->{"footer_passed"} # %{$W->{"headers"}} # %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key - # @{$W->{"packages_used"}{$W->{"__PACKAGE__"}}} - # @{$W->{"packages_used"}{"__My::Web"}} # %{$W->{"args"}} +sub cleanup($) +{ +my($apache_request)=@_; + + # Sanity protection. + $W=undef(); + return OK; +} + +sub request_check(;$) +{ +my($self)=@_; + + # Use &eval to prevent: Global $r object is not available. Set:\n\tPerlOptions +GlobalRequest\nin ... + # CGI requires valid "r": check it beforehand here. + confess "Calling sensitive dynamic code from a static code" if !eval { Apache2::RequestUtil->request(); }; + # Do not: confess "Calling sensitive dynamic code without My::Web::init" if !$W->{"__PACKAGE__"}; + # as it is valid at least while preparing arguments to call: &project::Lib::init +} + sub init ($%) { my($class,%args)=@_; print STDERR "$class->init ".Apache2::RequestUtil->request()->unparsed_uri()."\n"; - my $packages_used_save=$W->{"packages_used"}; - $W={ %WebConfig,%args }; # override %WebConfig settings - $W->{"packages_used"}=$packages_used_save; + # We need to track package dependencies, so we need to call it from &init. + # We cannot do it in BEGIN { } block + # as it would not be tracked for each of the toplevel users later. + Wuse 'WebConfig'; + Wrequire 'My::Hash::Sub'; + + $W={}; + tie %$W,"My::Hash::Sub"; + %$W=(%WebConfig,%args); # override %WebConfig settings + $W->{"__PACKAGE__"}||=caller(); # {"__PACKAGE__"} is mandatory for mod_perl-2.0; # $Apache2::Registry::curstash is no longer supported. do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__"; - $W->{"top_dir"}||=eval '$'.$W->{"__PACKAGE__"}.'::top_dir'; + # See: &escapeHTML + do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset(); + CGI::charset("utf-8"); 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 ("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"); @@ -127,7 +183,7 @@ my($class,%args)=@_; do { $W->{$_}="en-US" if !defined $W->{$_}; } for ("language"); my $footer_any=0; - for (qw(footer_mailme footer_ids)) { + for (qw(footer_ids)) { $W->{$_}=0 if !$W->{"footer"}; $footer_any=1 if $W->{$_}; } @@ -136,6 +192,14 @@ my($class,%args)=@_; $W->{"r"}=Apache2::RequestUtil->request(); + $W->{"r"}->push_handlers("PerlCleanupHandler"=>\&cleanup); + + $W->{"web_hostname"}||=$W->{"r"}->hostname(); + + tie *STDOUT,$W->{"r"}; + select *STDOUT; + $|=1; + $W->{"QUERY_STRING"}=$W->{"r"}->args() || ""; if ($W->{"detect_ent"}) { if ($W->{"QUERY_STRING"}=~/[&]amp;have_ent/) @@ -146,7 +210,7 @@ my($class,%args)=@_; { delete $W->{"have_ent"}; } if (!defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") { $W->{"head"}.='{"web_hostname_sub"}}()."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0] + .escapeHTML("http://".$W->{"web_hostname"}."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0] ."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect') .'" />'."\n"; } @@ -164,8 +228,8 @@ my($class,%args)=@_; $W->{"args"}{$name}=[@vals]; } - do { $W->{$_}=$W->{"r"}->headers_in()->{"Accept"} if !defined $W->{$_}; } for ("accept"); - do { $W->{$_}=$W->{"r"}->headers_in()->{"User-Agent"} if !defined $W->{$_}; } for ("user_agent"); + do { $W->{$_}=$W->{"r"}->headers_in()->{"Accept"} if !defined $W->{$_}; } for ("accept"); + do { $W->{$_}=$W->{"r"}->headers_in()->{"User-Agent"}||"" if !defined $W->{$_}; } for ("user_agent"); $W->{"browser"}=HTTP::BrowserDetect->new($W->{"user_agent"}); @@ -175,21 +239,45 @@ my($class,%args)=@_; $W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0); if ($W->{"detect_js"} && !$W->{"have_js"}) { - $W->{"head"}.=''."\n"; + $W->{"head"}.=''."\n"; } - do { args_check(%$_) if $_; } for ($W->{"args_check"}); - - $ENV{"HOSTNAME"}||=&{$W->{"web_hostname_sub"}}(); + do { _args_check(%$_) if $_; } for ($W->{"args_check"}); return bless $W,$class; } -sub Wprint($) +# Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself. +# Do not: Wprint $W->{"heading"},"undef"=>1; +# as we would need to undef() it to turn it off and it would get defaulted in such case. +# Do not: exists $W->{"heading"} +# as we use a lot of 'for $W->{"heading"}' which instantiates it with the value: undef() +sub Wprint($%) +{ +my($text,%args)=@_; + + cluck "undef Wprint" if !defined $text && !$args{"undef"}; + delete $args{"undef"}; + cluck join(" ","Invalid arguments:",keys(%args)) if keys(%args); + $W->{"r"}->puts($text) if defined $text; +} + +sub escapeHTML($) { my($text)=@_; - $W->{"r"}->puts($text); + # Prevent &CGI::escapeHTML breaking utf-8 strings like: \xC4\x9B eq \x{11B} + # Prevent case if we run under mod_perl but still just initializing: + request_check() if $ENV{"MOD_PERL"}; + # Generally we are initialized from &init but we may be used without it without mod_perl + # and in such case check the change on all non-first invocations. + our $init; + if (!$ENV{"MOD_PERL"} && $init++) { + do { cluck "charset==$_" if $_ ne "utf-8"; } for CGI::charset(); + } + CGI::charset("utf-8"); + + return CGI::escapeHTML($text); } # local *FH; @@ -210,63 +298,103 @@ my($self,$scalar,$length,$offset)=@_; Wprint substr($scalar,0,$length); } -sub top_dir_disk () +# /home/user/www/webdir +sub dir_top_abs_disk() +{ + our $dir_top_abs_disk; + if (!$dir_top_abs_disk) { + my $selfpkg_relpath=__PACKAGE__; + $selfpkg_relpath=~s{::}{/}g; + $selfpkg_relpath.=".pm"; + my $selfpkg_abspath=$INC{$selfpkg_relpath} or do { + cluck "Unable to find self package $selfpkg_relpath"; + return; + }; + $selfpkg_abspath=~s{/*\Q$selfpkg_relpath\E$}{} or do { + cluck "Unable to strip myself \"$selfpkg_relpath\" from the abspath: $selfpkg_abspath"; + return; + }; + cluck "INC{myself} is relative?: $selfpkg_abspath" if $selfpkg_abspath!~m{^/}; + $dir_top_abs_disk=$selfpkg_abspath; + } + return $dir_top_abs_disk; +} + +sub unparsed_uri() { - do { return $_ if $_; } for ($W->{"top_dir"}); - return $INC[0]; # fallback + request_check(); + if (!$W->{"unparsed_uri"}) { + # Do not: $W->{"r"} + # as we may be called before &init from: &My::Project::init + my $r=Apache2::RequestUtil->request(); + cluck "Calling ".'&unparsed_uri'." from a static code, going to fail" if !$r; + my $uri_string=$r->unparsed_uri() or cluck "Valid 'r' missing unparsed_uri()?"; + my $uri=URI->new_abs($uri_string,"http://".$W->{"web_hostname"}."/"); + $W->{"unparsed_uri"}=$uri; + } + return $W->{"unparsed_uri"}; +} + +sub in_to_uri_abs($) +{ +my($in)=@_; + + # Otherwise we may have been already processed and thus legally relativized. + # FIXME data: Currently disabled, all the data are too violating such rule. + if (0 && !ref $in) { + my $uri_check=URI->new($in); + $uri_check->scheme() || $in=~m{^\Q./\E} || $in=~m{^/} + or cluck "Use './' or '/' prefix for all the local references: $in"; + } + my $uri=URI->new_abs($in,unparsed_uri()); + $uri=$uri->canonical(); + return $uri; } -# $args{"abs"} -sub top_dir (;$%) +# $args{"uri_as_in"}=1 to permit passing URI objects as: $in +# $args{"abs"}=1; +sub path_web($%) { my($in,%args)=@_; - if (my $uri=$W->{"r"}->unparsed_uri()) { - if ($W->{"args"}{"Wabs"} || $args{"abs"}) { - # FIXME: $in may not be defined here! - # to prevent: Use of uninitialized value in ... - if ($in=~m#^/#) { - $in=~s#^/*##; - } - else { - $in=$uri."/".$in; - $in=~tr#/#/#s; - 1 while $in=~s#/(?:[^/]+)/\Q..\E/#/#g - } - return "http://".&{$W->{"web_hostname_sub"}}()."/".(defined $in ? $in : ""); - } - $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; + cluck if !$args{"uri_as_in"} && ref $in; + my $uri=in_to_uri_abs($in); + if (uri_is_local($uri)) { + # Prefer the $uri values over "args_persistent" values. + $uri->query_form_hash({ + map({ + my $key=$_; + my $val=$W->{"args"}{$key}; + (!defined $val ? () : ($key=>$val)); + } keys(%{$W->{"args_persistent"}})), + %{$uri->query_form_hash()}, + }); } - return top_dir_disk().$in; + return $uri->abs(unparsed_uri()) if $W->{"args"}{"Wabs"} || $args{"abs"}; + return $uri->rel(unparsed_uri()); +} + +# $args{"uri_as_in"}=1 to permit passing URI objects as: $in +sub path_abs_disk($%) +{ +my($in,%args)=@_; + + cluck if !$args{"uri_as_in"} && ref $in; + my $uri=in_to_uri_abs($in); + cluck if !uri_is_local($uri); + my $path=$uri->path(); + cluck "URI compatibility: ->path() not w/leading slash of URI \"$uri\"; path: $path" if $path!~m{^/}; + return dir_top_abs_disk().$path; } sub fatal (;$); -sub args_check (%) +sub _args_check (%) { my(%tmpl)=@_; while (my($name,$regex)=each(%tmpl)) { - my $name_html="Parameter ".CGI::escapeHTML($name).""; + my $name_html="Parameter ".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" @@ -274,8 +402,8 @@ my(%tmpl)=@_; $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)." " + fatal "$name_html ".escapeHTML($val)."" + ." does not match the required regex ".escapeHTML($regex)." " if $regex ne "" && $val!~/$regex/; } } @@ -317,33 +445,12 @@ sub footer (;$) Wprint vskip if $W->{"footer_delimit"}; - do { &{$_}() if $_; } for ($W->{"footing_delimit"}); + do { Wprint $_ if $_; } for $W->{"footing_delimit"}; Wprint "
\n" if $W->{"footer"}; - if ($W->{"footer_mailme"}) { - Wprint '
'."\n"; - Wprint input_hidden_persistents()."\n"; - Wprint '

'."\n"; - Wprint ''."\n"; - Wprint ''."\n"; - Wprint ''."\n"; - Wprint '

'."\n"; - Wprint '
'."\n"; - } + my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; - my @packages_used=( - $W->{"__PACKAGE__"}, - __PACKAGE__, - @{$W->{"packages_used"}{"__My::Web"}}, - map((!$_ ? () : @$_),$W->{"packages_used"}{$W->{"__PACKAGE__"}}), - ); - my %packages_used; - @packages_used=grep((!$packages_used{$_}++),@packages_used); if ($W->{"footer_ids"}) { Wprint '

'; Wprint join("
\n",map({ my $package=$_; @@ -361,11 +468,11 @@ sub footer (;$) $file=~s#::#/#g; my $ext; my @tried; - for (qw(.html.pl .pl .pm),"") { + for (qw(.pm)) { $ext=$_; - my $pathname=top_dir_disk()."/$file$ext"; - push @tried,$pathname; - last if -r $pathname; + my $path_abs_disk=path_abs_disk("/$file$ext"); + push @tried,$path_abs_disk; + last if -r $path_abs_disk; cluck "Class file $file not found; tried: ".join(" ",@tried) if !$ext; } $file.=$ext; @@ -374,25 +481,25 @@ sub footer (;$) $cvs_id_split[2]); $cvs_id_split[1]=a_href($W->{"viewcvs"}.$file, ($package!~/^Apache2::/ ? $package : $cvs_id_split[1])); - $cvs_id_split[5]=&{$W->{"cvs_id_author"}}($cvs_id_split[5]); + $cvs_id_split[5]=&{$W->{"cvs_id_author_sub"}}($cvs_id_split[5]); } join " ",@cvs_id_split; } - } @packages_used)); + } @$packages_used)); Wprint "

\n"; } - for my $package (@packages_used) { + for my $package (@$packages_used) { my $cvs_id=(eval('$'.$package."::CVS_ID") # || $package # debug ); Wprint ''."\n" if $cvs_id; } - do { &{$_}() if $_; } for ($W->{"footing"}); + do { Wprint $_ if $_; } for $W->{"footing"}; Wprint "\n"; - exit(0); + exit 0; } sub header (%) @@ -423,84 +530,82 @@ my($size)=@_; return $size; } -sub url_is_local ($) +sub uri_is_local($) { -my($url)=@_; +my($in)=@_; - return $url!~m#^[a-z]+://#; + my $uri_rel=in_to_uri_abs($in)->rel(unparsed_uri()); + # Do not: defined $uri_rel->("userinfo"|"host"|"port")(); + # as they fail to be called for schemes not supporting them. + return 0 if $uri_rel->scheme(); + return 0 if $uri_rel->authority(); + return 1; } -sub url_out($%) +# &path_web still may be required for &uri_escaped ! +sub uri_escaped($) { -my($url,%args)=@_; - - return $url if !url_is_local $url; - $url=top_dir($url,%args) if $url=~m#^/# || $args{"abs"}; +my($uri)=@_; - my $uri=URI->new($url); - # Prefer the $uri values over "args_persistent" values. - $uri->query_form_hash({ - map({ - my $key=$_; - my $val=$W->{"args"}{$key}; - (!defined $val ? () : ($key=>$val)); - } keys(%{$W->{"args_persistent"}})), - %{$uri->query_form_hash()}, - }); - $url="".$uri; - - return $url; + cluck if !ref $uri; + my $urient=escapeHTML($uri); + return $uri if $uri eq $urient; + request_check(); + return $urient if uri_is_local $uri; + return $uri if defined $W->{"have_ent"} && !$W->{"have_ent"}; # non-ent client + return $urient if $W->{"have_ent"}; # ent client + # Unknown client, &escapeHTML should not be needed here: + return escapeHTML(path_web('/Redirect.pm?location='.uri_escape($uri->abs(unparsed_uri())))); } -sub a_href ($;$%) +our $a_href_inhibited; +sub a_href($;$%) { -my($url,$contents,%args)=@_; +my($in,$contents,%args)=@_; + request_check(); do { $$_=1 if !defined $$_; } for (\$args{"size"}); if (!defined $contents) { - $contents=$url; + $contents=$in; $contents=File::Basename::basename($contents) if $args{"basename"}; - $contents=CGI::escapeHTML($contents); + $contents=escapeHTML($contents); } $contents=~s#]*>##gi; $contents=~s###gi; + return $contents if $a_href_inhibited; - $url=url_out($url,%args); - - 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))); } + my $path_web=path_web $in,%args; + my $r=""; + $r.=''; - if ($args{"size"} && url_is_local($url) && ($args{"size"}>=2 || $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]).')'; - } + if ($args{"size"} && uri_is_local($in) && ($args{"size"}>=2 || $in=~/[.](?:gz|Z|rpm|zip|deb|lha)/)) { # Downloadable? + my $path_abs_disk=path_abs_disk $in,%args; + cluck "File not readable: $path_abs_disk" if !-r $path_abs_disk; + $r.=' ('.size_display((stat($path_abs_disk))[7]).')'; } return $r; } +sub a_href_inhibit($$;@) +{ +my($self,$sub,@sub_args)=@_; + + local $a_href_inhibited=1; + return &{$sub}(@sub_args); +} + sub input_hidden_persistents() { + request_check(); return join("",map({ my $key=$_; my $val=$W->{"args"}{$key}; (!defined $val ? () : ''."\n"); } (keys(%{$W->{"args_persistent"}})))); } @@ -509,7 +614,7 @@ sub http_moved($$;$) { my($self,$url,$status)=@_; - $url=url_out($url,"abs"=>1); + $url=path_web($url,"abs"=>1); $status||=HTTP_MOVED_TEMPORARILY; $W->{"r"}->status($status); $W->{"r"}->headers_out()->{"Location"}=$url; @@ -549,13 +654,30 @@ sub make ($) { my($cmd)=@_; - system {'flock'} 'flock','-x',top_dir_disk(),$cmd.' >&2'; + # FIXME: &alarm, --timeout is now infinite. + # FIXME: Try to remove bash(1). + # FIXME: Use: @PATH_FLOCK@ + my @argv=('flock',dir_top_abs_disk(),'bash','-c',$cmd.' >&2'); + print STDERR join(" ","SPAWN:",@argv)."\n"; + system @argv; +} + +sub make_file($$) +{ +my($self,$file)=@_; + + cluck "Pathname not absolute: $file" if $file!~m{^/}; + return if -f $file; + # TODO: Somehow quickly check dependencies? + return make('make -s --no-print-directory' + .' -C '."'".File::Basename::dirname($file)."' '".File::Basename::basename($file)."'"); } sub img_size ($$) { my($width,$height)=@_; + cluck if !defined $width || !defined $height; return ($W->{"have_style"} ? "style=\"border:0;width:${width}px;height:${height}px\"" : "border=\"0\"") ." width=\"$width\" height=\"$height\""; } @@ -583,7 +705,7 @@ my($self,$variants)=@_; # Do not: HTTP::Headers->new($W->{"r"}->headers_in()); # to prevent empty result or even: Odd number of elements in anonymous hash HTTP::Headers->new(%{$W->{"r"}->headers_in()})); - $best||=$variants->[0]{"id"}; # &HTTP::Negotiate::choose failed? + $best||=$variants->[0][0]; # $variants->[0]{"id"}; &HTTP::Negotiate::choose failed? return $best; } @@ -593,67 +715,54 @@ my @img_variants=( ); my $img_variants_re='[.](?:'.join('|',"jpeg",map(($_->{"id"}),@img_variants)).')$'; -sub img_src ($) +# Returns: ($path_web,$path_abs_disk) +# URI path segments support ignored here. Where it is used? (';' path segment options) +sub _img_src($%) { -my($file_base)=@_; +my($in,%args)=@_; - 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); - } + cluck if !uri_is_local $in; + my $uri=in_to_uri_abs $in; + my $path_abs_disk=path_abs_disk $uri,%args,"uri_as_in"=>1; - 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); - } + # Known image extension? + return path_web($uri,%args,"uri_as_in"=>1),$path_abs_disk if $uri->path()=~m#$img_variants_re#o; 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; + my $path_abs_disk_variant=$path_abs_disk.".".$var->{"id"}; + __PACKAGE__->make_file($path_abs_disk_variant); push @nego_variants,negotiate_variant( %$var, - "size"=>(stat $file)[7], + "size"=>(stat $path_abs_disk_variant)[7], ); } my $ext=__PACKAGE__->Negotiate_choose(\@nego_variants); - return $file_base_uri.".".$ext if !wantarray(); - return ($file_base_uri.".".$ext,$file_base_disk.".".$ext); + $uri->path($uri->path().".$ext"); + return path_web($uri,%args,"uri_as_in"=>1),path_abs_disk($uri,%args,"uri_as_in"=>1); } -sub img ($$;%) +# $args{"attr"} +sub img ($$%) { -my($file_base,$alt,%attr)=@_; +my($in,$alt,%args)=@_; - my($file_uri,$file_disk)=img_src $file_base; - my($width,$height)=Image::Size::imgsize($file_disk); + request_check(); + my($path_web,$path_abs_disk)=_img_src($in,%args); + my($width,$height)=Image::Size::imgsize($path_abs_disk); $alt=~s/<[^>]*>//g; - $alt=CGI::escapeHTML($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"}; + $alt=escapeHTML($alt); + my $content="\"$alt\""; + do { return a_href((_img_src($_))[0],$content,"uri_as_in"=>1) if $_; } for $args{"a_href_img"}; + do { return a_href $_,$content if $_; } for $args{"a_href"}; return $content; } sub centerimg { - my $r.=""; + my $r=""; $r.=''."\n"; @_=( [@_] ) if !ref $_[0]; for (@_) { @@ -667,11 +776,12 @@ sub rightimg { my($text,@args_img)=@_; - # Workaround bug of 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)': + # FIXME: Workaround bug of 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)': + # ie() ? "1*" : "90%" ) ]}" /> + # ie() ? "0*" : "10%" ) ]}" /> + # causes whole invisible projects in: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7.10) Gecko/20050719 Galeon/1.3.21 return <<"HERE";
- ie() ? "1*" : "90%" ) ]}" /> - ie() ? "0*" : "10%" ) ]}" />
@{[ $text ]} @@ -684,28 +794,15 @@ my($text,@args_img)=@_; HERE } -sub readfile ($$) +sub readfile($$) { my($class,$filename)=@_; local *F; - open F,$filename or die "Cannot open \"$filename\": $!"; - local $/=undef(); - my $data=; - close F; - return $data; -} - -sub arr_keys (@) -{ -my(@arr)=@_; - - my @r=(); - while (@arr) { - push @r,shift @arr; # key - shift @arr; # val - } - return @r; + open F,$filename or cluck "Cannot open \"$filename\": $!"; + my $F=do { local $/=undef(); ; }; + close F or cluck "Cannot close \"$filename\": $!"; + return $F; } sub no_cache($) @@ -718,7 +815,7 @@ my($self)=@_; header("Pragma"=>"no-cache"); # HTTP/1.0 } -sub heading () +sub heading() { my($class)=@_; @@ -738,12 +835,14 @@ my($class)=@_; # FIXME: It is not clean to still append them without overwriting. return if $W->{"heading_done"}++; - my $lang=($W->{"language"}||"en-US"); # Workaround bug # https://bugzilla.mozilla.org/show_bug.cgi?id=120556 # of at least # Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8b) Gecko/20050217 - my $mime=$class->Negotiate_choose([ + my $mime; + # http://validator.w3.org/ does not send ANY "Accept" headers! + $mime||="application/xhtml+xml" if !$W->{"accept"} && $W->{"user_agent"}=~m{^W3C_Validator/}i; + $mime||=$class->Negotiate_choose([ # Put the fallback variant as the first one. # Rate both variants the same to prefer "text/html" for undecided clients. # At least @@ -755,38 +854,43 @@ my($class)=@_; "content-type"=>"text/html", "qs"=>0.6, "charset"=>$client_charset, - "lang"=>$lang, + "lang"=>$W->{"language"}, ), negotiate_variant( "id"=>"application/xhtml+xml", "content-type"=>"application/xhtml+xml", "qs"=>0.6, "charset"=>$client_charset, - "lang"=>$lang, + "lang"=>$W->{"language"}, ), # application/xml ? # text/xml ? ]); $W->{"r"}->content_type("$mime; charset=$client_charset"); - if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn - Wprint ''."\n"; - } + Wprint ''."\n" if $mime=~m{^application/\w+[+]xml$}; + return if $W->{"xml_header_only"}; Wprint ''."\n"; - Wprint ''."\n"; + Wprint ''."\n"; my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ()))); + # Do not: cluck if $title=~/[<>]/; + # as it is not solved just by: &a_href_inhibit + # as sometimes titles use also: ... $title=~s#<[^>]*>##g; Wprint ""; Wprint "$title\n"; if ($W->{"have_css"}) { # Everything can get overriden later. - Wprint <<"HERE"; - + for my $css ("/My/Web.css",map((!$_ ? () : ("ARRAY" ne ref($_) ? $_ : @$_)),$W->{"css_push"})) { + Wprint <<"HERE"; + HERE + } } Wprint ''."\n"; Wprint $W->{"head"}; for my $type (qw(prev next index contents start up)) { - do { Wprint ''."\n" if $_; } for ($W->{"rel_$type"}); + do { Wprint ''."\n" if $_; } + for ($W->{"rel_$type"}); } Wprint "{"body_attr"}; Wprint ">\n"; - do { &{$_}() if $_; } for ($W->{"heading"}); + do { Wprint $_ if $_; } for $W->{"heading"}; } BEGIN {