X-Git-Url: https://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;fp=Web.pm;h=3ef46cf8884f1d5baa77d5698106d900ae20e606;hp=2b08495976dfb7b21ff5564128b49b0a5eb586e0;hb=2cef9aaaf5f11580cc136731902d5947a4d48d48;hpb=2ee1627503d02a1491c9e185895d12593e3e9753 diff --git a/Web.pm b/Web.pm index 2b08495..3ef46cf 100644 --- a/Web.pm +++ b/Web.pm @@ -33,7 +33,7 @@ our @EXPORT=qw( &uri_escaped &a_href &a_href_cc &vskip - &img ¢erimg &rightimg + &img ¢erimg &rightimg &leftimg $W &input_hidden_persistents &escapeHTML @@ -180,7 +180,6 @@ my($class,%args)=@_; do { $W->{$_}=1 if !defined $W->{$_}; } for "footer_delimit"; 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 "body_attr"; do { $W->{$_}="en-US" if !defined $W->{$_}; } for "language"; @@ -247,7 +246,7 @@ my($class,%args)=@_; else { delete $W->{"have_ent"}; } if (!defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") { - $W->{"head"}.='{"web_hostname"}."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0] ."?".($_ || "detect_ent_glue=1").'&have_ent=detect') .'" />'."\n"; @@ -283,7 +282,7 @@ my($class,%args)=@_; # as it does not look as registered, at least according to: MIME::Types $VERSION 1.15 # "application/javascript" so far standardized till 2005-12-08 by: # http://www.ietf.org/internet-drafts/draft-hoehrmann-script-types-03.txt - $W->{"head"}.=''."\n"; + $W->{"head_push"}=''."\n"; } # Required by &_args_check below. @@ -298,10 +297,11 @@ sub form_method($) { my($method)=@_; - return q{enctype="application/x-www-form-urlencoded" accept-charset="us-ascii utf-8"} if $method eq "post"; - return q{accept-charset="us-ascii utf-8"} if $method eq "get"; + my $r=q{method="}.$method.q{"}; + return $r." ".q{enctype="application/x-www-form-urlencoded" accept-charset="us-ascii utf-8"} if $method eq "post"; + return $r." ". q{accept-charset="us-ascii utf-8"} if $method eq "get"; cluck "Undefined method: $method"; - return "" + return $r; } sub merge_post_args($) @@ -696,7 +696,10 @@ sub footer() # Never update the package list while we examine it! $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1; - my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; + # Dump the whole packages stack or just the primary one? + #my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; + my $packages_used=[$W->{"__PACKAGE__"}]; + if ($W->{"footer_ids"}) { Wprint '

