X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=2b08495976dfb7b21ff5564128b49b0a5eb586e0;hp=ab1646f412a54f993003cdd77dbce84ef686b02b;hb=refs%2Fheads%2Fapache20;hpb=b8c34b7761f9ad233e715291ca92559b2b617e5b
diff --git a/Web.pm b/Web.pm
index ab1646f..2b08495 100644
--- a/Web.pm
+++ b/Web.pm
@@ -24,19 +24,20 @@ use strict;
use warnings;
use Exporter;
-sub Wrequire($);
+sub Wrequire($%);
sub Wuse($@);
our $W;
our @EXPORT=qw(
&Wrequire &Wuse
&path_web &path_abs_disk
&uri_escaped
- &a_href &a_href_cz
+ &a_href &a_href_cc
&vskip
&img ¢erimg &rightimg
$W
&input_hidden_persistents
&escapeHTML
+ &form_method
);
our @ISA=qw(Tie::Handle Exporter);
@@ -48,9 +49,10 @@ BEGIN
use Carp qw(cluck confess);
$W->{"__My::Web_init"}=1;
- sub Wrequire ($)
+ # $args{"first"}=1
+ sub Wrequire ($%)
{
- my($file)=@_;
+ my($file,%args)=@_;
# print STDERR "Wrequire $file\n";
$file=~s#/#::#g;
@@ -66,9 +68,15 @@ BEGIN
$callers{$selfpkg}=1;
for my $target ($class,__PACKAGE__) {
for my $caller (keys(%callers)) {
- next if $caller eq $target;
next if $packages_used_hash{$caller}{$target}++;
- push @{$packages_used_array{$caller}},$target;
+ cluck "Appending to the '_done' package list: caller=$caller,target=$target"
+ if $packages_used_hash{$caller}{"_done"};
+ if ($args{"first"}) {
+ unshift @{$packages_used_array{$caller}},$target;
+ }
+ else {
+ push @{$packages_used_array{$caller}},$target;
+ }
}
}
eval { CORE::require "$file"; } or confess $@;
@@ -97,56 +105,41 @@ BEGIN
}
use WebConfig; # see also below: Wuse 'WebConfig';
-require CGI;
require Image::Size; # for &imgsize
use File::Basename; # &basename
use Carp qw(cluck confess);
use URI::Escape;
require HTTP::BrowserDetect;
require HTTP::Negotiate;
-my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; }
+our $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 OK);
+use Apache2::Const qw(HTTP_MOVED_TEMPORARILY OK HTTP_OK);
use URI;
use URI::QueryParam;
use Cwd;
require HTTP::Date;
+require Storable;
+require Digest::MD5;
+require Data::Compare;
+use Data::Dumper;
+require Encode;
+use Apache2::RequestUtil;
+use Apache2::Filter;
+use Apache2::Connection;
+require MIME::Base64;
+use Apache2::ServerUtil;
+require MIME::Types;
+require MIME::Parser;
+use Apache2::RequestRec;
+use Apache2::RequestIO;
+use Apache2::Response;
#our $W;
- # $W->{"title"}
- # $W->{"head"}
- # $W->{"force_charset"}
- # $W->{"heading_done"}
- # $W->{"footer_passed"}
- # %{$W->{"headers"}}
- # %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key
- # %{$W->{"args"}}
-
-sub cleanup($)
-{
-my($apache_request)=@_;
-
- $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
- # Sanity protection.
- $W=undef();
- return OK;
-}
-
-sub request_check(;$)
-{
-my($self)=@_;
-
- # Use &eval to prevent: Global $r object is not available. Set:\n\tPerlOptions +GlobalRequest\nin ...
- # CGI requires valid "r": check it beforehand here.
- confess "Calling sensitive dynamic code from a static code" if !eval { Apache2::RequestUtil->request(); };
- # Do not: confess "Calling sensitive dynamic code without My::Web::init" if !$W->{"__PACKAGE__"};
- # as it is valid at least while preparing arguments to call: &project::Lib::init
-}
sub init ($%)
{
@@ -158,20 +151,26 @@ my($class,%args)=@_;
# We cannot do it in BEGIN { } block
# as it would not be tracked for each of the toplevel users later.
Wuse 'WebConfig';
- Wrequire 'My::Hash::Sub';
-
- $W={};
- tie %$W,"My::Hash::Sub";
- %$W=(%WebConfig,%args); # override %WebConfig settings
- $W->{"__PACKAGE__"}||=caller();
+ Wrequire 'My::Hash';
+
+ # $W={} can get somehow created very easily.
+ # Do not: cluck "W not empty:\n".Dumper($W) if keys(%$W);
+ # to prevent (of $W->{"headers_in"}): TODO: Enumeration may not be expected.
+ cluck "W not empty; __PACKAGE__ was: ".$W->{"__PACKAGE__"} if keys(%$W);
+ $W=My::Hash->new({},"My::Hash::Sub","My::Hash::Push");
+ bless $W,$class;
+ %$W=(
+ "__PACKAGE__"=>scalar(caller()),
+ %WebConfig,
+ %args, # override %WebConfig settings
+ );
# {"__PACKAGE__"} is mandatory for mod_perl-2.0;
# $Apache2::Registry::curstash is no longer supported.
do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__";
-
- # See: &escapeHTML
- do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset();
- CGI::charset("utf-8");
+ exit_hook_start();
+ # Package dependencies tracking only:
+ Wrequire $W->{"__PACKAGE__"},"first"=>1;
do { $W->{$_}=0 if !defined $W->{$_}; } for "detect_ent";
do { $W->{$_}=0 if !defined $W->{$_}; } for "detect_js";
@@ -203,54 +202,278 @@ my($class,%args)=@_;
select *STDOUT;
$|=1;
- $W->{"QUERY_STRING"}=$W->{"r"}->args() || "";
- 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"}."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0]
- ."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect')
- .'" />'."\n";
+ $W->{"headers_in"}=$W->{"r"}->headers_in();
+ Wrequire 'My::Hash::Merge';
+ $W->{"headers_in"}=My::Hash::Merge->new(
+ $W->{"headers_in"},
+ My::Hash::Sub->new({
+ "_remote_ip"=>sub { return $W->{"r"}->connection()->remote_ip(); },
+ }),
+ );
+ Wrequire 'My::Hash::Readonly';
+ $W->{"headers_in"}=My::Hash::Readonly->new($W->{"headers_in"});
+
+ if ($W->{"r"}->method() eq "GET" || $W->{"r"}->method() eq "HEAD") {
+ for (\$W->{"http_safe"}) {
+ # Do not: # Extend the current ETag system instead if you would need it:
+ # cluck "Explicitely NOT HTTP-Safe for method \"".$W->{"r"}->method()."\"?!?"
+ # if defined($$_) && !$$_;
+ # as sometimes it just does not make sense to cache it.
+ $$_=1 if !defined $$_;
}
}
- $W->{"QUERY_STRING"}=~s/([&])amp;/$1/g;
- $W->{"r"}->args($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($W->{"r"})->Vars() };
- for my $name (keys(%{$W->{"args"}})) {
- my @vals=split /\x00/,$W->{"args"}{$name};
- next if @vals<=1;
- $W->{"args"}{$name}=[@vals];
+ else {
+ for (\$W->{"http_safe"}) {
+ cluck "Undefined HTTP-Safe-ty for method \"".$W->{"r"}->method()."\"!"
+ if !defined($$_);
+ $$_=0 if !defined $$_;
+ }
+ }
+ # Used only if: $W->{"http_safe"}
+ # but we would cause on different method(): Appending to the '_done' package list
+ Wrequire 'My::Hash::RecordKeys';
+ if ($W->{"http_safe"}) {
+ $W->{"headers_in_RecordKeys"}=My::Hash::RecordKeys->new($W->{"headers_in"});
+ $W->{"headers_in"}=$W->{"headers_in_RecordKeys"};
+ }
+
+ {
+ local $_=$W->{"r"}->args() || "";
+ if ($W->{"detect_ent"}) {
+ if (/[&]amp;have_ent/)
+ { $W->{"have_ent"}=0; }
+ elsif ( /[&]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"}."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0]
+ ."?".($_ || "detect_ent_glue=1").'&have_ent=detect')
+ .'" />'."\n";
+ }
+ }
+ s/([&])amp;/$1/g;
+ $W->{"r"}->args($_);
}
- 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->{"args"}=URI->new("?".$W->{"r"}->args())->query_form_hash();
+ $W->merge_post_args() if $W->{"r"}->method() eq "POST";
+ # Prepare '$args' first to (FIXME: Why?) prevent: Not a reference
+ my $args=$W->{"args"};
+ $W->{"args_orig"}=Storable::dclone($args);
- $W->{"browser"}=HTTP::BrowserDetect->new($W->{"user_agent"});
+ $W->{"browser"}=sub {
+ # Lazy-evaluation, we may not need the "User-Agent" header at all.
+ return our $r||=HTTP::BrowserDetect->new($W->{"headers_in"}{"User-Agent"});
+ };
if (!defined $W->{"have_style"}) {
- $W->{"have_style"}=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0);
+ $W->{"have_style"}=sub {
+ # Lazy-evaluation, we may not need the "User-Agent" header at all.
+ return our $r||=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0);
+ };
}
$W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0);
if ($W->{"detect_js"} && !$W->{"have_js"}) {
- $W->{"head"}.=''."\n";
+ # Do not:
+ # as at least Lynx inhibits any further HTML output.
+ # Do not: text/javascript
+ # as it does not look as registered, at least according to: MIME::Types $VERSION 1.15
+ # "application/javascript" so far standardized till 2005-12-08 by:
+ # http://www.ietf.org/internet-drafts/draft-hoehrmann-script-types-03.txt
+ $W->{"head"}.=''."\n";
}
- do { _args_check(%$_) if $_; } for ($W->{"args_check"});
+ # Required by &_args_check below.
+ $W->{"_init_done"}=1;
+
+ do { _args_check(%$_) if $_; } for $W->{"args_check"};
+
+ return $W;
+}
+
+sub form_method($)
+{
+my($method)=@_;
+
+ return q{enctype="application/x-www-form-urlencoded" accept-charset="us-ascii utf-8"} if $method eq "post";
+ return q{accept-charset="us-ascii utf-8"} if $method eq "get";
+ cluck "Undefined method: $method";
+ return ""
+}
+
+sub merge_post_args($)
+{
+my($class)=@_;
+
+ my @post_args=$class->read_post_args();
+ while (@post_args) {
+ my $name=shift @post_args;
+ my $data=shift @post_args;
+ my $ref=\$W->{"args"}{$name};
+ if (!defined $$ref) { $$ref=$data; }
+ elsif (!ref $$ref) { $$ref=[$$ref,$data]; }
+ elsif ("ARRAY" eq ref $$ref) { push @$$ref,$data; }
+ else {
+ cluck "Ignoring POST argument \"$name\", orig is weird:\n",Dumper($$ref);
+ }
+ }
+ return;
+}
+
+# Do not: use CGI;
+# as CGI parsing of POST vs. QUERY_STRING data, multiple-valued keys etc.
+# is too dense and causes weird problems, together with mod_perl etc.
+sub read_post_args($)
+{
+my($class)=@_;
- return bless $W,$class;
+ local $_=$class->http_headers_in_for("Content-type")->content_type();
+ return $class->read_multipart_form_data() if $_ eq "multipart/form-data";
+ return $class->read_application_x_www_form_urlencoded() if $_ eq "application/x-www-form-urlencoded";
+ cluck "Unknown POST data body, ignored: $_";
+ return;
}
-# Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself.
+sub read_application_x_www_form_urlencoded($)
+{
+my($class)=@_;
+
+ my $body="";
+ for (;;) {
+ my $got=$W->{"r"}->read(my($buf),0x1000);
+ # Do not: cluck "Error reading POST data: $!" if !defined $got;
+ # as it should be done using: APR::Error exceptions
+ last if !$got;
+ $body.=$buf;
+ }
+ return URI->new("?".$body)->query_form();
+}
+
+sub read_multipart_form_data($)
+{
+my($class)=@_;
+
+ my $parser=MIME::Parser->new();
+ # FIXME: No unlink()s done!
+ $parser->output_under("/tmp");
+
+ local *R_FH;
+ tie *R_FH,$W->{"r"};
+ local *FH;
+ tie *FH,"My::Web::ReadMerged",
+ join("",map(($_.": ".$W->{"headers_in"}{$_}."\n"),qw(
+ Content-type
+ )))."\n",
+ \*R_FH;
+ my $body=$parser->parse(\*FH);
+ cluck "No multipart POST request body?" if !$body->is_multipart();
+
+ return map((
+ $_->head()->mime_attr("content-disposition.name")
+ =>
+ join("",@{$_->body()})
+ ),$body->parts());
+
+ # TODO: Globalize, make it IO::* compatible, split to the merging part + IO::Scalar.
+ package My::Web::ReadMerged;
+
+ require Tie::Handle;
+ require Exporter;
+ our @ISA=qw(Tie::Handle Exporter);
+ use Carp qw(cluck confess);
+
+ sub READLINE($)
+ {
+ my($self)=@_;
+
+ confess "Slurp not yet implemented" if !defined $/;
+ # Apache2::RequestIO does not support 'READLINE'!
+ for (;;) {
+ if (defined $self->{"data"} && $self->{"data"}=~s{^.*\Q$/\E}{}) {
+ $self->{"offset"}+=length $&;
+ return $&;
+ }
+ my $fh_orig=$self->{"fh_orig"};
+ if (!$fh_orig) {
+ my $r=$self->{"data"};
+ delete $self->{"data"};
+ $self->{"offset"}+=length $r if defined $r;
+ return $r;
+ }
+ my $got=read $fh_orig,my($buf),0x1000;
+ cluck "Error reading POST data: $!" if !defined $got;
+ delete $self->{"fh_orig"} if !$got;
+ cluck "INTERNAL: fh_orig should not exist here" if !defined $self->{"data"};
+ $self->{"data"}.=$buf;
+ }
+ }
+
+ sub TELL($)
+ {
+ my($self)=@_;
+
+ return $self->{"offset"};
+ }
+
+ sub TIEHANDLE($$$)
+ {
+ my($class,$data,$fh_orig)=@_;
+
+ my $self=bless {},$class;
+ $self->{"data"}=$data;
+ $self->{"offset"}=0;
+ $self->{"fh_orig"}=$fh_orig;
+ return $self;
+ }
+}
+
+sub cleanup($)
+{
+my($apache_request)=@_;
+
+ cluck "CORE::GLOBAL::exit hook not ran" if !$W->{"_exit_done"};
+ cluck "packages not finalized" if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"};
+ cache_finish();
+ # Sanity protection.
+ $W=undef();
+ exit_hook_stop();
+ return OK;
+}
+
+# PerlResponseHandler is RUN_FIRST and &ModPerl::Util::exit returns OK, so no (sane) go.
+# PerlLogHandler is already too late to be able to produce any output.
+my $exit_orig;
+sub exit_hook
+{
+ cluck "Missing ->init while in exit_hook()" if !$W->{"_init_done"};
+ # &footer will call us recursively!
+ footer() if !$W->{"_exit_done"}++;
+ return &{$exit_orig}(@_);
+}
+sub exit_hook_start
+{
+ do { cluck "exit_hook_start() twice?"; return; } if defined $exit_orig;
+ $exit_orig=\&CORE::GLOBAL::exit;
+ # Prevent: Subroutine CORE::GLOBAL::exit redefined
+ no warnings 'redefine';
+ *CORE::GLOBAL::exit=\&exit_hook;
+}
+sub exit_hook_stop
+{
+ do { cluck "exit_hook_stop() without exit_hook_start()?"; return; }
+ if \&exit_hook ne \&CORE::GLOBAL::exit;
+ do { cluck "INTERNAL: exit_orig uninitialized"; return; }
+ if !$exit_orig;
+ # Prevent: Subroutine CORE::GLOBAL::exit redefined
+ no warnings 'redefine';
+ *CORE::GLOBAL::exit=$exit_orig;
+ $exit_orig=undef();
+}
+
+# Be aware other parts of code (non-My::Web) will NOT use this function!
# 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"}
@@ -262,43 +485,35 @@ my($text,%args)=@_;
cluck "undef Wprint" if !defined $text && !$args{"undef"};
delete $args{"undef"};
cluck join(" ","Invalid arguments:",keys(%args)) if keys(%args);
- $W->{"r"}->puts($text) if defined $text;
+ return if !defined $text;
+ # Do not: cluck "utf-8 untested" if Encode::is_utf8($text);
+ # as it is valid here.
+ $W->{"r"}->puts($text);
}
-sub escapeHTML($)
-{
-my($text)=@_;
-
- # Prevent &CGI::escapeHTML breaking utf-8 strings like: \xC4\x9B eq \x{11B}
- # Prevent case if we run under mod_perl but still just initializing:
- request_check() if $ENV{"MOD_PERL"};
- # Generally we are initialized from &init but we may be used without it without mod_perl
- # and in such case check the change on all non-first invocations.
- our $init;
- if (!$ENV{"MOD_PERL"} && $init++) {
- do { cluck "charset==$_" if $_ ne "utf-8"; } for CGI::charset();
- }
- CGI::charset("utf-8");
-
- return CGI::escapeHTML($text);
-}
-
-# local *FH;
-# tie *FH,ref($W),$W;
-sub TIEHANDLE($)
+sub request_check(;$)
{
-my($class,$W)=@_;
+my($self)=@_;
- my $self={};
- $self->{"W"}=$W or confess "Missing W";
- return bless $self,$class;
+ # Use &eval to prevent: Global $r object is not available. Set:\n\tPerlOptions +GlobalRequest\nin ...
+ confess "Calling sensitive dynamic code from a static code" if !eval { Apache2::RequestUtil->request(); };
+ # Do not: confess "Calling sensitive dynamic code without My::Web::init" if !$W->{"__PACKAGE__"};
+ # as it is valid at least while preparing arguments to call: &project::Lib::init
}
-sub WRITE
+# Do not: use CGI;
+# as it is too much backward compatible regarding the charset encodings etc.
+# and the resulting code is too dense with no additional functionality for the recent content.
+sub escapeHTML($)
{
-my($self,$scalar,$length,$offset)=@_;
+my($text)=@_;
- Wprint substr($scalar,0,$length);
+ local $_=$text;
+ s{&}{&}gso;
+ s{<}{<}gso;
+ s{>}{>}gso;
+ s{"}{"}gso;
+ return $_;
}
# /home/user/www/webdir
@@ -364,6 +579,7 @@ my($in,%args)=@_;
my $uri=in_to_uri_abs($in);
if (uri_is_local($uri)) {
# Prefer the $uri values over "args_persistent" values.
+ # &query_form_hash comes from: URI::QueryParam
$uri->query_form_hash({
map({
my $key=$_;
@@ -377,6 +593,13 @@ my($in,%args)=@_;
return $uri->rel(unparsed_uri());
}
+sub path_abs_disk_register($)
+{
+my($path_abs_disk)=@_;
+
+ $W->{"path_abs_disk_register"}{$path_abs_disk}=1;
+}
+
# $args{"uri_as_in"}=1 to permit passing URI objects as: $in
sub path_abs_disk($%)
{
@@ -387,7 +610,9 @@ my($in,%args)=@_;
cluck if !uri_is_local($uri);
my $path=$uri->path();
cluck "URI compatibility: ->path() not w/leading slash of URI \"$uri\"; path: $path" if $path!~m{^/};
- return dir_top_abs_disk().$path;
+ my $r=dir_top_abs_disk().$path;
+ path_abs_disk_register $r if !defined $args{"register"} || $args{"register"};
+ return $r;
}
sub fatal (;$);
@@ -434,26 +659,44 @@ my($msg)=@_;
if (!$W->{"heading_done"}) {
$W->{"indexme"}=0; # For the case no heading was sent yet.
$W->{"header_only"}=0; # assurance for &heading
+ $W->{"content_type"}="text/html"; # Force HTML and avoid strictly checked XHTML.
My::Web->heading();
}
Wprint "\n".vskip("3ex")."
FATAL ERROR: $msg!
\n"
."You can report this problem's details to"
." ".a_href("mailto:".$W->{"admin_mail"},"admin of this website").".
\n";
- footer();
+ exit;
}
-sub footer (;$)
+sub footer_packages_used_comments()
{
- exit 1 if $W->{"footer_passed"}++; # deadlock prevention:
-
- Wprint vskip if $W->{"footer_delimit"};
+ my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}};
+ for my $package (@$packages_used) {
+ my $cvs_id=(eval('$'.$package."::CVS_ID")
+# || $package # debug
+ );
+ Wprint ''."\n" if $cvs_id;
+ }
+}
- do { Wprint $_ if $_; } for $W->{"footing_delimit"};
+sub footer()
+{
+ cluck 'Explicit &footer call is deprecated, !_exit_dne' if !$W->{"_exit_done"};
+ exit if $W->{"footer_done"}++; # deadlock prevention:
+ &{$_}() for reverse @{$W->{"footer_sub_push"}};
+ if ($W->{"header_only"}) {
+ $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
+ exit;
+ }
+ Wprint vskip if $W->{"footer_delimit"};
+ &{$_}() for reverse @{$W->{"footing_delimit_sub_push"}};
Wprint "
\n" if $W->{"footer"};
- my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}};
+ # Never update the package list while we examine it!
+ $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
+ my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}};
if ($W->{"footer_ids"}) {
Wprint '';
Wprint join("
\n",map({ my $package=$_;
@@ -479,11 +722,17 @@ sub footer (;$)
cluck "Class file $file not found; tried: ".join(" ",@tried) if !$ext;
}
$file.=$ext;
+ my $viewcvs;
+ if ((my $file_cvs=$file)=~s{^My/}{}) {
+ $viewcvs=$W->{"viewcvs_My"}.$file_cvs;
+ }
+ else {
+ $viewcvs=$W->{"viewcvs"}.$file;
+ }
$cvs_id_split[2]=""
- .a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $W->{"viewcvs"}))[0]."$file?rev=".$cvs_id_split[2],
+ .a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $viewcvs))[0]."?rev=".$cvs_id_split[2],
$cvs_id_split[2]);
- $cvs_id_split[1]=a_href($W->{"viewcvs"}.$file,
- ($package!~/^Apache2::/ ? $package : $cvs_id_split[1]));
+ $cvs_id_split[1]=a_href($viewcvs,($package!~/^Apache2::/ ? $package : $cvs_id_split[1]));
$cvs_id_split[5]=&{$W->{"cvs_id_author_sub"}}($cvs_id_split[5]);
}
join " ",@cvs_id_split;
@@ -492,30 +741,22 @@ sub footer (;$)
Wprint "
\n";
}
- for my $package (@$packages_used) {
- my $cvs_id=(eval('$'.$package."::CVS_ID")
-# || $package # debug
- );
- Wprint ''."\n" if $cvs_id;
- }
+ footer_packages_used_comments();
do { Wprint $_ if $_; } for $W->{"footing"};
Wprint "