X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=0616f94e51851c73192cd50f98b1b6a605415c7b;hb=3b62e3657c71b5ee91280b70c7af35e01231e343;hp=f67c47d206c4678602ec97ff75f6de9a0397308b;hpb=209bb85c6749050cd5f57241f43d118b04cd41f3;p=MyWeb.git diff --git a/Web.pm b/Web.pm index f67c47d..0616f94 100644 --- a/Web.pm +++ b/Web.pm @@ -39,6 +39,9 @@ our @EXPORT=qw( ); our @ISA=qw(Tie::Handle Exporter); +my %packages_used_hash; +my %packages_used_array; + BEGIN { use Carp qw(cluck confess); @@ -63,8 +66,8 @@ BEGIN for my $target ($class,__PACKAGE__) { for my $caller (keys(%callers)) { next if $caller eq $target; - next if $W->{'packages_used%'}{$caller}{$target}++; - push @{$W->{'packages_used@'}{$caller}},$target; + next if $packages_used_hash{$caller}{$target}++; + push @{$packages_used_array{$caller}},$target; } } eval { CORE::require "$file"; } or confess $@; @@ -106,7 +109,7 @@ 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; @@ -120,10 +123,17 @@ use Cwd; # $W->{"footer_passed"} # %{$W->{"headers"}} # %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key - # @{$W->{'packages_used@'}{callers...}} - # %{$W->{'packages_used%'}{callers...}} # %{$W->{"args"}} +sub cleanup($) +{ +my($apache_request)=@_; + + # Sanity protection. + $W=undef(); + return OK; +} + sub init ($%) { my($class,%args)=@_; @@ -136,13 +146,9 @@ my($class,%args)=@_; Wuse 'WebConfig'; Wrequire 'My::Hash::Sub'; - my $packages_used_array_save=$W->{'packages_used@'}; - my $packages_used_hash_save =$W->{'packages_used%'}; $W={}; tie %$W,"My::Hash::Sub"; %$W=(%WebConfig,%args); # override %WebConfig settings - $W->{'packages_used@'}=$packages_used_array_save; - $W->{'packages_used%'}=$packages_used_hash_save; $W->{"__PACKAGE__"}||=caller(); # {"__PACKAGE__"} is mandatory for mod_perl-2.0; @@ -170,6 +176,10 @@ 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; @@ -218,12 +228,14 @@ my($class,%args)=@_; do { args_check(%$_) if $_; } for ($W->{"args_check"}); - $ENV{"HOSTNAME"}||=$W->{"web_hostname"}; - return bless $W,$class; } # 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)=@_; @@ -292,7 +304,7 @@ sub unparsed_uri() 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"}||$WebConfig{"web_hostname"})."/"); + my $uri=URI->new_abs($uri_string,"http://".$W->{"web_hostname"}."/"); $W->{"unparsed_uri"}=$uri; } return $W->{"unparsed_uri"}; @@ -315,6 +327,7 @@ my($in)=@_; } # $args{"uri_as_in"}=1 to permit passing URI objects as: $in +# $args{"abs"}=1; sub path_web($%) { my($in,%args)=@_; @@ -407,11 +420,11 @@ sub footer (;$) Wprint vskip if $W->{"footer_delimit"}; - Wprint $W->{"footing_delimit"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"footing_delimit"}; Wprint "
\n" if $W->{"footer"}; - my $packages_used=$W->{'packages_used@'}{$W->{"__PACKAGE__"}}; + my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; if ($W->{"footer_ids"}) { Wprint '

'; @@ -458,7 +471,7 @@ sub footer (;$) Wprint ''."\n" if $cvs_id; } - Wprint $W->{"footing"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"footing"}; Wprint "\n"; exit 0; @@ -519,6 +532,7 @@ my($uri)=@_; return escapeHTML(path_web('/Redirect.pm?location='.uri_escape($uri->abs(unparsed_uri())))); } +our $a_href_inhibited; sub a_href($;$%) { my($in,$contents,%args)=@_; @@ -531,6 +545,7 @@ my($in,$contents,%args)=@_; } $contents=~s#]*>##gi; $contents=~s###gi; + return $contents if $a_href_inhibited; my $path_web=path_web $in,%args; my $r=""; @@ -547,6 +562,14 @@ my($in,$contents,%args)=@_; return $r; } +sub a_href_inhibit($$;@) +{ +my($self,$sub,@sub_args)=@_; + + local $a_href_inhibited=1; + return &{$sub}(@sub_args); +} + sub input_hidden_persistents() { return join("",map({ @@ -654,7 +677,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; } @@ -783,7 +806,6 @@ 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 @@ -803,31 +825,37 @@ 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"); 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"}; @@ -841,7 +869,7 @@ HERE Wprint $W->{"body_attr"}; Wprint ">\n"; - Wprint $W->{"heading"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"heading"}; } BEGIN {