My::Hash::* reimplementation for separate feature add-on packages (cleanup).

[MyWeb.git] / Web.pm

diff --git a/Web.pm b/Web.pm
index 10bc1da..c368a4b 100644 (file)
--- a/Web.pm
+++ b/Web.pm
@@ -40,7 +40,7 @@ our @EXPORT=qw(
                );
 our @ISA=qw(Tie::Handle Exporter);
 
-my %packages_used_hash;
+my %packages_used_hash;        # $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
 my %packages_used_array;
 
 BEGIN
@@ -114,6 +114,7 @@ use Apache2::Const qw(HTTP_MOVED_TEMPORARILY OK);
 use URI;
 use URI::QueryParam;
 use Cwd;
+require HTTP::Date;
 
 
 #our $W;
@@ -130,6 +131,7 @@ sub cleanup($)
 {
 my($apache_request)=@_;
 
+       $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
        # Sanity protection.
        $W=undef();
        return OK;
@@ -156,12 +158,13 @@ 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';
+       Wrequire 'My::Hash';
 
-       $W={};
-       tie %$W,"My::Hash::Sub";
-       %$W=(%WebConfig,%args); # override %WebConfig settings
-       $W->{"__PACKAGE__"}||=caller();
+       $W=My::Hash->new({
+               "__PACKAGE__"=>scalar(caller()),
+               %WebConfig,
+               %args,  # override %WebConfig settings
+               },"My::Hash::Sub","My::Hash::Push");
 
        # {"__PACKAGE__"} is mandatory for mod_perl-2.0;
        # $Apache2::Registry::curstash is no longer supported.
@@ -375,6 +378,15 @@ my($in,%args)=@_;
        return $uri->rel(unparsed_uri());
 }
 
+my %path_abs_disk_for_package; # $path_abs_disk_for_package{$W->{"__PACKAGE__"}}{$path_abs_disk}=1;
+
+sub path_abs_disk_register($)
+{
+my($path_abs_disk)=@_;
+
+       $path_abs_disk_for_package{$W->{"__PACKAGE__"}}{$path_abs_disk}=1;
+}
+
 # $args{"uri_as_in"}=1 to permit passing URI objects as: $in
 sub path_abs_disk($%)
 {
@@ -385,7 +397,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 (;$);
@@ -724,7 +738,7 @@ my($in,%args)=@_;
 
        cluck if !uri_is_local $in;
        my $uri=in_to_uri_abs $in;
-       my $path_abs_disk=path_abs_disk $uri,%args,"uri_as_in"=>1;
+       my $path_abs_disk=path_abs_disk $uri,%args,"uri_as_in"=>1,"register"=>0;
 
        # Known image extension?
        return path_web($uri,%args,"uri_as_in"=>1),$path_abs_disk if $uri->path()=~m#$img_variants_re#o;
@@ -732,6 +746,7 @@ my($in,%args)=@_;
        my @nego_variants;
        for my $var (@img_variants) {
                my $path_abs_disk_variant=$path_abs_disk.".".$var->{"id"};
+               path_abs_disk_register($path_abs_disk_variant);
                __PACKAGE__->make_file($path_abs_disk_variant);
                push @nego_variants,negotiate_variant(
                                %$var,
@@ -810,10 +825,45 @@ sub no_cache($)
 {
 my($self)=@_;
 
-       header("Expires"=>"Mon, 26 Jul 1997 05:00:00 GMT");     # date in the past
-       header("Last-Modified"=>strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime()));        # always modified
-       header("Cache-Control"=>"no-cache, must-revalidate");   # HTTP/1.1
+       header("Expires"=>HTTP::Date::time2str(1000000000));    # date in the past
+       header("Last-Modified"=>HTTP::Date::time2str());        # always modified
+       header("Cache-Control"=>join(", ",
+                       "no-cache",
+                       "no-store",
+                       "must-revalidate",
+                       "max-age=0",
+                       "pre-check=0",  # MSIE
+                       "post-check=0", # MSIE
+                       ));     # HTTP/1.1
        header("Pragma"=>"no-cache");   # HTTP/1.0
+       header("Vary"=>"*");    # content may ba based on unpredictable sources
+}
+
+sub last_modified($)
+{
+my($self)=@_;
+
+       return if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"};
+       our %path_abs_disk_registered;
+       if (!$path_abs_disk_registered{$W->{"__PACKAGE__"}}++) {
+               for my $package_orig (@{$packages_used_array{$W->{"__PACKAGE__"}}}) {
+                       local $_=$package_orig.".pm";
+                       s{::}{/}g;
+                       path_abs_disk "/$_","register"=>1;
+                       }
+               }
+       my $mtime_newest;
+       for my $path_abs_disk (keys(%{$path_abs_disk_for_package{$W->{"__PACKAGE__"}}})) {
+###print STDERR "CHECK:$path_abs_disk\n";
+               my $mtime=(stat $path_abs_disk)[9];
+               do { cluck "No mtime for: $path_abs_disk"; next; } if !$mtime;
+               $mtime_newest=$mtime if !$mtime_newest || $mtime_newest<$mtime;
+               }
+       cluck "No mtime_newest found for the current W __PACKAGE__: ".$W->{"__PACKAGE__"}
+                       if !$mtime_newest;
+       # "Vary" header is REQUIRED in this case:
+       header("Last-Modified"=>HTTP::Date::time2str($mtime_newest));
+       return 1;
 }
 
 sub heading()
@@ -825,6 +875,7 @@ my($class)=@_;
        header("Content-Style-Type"=>"text/css");
        header("Content-Script-Type"=>"text/javascript");
        do { header("Content-Language"=>$_) if $_; } for $W->{"language"};
+       $class->last_modified() if !$W->{"no_cache"};
        $class->no_cache() if $W->{"no_cache"};
 
        while (my($key,$val)=each(%{$W->{"headers"}})) {