X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=456e7c8bcfd721d12166e2aa86d985469d83e829;hp=2dd77470bc95eec121632e68e7df4aca3c1db4c4;hb=1ee642491d049abd3ee7324f395940f1650436bf;hpb=04cfa87afa399b81e737964810304fa942b0eca7 diff --git a/Web.pm b/Web.pm index 2dd7747..456e7c8 100644 --- a/Web.pm +++ b/Web.pm @@ -27,8 +27,8 @@ 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 &Wprint); -our @ISA=qw(Exporter); +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); BEGIN { @@ -46,9 +46,11 @@ BEGIN $file.=".pm"; my $who=$W->{"__PACKAGE__"}; $who||="__My::Web" if $W->{"__My::Web_init"}; - my $aref=($W->{"packages_used"}{$who}||=[]); - push @$aref,$class - if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries. + if ($who) { + my $aref=($W->{"packages_used"}{$who}||=[]); + push @$aref,$class + if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries. + } CORE::require $file; 1; # Otherwise 'require' would already file above. } @@ -76,12 +78,15 @@ require HTTP::Negotiate; my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; } use ModPerl::Util qw(exit); use POSIX qw(strftime); +use Tie::Handle; +use Apache::Const qw(HTTP_MOVED_TEMPORARILY); +use URI; +use URI::QueryParam; #our $W; # $W->{"title"} # $W->{"head"} - # $W->{"head_css"} # $W->{"force_charset"} # $W->{"heading_done"} # $W->{"footer_passed"} @@ -110,14 +115,14 @@ my($class,%args)=@_; 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"); + do { $W->{$_}="" if !defined $W->{$_}; } for ("body_attr"); + do { $W->{$_}="en-US" if !defined $W->{$_}; } for ("language"); my $footer_any=0; for (qw(footer_mailme footer_ids)) { @@ -130,27 +135,31 @@ my($class,%args)=@_; $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"; + if ($W->{"detect_ent"}) { + 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 (!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"}); + # Workaround: &CGI::Vars behaves weird if strings passed both as POST data and in: $QUERY_STRING + do { $W->{"r"}->args(""); delete $ENV{"QUERY_STRING"}; } if $W->{"r"}->method() eq "POST"; # Do not: $W->{"r"}->args() # as it parses only QUERY_STRING (not POST data). $W->{"args"}={ CGI->new($W->{"r"})->Vars() }; - for (keys(%{$W->{"args"}})) { - my @vals=split /\x00/,$W->{"args"}{$_}; + for my $name (keys(%{$W->{"args"}})) { + my @vals=split /\x00/,$W->{"args"}{$name}; next if @vals<=1; - $W->{"args"}{$_}=[@vals]; + $W->{"args"}{$name}=[@vals]; } do { $W->{$_}=$W->{"r"}->headers_in()->{"Accept"} if !defined $W->{$_}; } for ("accept"); @@ -171,14 +180,32 @@ my($class,%args)=@_; $ENV{"HOSTNAME"}||=&{$W->{"web_hostname_sub"}}(); - return $W; + return bless $W,$class; } sub Wprint($) { my($text)=@_; - $W->{"r"}->print($text); + $W->{"r"}->puts($text); +} + +# local *FH; +# tie *FH,ref($W),$W; +sub TIEHANDLE($) +{ +my($class,$W)=@_; + + my $self={}; + $self->{"W"}=$W or confess "Missing W"; + return bless $self,$class; +} + +sub WRITE +{ +my($self,$scalar,$length,$offset)=@_; + + Wprint substr($scalar,0,$length); } sub top_dir_disk () @@ -187,12 +214,13 @@ sub top_dir_disk () return $INC[0]; # fallback } -sub top_dir (;$) +# $args{"abs"} +sub top_dir (;$%) { -my($in)=@_; +my($in,%args)=@_; if (my $uri=$W->{"r"}->unparsed_uri()) { - if ($W->{"args"}{"Wabs"}) { + if ($W->{"args"}{"Wabs"} || $args{"abs"}) { # FIXME: $in may not be defined here! # to prevent: Use of uninitialized value in ... if ($in=~m#^/#) { @@ -263,8 +291,11 @@ sub fatal (;$) my($msg)=@_; $msg="UNKNOWN" if !$msg; + cluck "FATAL: $msg"; $W->{"indexme"}=0; # For the case no heading was sent yet. + $W->{"heading_done"}=0; # for the case of already sent {"header_only"}==1 + $W->{"header_only"}=0; # assurance for &heading My::Web->heading(); Wprint "\n".vskip("3ex")."
You can report this problem's details to" @@ -278,9 +309,7 @@ sub footer (;$) Wprint vskip if $W->{"footer_delimit"}; - if ($W->{"heading"}) { - do { &{$_}() if $_; } for ($W->{"footing_delimit"}); - } + do { &{$_}() if $_; } for ($W->{"footing_delimit"}); Wprint "
'."\n"; Wprint ''."\n"; Wprint ''."\n"; @@ -351,9 +381,7 @@ sub footer (;$) Wprint ''."\n" if $cvs_id; } - if ($W->{"heading"}) { - do { &{$_}() if $_; } for ($W->{"footing"}); - } + do { &{$_}() if $_; } for ($W->{"footing"}); Wprint "