X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=e41a314f3d09e47f2d524abca9ba690d5df97d32;hp=33e03105250e97294d6cfe5f444a35598e635ed6;hb=refs%2Fheads%2Fmodperl;hpb=ab61085d544a2e9f1f4ddeaf30178f408b01d803 diff --git a/Web.pm b/Web.pm index 33e0310..e41a314 100644 --- a/Web.pm +++ b/Web.pm @@ -23,13 +23,45 @@ our $CVS_ID=q$Id$; use strict; use warnings; -use lib qw(/home/short/lib/perl5/site_perl/5.6.0/i386-linux /home/short/lib/perl5/site_perl/5.6.0 /home/short/lib/perl5/site_perl/i386-linux /home/short/lib/perl5/site_perl /home/short/lib/perl5/5.6.0/i386-linux /home/short/lib/perl5/5.6.0 /home/short/lib/perl5/i386-linux /home/short/lib/perl5); - use Exporter; -our @EXPORT=qw(&require &a_href &a_href_cz &vskip &img $W); +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); -use WebConfig; # for %WebConfig +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 @@ -46,7 +78,7 @@ delete $ENV{"PERLLIB"}; delete $ENV{"LD_LIBRARY_PATH"}; -our $W; +#our $W; # $W->{"title"} # $W->{"head"} # $W->{"head_css"} @@ -63,7 +95,9 @@ sub init ($%) { my($class,%args)=@_; + 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; @@ -72,6 +106,7 @@ 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"); @@ -99,7 +134,7 @@ my($class,%args)=@_; { delete $W->{"have_ent"}; } if ($W->{"detect_ent"} && !defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") { $W->{"head"}.='{"r"}->hostname()."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0] + .CGI::escapeHTML("http://".&{$W->{"web_hostname_sub"}}()."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0] ."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect') .'" />'."\n"; } @@ -107,8 +142,13 @@ my($class,%args)=@_; $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). + # 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"); @@ -121,7 +161,7 @@ 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"}); @@ -129,20 +169,39 @@ my($class,%args)=@_; return $W; } -sub require ($) +sub top_dir_disk () { -my($file)=@_; - - $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. + do { return $_ if $_; } for ($W->{"top_dir"}); + return $INC[0]; # fallback +} + +sub top_dir (;$) +{ +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; + } + return top_dir_disk().$in; } sub fatal (;$); @@ -152,13 +211,18 @@ sub args_check (%) my(%tmpl)=@_; while (my($name,$regex)=each(%tmpl)) { - my $name_html="Parametr ".CGI::escapeHTML($name).""; - my $val=$W->{"args"}{$name}; - fatal "$name_html ".CGI::escapeHTML($val)."" - ." does not match required regex ".CGI::escapeHTML($regex)."" - if defined $val && $val!~/$regex/; - fatal "$name_html is required" - if !defined $val; + 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/; + } } } @@ -175,7 +239,8 @@ my($msg)=@_; $msg="UNKNOWN" if !$msg; -# heading(false/*title*/,false/*indexme*/); # notitle is always safe, don't index the error message + $W->{"indexme"}=0; # For the case no heading was sent yet. + My::Web->heading(); print "\n".vskip("3ex")."
You can report this problem's details to" ." ".a_href("mailto:".$W->{"admin_mail"},"admin of this website").".
\n"; @@ -188,10 +253,14 @@ sub footer (;$) print vskip if $W->{"footer_delimit"}; + if ($W->{"heading"}) { + do { &{$_}() if $_; } for ($W->{"footing_delimit"}); + } + print "