&img ¢erimg &rightimg
$W
&input_hidden_persistents
+ &escapeHTML
);
our @ISA=qw(Tie::Handle Exporter);
+my %packages_used_hash;
+my %packages_used_array;
+
BEGIN
{
use Carp qw(cluck confess);
for my $target ($class,__PACKAGE__) {
for my $caller (keys(%callers)) {
next if $caller eq $target;
- next if $W->{'packages_used%'}{$caller}{$target}++;
- push @{$W->{'packages_used@'}{$caller}},$target;
+ next if $packages_used_hash{$caller}{$target}++;
+ push @{$packages_used_array{$caller}},$target;
}
}
eval { CORE::require "$file"; } or confess $@;
}
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);
# I do not know why.
use POSIX qw(strftime);
use Tie::Handle;
-use Apache2::Const qw(HTTP_MOVED_TEMPORARILY);
+use Apache2::Const qw(HTTP_MOVED_TEMPORARILY OK);
use URI;
use URI::QueryParam;
use Cwd;
# $W->{"footer_passed"}
# %{$W->{"headers"}}
# %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key
- # @{$W->{'packages_used@'}{callers...}}
- # %{$W->{'packages_used%'}{callers...}}
# %{$W->{"args"}}
+sub cleanup($)
+{
+my($apache_request)=@_;
+
+ # 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)=@_;
Wuse 'WebConfig';
Wrequire 'My::Hash::Sub';
- my $packages_used_array_save=$W->{'packages_used@'};
- my $packages_used_hash_save =$W->{'packages_used%'};
$W={};
tie %$W,"My::Hash::Sub";
%$W=(%WebConfig,%args); # override %WebConfig settings
- $W->{'packages_used@'}=$packages_used_array_save;
- $W->{'packages_used%'}=$packages_used_hash_save;
$W->{"__PACKAGE__"}||=caller();
# {"__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");
+
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.
$W->{"r"}=Apache2::RequestUtil->request();
+ $W->{"r"}->push_handlers("PerlCleanupHandler"=>\&cleanup);
+
+ $W->{"web_hostname"}||=$W->{"r"}->hostname();
+
tie *STDOUT,$W->{"r"};
select *STDOUT;
$|=1;
$W->{"head"}.='<script type="text/javascript" src="'.path_web('/have_js.pm').'"></script>'."\n";
}
- do { args_check(%$_) if $_; } for ($W->{"args_check"});
-
- $ENV{"HOSTNAME"}||=$W->{"web_hostname"};
+ 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
my $r=Apache2::RequestUtil->request();
cluck "Calling ".'&unparsed_uri'." from a static code, going to fail" if !$r;
my $uri_string=$r->unparsed_uri() or cluck "Valid 'r' missing unparsed_uri()?";
- my $uri=URI->new_abs($uri_string,"http://".($W->{"web_hostname"}||$WebConfig{"web_hostname"})."/");
+ my $uri=URI->new_abs($uri_string,"http://".$W->{"web_hostname"}."/");
$W->{"unparsed_uri"}=$uri;
}
return $W->{"unparsed_uri"};
}
# $args{"uri_as_in"}=1 to permit passing URI objects as: $in
+# $args{"abs"}=1;
sub path_web($%)
{
my($in,%args)=@_;
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"};
- my $packages_used=$W->{'packages_used@'}{$W->{"__PACKAGE__"}};
+ my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}};
if ($W->{"footer_ids"}) {
Wprint '<p class="cvs-id">';
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
return escapeHTML(path_web('/Redirect.pm?location='.uri_escape($uri->abs(unparsed_uri()))));
}
+our $a_href_inhibited;
sub a_href($;$%)
{
my($in,$contents,%args)=@_;
+ request_check();
do { $$_=1 if !defined $$_; } for (\$args{"size"});
if (!defined $contents) {
$contents=$in;
}
$contents=~s#<a\b[^>]*>##gi;
$contents=~s#</a>##gi;
+ return $contents if $a_href_inhibited;
my $path_web=path_web $in,%args;
my $r="";
return $r;
}
+sub a_href_inhibit($$;@)
+{
+my($self,$sub,@sub_args)=@_;
+
+ local $a_href_inhibited=1;
+ return &{$sub}(@sub_args);
+}
+
sub input_hidden_persistents()
{
+ request_check();
return join("",map({
my $key=$_;
my $val=$W->{"args"}{$key};
# Do not: HTTP::Headers->new($W->{"r"}->headers_in());
# to prevent empty result or even: Odd number of elements in anonymous hash
HTTP::Headers->new(%{$W->{"r"}->headers_in()}));
- $best||=$variants->[0]{"id"}; # &HTTP::Negotiate::choose failed?
+ $best||=$variants->[0][0]; # $variants->[0]{"id"}; &HTTP::Negotiate::choose failed?
return $best;
}
{
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;
# FIXME: It is not clean to still append them without overwriting.
return if $W->{"heading_done"}++;
- my $lang=($W->{"language"}||"en-US");
# Workaround bug
# https://bugzilla.mozilla.org/show_bug.cgi?id=120556
# of at least
"content-type"=>"text/html",
"qs"=>0.6,
"charset"=>$client_charset,
- "lang"=>$lang,
+ "lang"=>$W->{"language"},
),
negotiate_variant(
"id"=>"application/xhtml+xml",
"content-type"=>"application/xhtml+xml",
"qs"=>0.6,
"charset"=>$client_charset,
- "lang"=>$lang,
+ "lang"=>$W->{"language"},
),
# application/xml ?
# text/xml ?
]);
$W->{"r"}->content_type("$mime; charset=$client_charset");
Wprint '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n" if $mime=~m{^application/\w+[+]xml$};
+ return if $W->{"xml_header_only"};
Wprint '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">'."\n";
- Wprint '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="'.$lang.'">'."\n";
+ Wprint '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="'.$W->{"language"}.'">'."\n";
my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ())));
+ # Do not: cluck if $title=~/[<>]/;
+ # as it is not solved just by: &a_href_inhibit
+ # as sometimes titles use also: <i>...</i>
$title=~s#<[^>]*>##g;
Wprint "<head>";
Wprint "<title>$title</title>\n";
if ($W->{"have_css"}) {
# Everything can get overriden later.
- Wprint <<"HERE";
-<link rel="stylesheet" type="text/css" href="@{[ uri_escaped(path_web "/My/Web.css") ]}" />
+ for my $css ("/My/Web.css",map((!$_ ? () : ("ARRAY" ne ref($_) ? $_ : @$_)),$W->{"css_push"})) {
+ Wprint <<"HERE";
+<link rel="stylesheet" type="text/css" href="@{[ uri_escaped(path_web $css) ]}" />
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