Provide 'tie' capability with 'My::Web' classname for output &Wprint.

[MyWeb.git] / Web.pm

diff --git a/Web.pm b/Web.pm
index 5709a63..ea9b928 100644 (file)
--- a/Web.pm
+++ b/Web.pm
@@ -28,7 +28,7 @@ sub Wrequire ($);
 sub Wuse ($@);
 our $W;
 our @EXPORT=qw(&Wrequire &Wuse &a_href &a_href_cz &vskip &img &centerimg &rightimg $W &top_dir &top_dir_disk &Wprint);
-our @ISA=qw(Exporter);
+our @ISA=qw(Exporter Tie::Handle);
 
 BEGIN
 {
@@ -75,6 +75,8 @@ require HTTP::BrowserDetect;
 require HTTP::Negotiate;
 my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; }
 use ModPerl::Util qw(exit);
+use POSIX qw(strftime);
+use Tie::Handle;
 
 
 #our $W;
@@ -170,14 +172,32 @@ my($class,%args)=@_;
 
        $ENV{"HOSTNAME"}||=&{$W->{"web_hostname_sub"}}();
 
-       return $W;
+       return bless $W,$class;
 }
 
 sub Wprint($)
 {
 my($text)=@_;
 
-       $W->{"r"}->print($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 ()
@@ -607,6 +627,16 @@ my(@arr)=@_;
        return @r;
 }
 
+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("Pragma"=>"no-cache");   # HTTP/1.0
+}
+
 sub heading ()
 {
 my($class)=@_;
@@ -617,6 +647,7 @@ my($class)=@_;
        my $client_charset=$W->{"force_charset"} || "us-ascii";
        header("Content-Style-Type"=>"text/css");
        header("Content-Script-Type"=>"text/javascript");
+       $class->no_cache() if $W->{"no_cache"};
 
        while (my($key,$val)=each(%{$W->{"headers"}})) {
                $W->{"r"}->header_out($key,$val);