'; Wprint join("
\n",map({ my $package=$_; @@ -812,6 +815,7 @@ my($in,$contents,%args)=@_; if (!defined $contents) { $contents=$in; $contents=File::Basename::basename($contents) if $args{"basename"}; + $contents=~s/^mailto:([-.\w]+@[-.\w]+)$/$1/; $contents=escapeHTML($contents); } $contents=~s#]*>##gi; @@ -976,11 +980,30 @@ my($self,$variants)=@_; return $best; } +# FIXME: Use for "content-type": MIME::Types my @img_variants=( - { "id"=>"png","qs"=>0.9,"content-type"=>"image/png" }, - { "id"=>"gif","qs"=>0.7,"content-type"=>"image/gif" }, - ); -my $img_variants_re='[.](?:'.join('|',"jpeg",map(($_->{"id"}),@img_variants)).')$'; + { "id"=>"svg","qs"=>0.9,"content-type"=>"image/svg+xml" }, + { "id"=>"png","qs"=>0.8,"content-type"=>"image/png" }, + { "id"=>"gif","qs"=>0.7,"content-type"=>"image/gif" }, + # Do not prefer these to avoid fedding them for '*/*' browsers. + { "id"=>"dia","qs"=>0.6,"content-type"=>"application/x-dia-diagram" }, + { "id"=>"fig","qs"=>0.6,"content-type"=>"image/x-xfig" }, + { "id"=>"fig","qs"=>0.6,"content-type"=>"application/x-xfig" }, + { "id"=>"sxd","qs"=>0.6,"content-type"=>"application/vnd.sun.xml.draw" }, + { "id"=>"sxi","qs"=>0.6,"content-type"=>"application/vnd.sun.xml.impress" }, + ); +# Unsupported by Image::Size 2.992: sxd sxi dia +# Supported by Image::Size 2.992: fig png gif jpeg +# Expensive by Image::Size 2.992: svg +my %img_map=( + "svg" =>[qw(png gif)], # svg + "png" =>[qw(png gif)], + "jpeg"=>[qw(jpeg)], + "dia" =>[qw(png gif)], # svg + "fig" =>[qw(fig png gif)], + "sxd" =>[qw(png gif)], + "sxi" =>[qw(png gif)], + ); # Returns: ($path_web,$path_abs_disk) # URI path segments support ignored here. Where it is used? (';' path segment options) @@ -992,22 +1015,31 @@ my($in,%args)=@_; my $uri=in_to_uri_abs $in; my $path_abs_disk=path_abs_disk $uri,%args,"uri_as_in"=>1,"register"=>0; - # 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 $path_abs_disk_variant=$path_abs_disk.".".$var->{"id"}; - path_abs_disk_register($path_abs_disk_variant); - __PACKAGE__->make_file($path_abs_disk_variant); - push @nego_variants,negotiate_variant( - %$var, - "size"=>(stat $path_abs_disk_variant)[7], - ); + cluck "Not exists image path_abs_disk: $path_abs_disk" if !-r $path_abs_disk; + my($path_abs_disk_base,$ext_orig)=($path_abs_disk=~/^(.*)[.](\w+)$/) or cluck; + my $map_arrayref=$img_map{$ext_orig} or cluck; + + my $ext=$ext_orig; + if (1!=@$map_arrayref) { + my @nego_variants; + for my $ext (@$map_arrayref) { + my $path_abs_disk_variant=$path_abs_disk_base.".".$ext; + path_abs_disk_register($path_abs_disk_variant); + __PACKAGE__->make_file($path_abs_disk_variant); + for my $var (@img_variants) { + next if $var->{"id"} ne $ext; + push @nego_variants,negotiate_variant( + %$var, + "size"=>(stat $path_abs_disk_variant)[7], + ); + } + } + $ext=__PACKAGE__->Negotiate_choose(\@nego_variants); } - my $ext=__PACKAGE__->Negotiate_choose(\@nego_variants); - $uri->path($uri->path().".$ext"); + my $uri_path=$uri->path(); + $uri_path=~s/\Q.$ext_orig\E$/.$ext/ or cluck; + $uri->path($uri_path); return path_web($uri,%args,"uri_as_in"=>1),path_abs_disk($uri,%args,"uri_as_in"=>1); } @@ -1040,6 +1072,7 @@ sub centerimg return $r; } +# Optional: Provide 'text' as 1==@args_img item. sub rightimg { my($text,@args_img)=@_; @@ -1049,13 +1082,38 @@ my($text,@args_img)=@_; # 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"; - +
+ + +
@{[ $text ]}    - @{[ &{\&img}(@args_img) ]} + @{[ 1==@args_img ? $args_img[0] : &{\&img}(@args_img) ]} +
+HERE +} + +# Optional: Provide 'text' as 1==@args_img item. +sub leftimg +{ +my($text,@args_img)=@_; + + # FIXME: Workaround bug of 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)': + # ie() ? "0*" : "10%" ) ]}" /> + # ie() ? "1*" : "90%" ) ]}" /> + # 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"; + + + + +
+ @{[ 1==@args_img ? $args_img[0] : &{\&img}(@args_img) ]} +    + @{[ $text ]}
@@ -1361,19 +1419,26 @@ my($class)=@_; HERE } if ($W->{"css_inherit"}) { - # Do not: -HERE + $W->{"js_push"}="/My/css_inherit.js"; } } + for my $js (@{$W->{"js_push"}}) { + # Do not: + +HERE + } Wprint ''."\n"; - Wprint $W->{"head"}; + for my $head (@{$W->{"head_push"}}) { + $head=&{$head}() if "CODE" eq ref $head; + Wprint $head; + } for my $type (qw(prev next index contents start up)) { do { Wprint ''."\n" if $_; } for ($W->{"rel_$type"});