X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=6a2189e7f68cbc84c47e466086d6237532b6ba50;hp=c5220821f4b11bf0bb0b1d80204834cb1b3e39bb;hb=4296af3ea0c0c9e1592b3adac1b8460b42b5833a;hpb=debfd3cb3c0f2954e8a330b69fa35b9c35d9d477 diff --git a/Web.pm b/Web.pm index c522082..6a2189e 100644 --- a/Web.pm +++ b/Web.pm @@ -24,10 +24,44 @@ use strict; use warnings; 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 $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 @@ -44,7 +78,7 @@ delete $ENV{"PERLLIB"}; delete $ENV{"LD_LIBRARY_PATH"}; -our $W; +#our $W; # $W->{"title"} # $W->{"head"} # $W->{"head_css"} @@ -61,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; @@ -70,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"); @@ -119,7 +156,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"}); @@ -127,20 +164,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 (;$); @@ -150,13 +206,13 @@ sub args_check (%) my(%tmpl)=@_; while (my($name,$regex)=each(%tmpl)) { - my $name_html="Parametr ".CGI::escapeHTML($name).""; + my $name_html="Parameter ".CGI::escapeHTML($name).""; + $W->{"args"}{$name}="" if !defined $W->{"args"}{$name}; my $val=$W->{"args"}{$name}; + $val="" if !defined $val; 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; + ." does not match required regex ".CGI::escapeHTML($regex)." " + if $regex ne "" && $val!~/$regex/; } } @@ -189,7 +245,7 @@ sub footer (;$) print "