&img ¢erimg &rightimg
$W
&input_hidden_persistents
+ &escapeHTML
);
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
}
use WebConfig; # see also below: Wuse 'WebConfig';
-require CGI; # for &escapeHTML
+require CGI;
require Image::Size; # for &imgsize
use File::Basename; # &basename
use Carp qw(cluck confess);
use URI;
use URI::QueryParam;
use Cwd;
+require HTTP::Date;
#our $W;
{
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 ($%)
{
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.
do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__";
- 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 ("footer");
- do { $W->{$_}=1 if !defined $W->{$_}; } for ("footer_delimit");
- 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 ("body_attr");
- do { $W->{$_}="en-US" if !defined $W->{$_}; } for ("language");
+ # See: &escapeHTML
+ do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset();
+ CGI::charset("utf-8");
+
+ 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->{$_}=0 if !defined $W->{$_}; } for "css_inherit";
+ 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_ids";
+ do { $W->{$_}=1 if !defined $W->{$_}; } for "indexme";
+ do { $W->{$_}="" if !defined $W->{$_}; } for "head";
+ do { $W->{$_}="" if !defined $W->{$_}; } for "body_attr";
+ do { $W->{$_}="en-US" if !defined $W->{$_}; } for "language";
my $footer_any=0;
for (qw(footer_ids)) {
$W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0);
if ($W->{"detect_js"} && !$W->{"have_js"}) {
- $W->{"head"}.='<script type="text/javascript" src="'.path_web('/have_js.pm').'"></script>'."\n";
+ $W->{"head"}.='<script type="text/javascript" src="'.uri_escaped(path_web('/have_js.pm')).'"></script>'."\n";
}
- do { args_check(%$_) if $_; } for ($W->{"args_check"});
+ do { _args_check(%$_) if $_; } for ($W->{"args_check"});
return bless $W,$class;
}
# Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself.
+# 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"}
+# as we use a lot of 'for $W->{"heading"}' which instantiates it with the value: undef()
sub Wprint($%)
{
my($text,%args)=@_;
{
my($text)=@_;
- # 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 dynamic URL generator from a static code" if !eval { Apache2::RequestUtil->request(); };
+ # 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);
}
sub unparsed_uri()
{
+ request_check();
if (!$W->{"unparsed_uri"}) {
# Do not: $W->{"r"}
# as we may be called before &init from: &My::Project::init
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($%)
{
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 (;$);
-sub args_check (%)
+sub _args_check (%)
{
my(%tmpl)=@_;
Wprint vskip if $W->{"footer_delimit"};
- Wprint $W->{"footing_delimit"},"undef"=>1;
+ do { Wprint $_ if $_; } for $W->{"footing_delimit"};
Wprint "<hr />\n" if $W->{"footer"};
Wprint '<!-- '.$package.' - $'.$cvs_id.'$ -->'."\n" if $cvs_id;
}
- Wprint $W->{"footing"},"undef"=>1;
+ do { Wprint $_ if $_; } for $W->{"footing"};
Wprint "</body></html>\n";
exit 0;
cluck if !ref $uri;
my $urient=escapeHTML($uri);
return $uri if $uri eq $urient;
+ request_check();
return $urient if uri_is_local $uri;
return $uri if defined $W->{"have_ent"} && !$W->{"have_ent"}; # non-ent client
return $urient if $W->{"have_ent"}; # ent client
{
my($in,$contents,%args)=@_;
+ request_check();
do { $$_=1 if !defined $$_; } for (\$args{"size"});
if (!defined $contents) {
$contents=$in;
sub input_hidden_persistents()
{
+ request_check();
return join("",map({
my $key=$_;
my $val=$W->{"args"}{$key};
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;
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,
{
my($in,$alt,%args)=@_;
+ request_check();
my($path_web,$path_abs_disk)=_img_src($in,%args);
my($width,$height)=Image::Size::imgsize($path_abs_disk);
$alt=~s/<[^>]*>//g;
{
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()
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"}})) {
<link rel="stylesheet" type="text/css" href="@{[ uri_escaped(path_web $css) ]}" />
HERE
}
+ if ($W->{"css_inherit"}) {
+ Wprint <<"HERE";
+<script type="text/javascript" src="@{[ uri_escaped(path_web('/My/css_inherit.js')) ]}" />
+HERE
+ }
}
Wprint '<meta name="robots" content="'.($W->{"indexme"} ? "" : "no" ).'index,follow" />'."\n";
Wprint $W->{"head"};
Wprint $W->{"body_attr"};
Wprint ">\n";
- Wprint $W->{"heading"},"undef"=>1;
+ do { Wprint $_ if $_; } for $W->{"heading"};
}
BEGIN {
git://git.jankratochvil.net / MyWeb.git / blobdiff