X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=2a93ce16fccabf37a24c5b251b6247855bc32ee1;hb=8c80926a8d815836ff9bc26740751cd1780fd045;hp=202ecd99cc81bf03ad2fca8fa8a462fe53ec1090;hpb=c8dccbabbbd73dcf3b25bddf5e8557d7551dd6c4;p=MyWeb.git diff --git a/Web.pm b/Web.pm index 202ecd9..2a93ce1 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 $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"); @@ -121,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"}); @@ -129,20 +164,39 @@ my($class,%args)=@_; return $W; } -sub require ($) +sub top_dir_disk () +{ + do { return $_ if $_; } for ($W->{"top_dir"}); + return $INC[0]; # fallback +} + +sub top_dir (;$) { -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. +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 +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/; } } @@ -191,7 +245,7 @@ sub footer (;$) print "