From f144923df598ea0c6b4130278fe1bbfeeef7d928 Mon Sep 17 00:00:00 2001 From: short <> Date: Sat, 30 Jul 2005 21:15:06 +0000 Subject: [PATCH] mod_perl-2.0 compatible version. --- Web.pm | 406 ++++++++++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 266 insertions(+), 140 deletions(-) diff --git a/Web.pm b/Web.pm index 524cf14..9268953 100644 --- a/Web.pm +++ b/Web.pm @@ -27,11 +27,13 @@ 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); -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 { + $W->{"__My::Web_init"}=1; + sub Wrequire ($) { my($file)=@_; @@ -42,9 +44,13 @@ BEGIN 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. + my $who=$W->{"__PACKAGE__"}; + $who||="__My::Web" if $W->{"__My::Web_init"}; + 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. } @@ -69,53 +75,56 @@ use Carp qw(cluck confess); use URI::Escape; require HTTP::BrowserDetect; require HTTP::Negotiate; -require Geo::IP; -require CGI; - - -# Undo 'www/engine/httpd-restart' as it may use obsolete Perl for 'mod_perl' -delete $ENV{"PERLLIB"}; -delete $ENV{"LD_LIBRARY_PATH"}; +my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; } +# Do not: use ModPerl::Util qw(exit); +# to prevent in mod_perl2: "exit" is not exported by the ModPerl::Util module +# I do not know why. +use POSIX qw(strftime); +use Tie::Handle; +use Apache2::Const qw(HTTP_MOVED_TEMPORARILY); +use URI; +use URI::QueryParam; #our $W; # $W->{"title"} # $W->{"head"} - # $W->{"head_css"} # $W->{"force_charset"} - # %{$W->{"packages_used"} # $W->{"heading_done"} # $W->{"footer_passed"} # %{$W->{"headers"}} # %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key - # @{$W->{"packages_used"}{$Apache::Registry::curstash}}} + # @{$W->{"packages_used"}{$W->{"__PACKAGE__"}}} + # @{$W->{"packages_used"}{"__My::Web"}} # %{$W->{"args"}} sub init ($%) { my($class,%args)=@_; - print STDERR "$class->init ".$ENV{"REQUEST_URI"}."\n"; + print STDERR "$class->init ".Apache2::RequestUtil->request()->unparsed_uri()."\n"; 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; + # {"__PACKAGE__"} is mandatory for mod_perl-2.0; + # $Apache2::Registry::curstash is no longer supported. + do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__"; $W->{"top_dir"}||=eval '$'.$W->{"__PACKAGE__"}.'::top_dir'; 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)) { @@ -125,35 +134,38 @@ my($class,%args)=@_; $W->{"footer"}=0 if !$footer_any; $W->{"footer_delimit"}=0 if !$W->{"footer"}; - $W->{"r"}=Apache->request(); + $W->{"r"}=Apache2::RequestUtil->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"}); - $ENV{"QUERY_STRING"}=$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()->Vars() }; - for (keys(%{$W->{"args"}})) { - my @vals=split /\x00/,$W->{"args"}{$_}; + $W->{"args"}={ CGI->new($W->{"r"})->Vars() }; + 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->{$_}=$ENV{"HTTP_ACCEPT"} if !defined $W->{$_}; } for ("accept"); - do { $W->{$_}=$ENV{"HTTP_USER_AGENT"} if !defined $W->{$_}; } for ("user_agent"); + do { $W->{$_}=$W->{"r"}->headers_in()->{"Accept"} if !defined $W->{$_}; } for ("accept"); + do { $W->{$_}=$W->{"r"}->headers_in()->{"User-Agent"} if !defined $W->{$_}; } for ("user_agent"); $W->{"browser"}=HTTP::BrowserDetect->new($W->{"user_agent"}); @@ -168,7 +180,34 @@ my($class,%args)=@_; do { args_check(%$_) if $_; } for ($W->{"args_check"}); - return $W; + $ENV{"HOSTNAME"}||=&{$W->{"web_hostname_sub"}}(); + + return bless $W,$class; +} + +sub Wprint($) +{ +my($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 () @@ -177,19 +216,20 @@ sub top_dir_disk () return $INC[0]; # fallback } -sub top_dir (;$) +# $args{"abs"} +sub top_dir (;$%) { -my($in)=@_; +my($in,%args)=@_; - if (my $uri=$ENV{"REQUEST_URI"}) { - if ($W->{"args"}{"Wabs"}) { + if (my $uri=$W->{"r"}->unparsed_uri()) { + if ($W->{"args"}{"Wabs"} || $args{"abs"}) { # FIXME: $in may not be defined here! # to prevent: Use of uninitialized value in ... if ($in=~m#^/#) { $in=~s#^/*##; } else { - $in=$ENV{"REQUEST_URI"}."/".$in; + $in=$uri."/".$in; $in=~tr#/#/#s; 1 while $in=~s#/(?:[^/]+)/\Q..\E/#/#g } @@ -231,7 +271,7 @@ my(%tmpl)=@_; $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; + $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)."" @@ -253,10 +293,13 @@ 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(); - print "\n".vskip("3ex")."
You can report this problem's details to" ." ".a_href("mailto:".$W->{"admin_mail"},"admin of this website").".
\n"; footer(); @@ -266,31 +309,38 @@ sub footer (;$) { exit 1 if $W->{"footer_passed"}++; # deadlock prevention: - print vskip if $W->{"footer_delimit"}; + Wprint vskip if $W->{"footer_delimit"}; - if ($W->{"heading"}) { - do { &{$_}() if $_; } for ($W->{"footing_delimit"}); - } + do { &{$_}() if $_; } for ($W->{"footing_delimit"}); - print "'."\n"; + Wprint ''."\n"; + Wprint ''."\n"; + Wprint ''."\n"; + Wprint '
'."\n"; + Wprint ''."\n"; } + my @packages_used=( + $W->{"__PACKAGE__"}, + __PACKAGE__, + @{$W->{"packages_used"}{"__My::Web"}}, + map((!$_ ? () : @$_),$W->{"packages_used"}{$W->{"__PACKAGE__"}}), + ); + my %packages_used; + @packages_used=grep((!$packages_used{$_}++),@packages_used); if ($W->{"footer_ids"}) { - print '';
- print join("
\n",map({ my $package=$_;
+ Wprint '
';
+ Wprint join("
\n",map({ my $package=$_;
my $cvs_id=(eval('$'.$package."::CVS_ID")
# || $package # debug
);
@@ -304,48 +354,38 @@ sub footer (;$)
my $file=$package;
$file=~s#::#/#g;
my $ext;
+ my @tried;
for (qw(.html.pl .pl .pm),"") {
$ext=$_;
- last if -r top_dir_disk()."/$file$ext";
- cluck "Class file $file not found" if !$ext;
+ my $pathname=top_dir_disk()."/$file$ext";
+ push @tried,$pathname;
+ last if -r $pathname;
+ cluck "Class file $file not found; tried: ".join(" ",@tried) if !$ext;
}
$file.=$ext;
$cvs_id_split[2]=""
.a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $W->{"viewcvs"}))[0]."$file?rev=".$cvs_id_split[2],
$cvs_id_split[2]);
- # FIXME: Use 'CVS/Repository' here.
- my $viewcvs=$W->{"viewcvs"};
- $viewcvs=~s#(/viewcvs)/.*$#$1/MyWeb/# if $file=~s#^My/##;
- $cvs_id_split[1]=a_href($viewcvs.$file,
- ($package!~/^Apache::/ ? $package : $cvs_id_split[1]));
+ $cvs_id_split[1]=a_href($W->{"viewcvs"}.$file,
+ ($package!~/^Apache2::/ ? $package : $cvs_id_split[1]));
$cvs_id_split[5]=&{$W->{"cvs_id_author"}}($cvs_id_split[5]);
}
join " ",@cvs_id_split;
}
- } (
- $W->{"__PACKAGE__"},
- __PACKAGE__,
- @{$W->{"packages_used"}{$Apache::Registry::curstash}},
- )));
- print "