jwalt 2003/06/18 06:30:08
Modified: lib AxKit.pm
lib/Apache/AxKit Cache.pm
lib/Apache/AxKit/Language XSP.pm
lib/Apache/AxKit/Language/XSP SimpleTaglib.pm
Log:
- fix SimpleTaglib bugs regarding childStruct
- add XSP on-disk cache of compiled scripts (essential for debug mode)
- turn off XSP debug mode, extremely slow
- make Cache.pm perl5.8.0/utf8 clean
- make AxTraceIntermediate utf8-clean
Revision Changes Path
1.44 +14 -3 xml-axkit/lib/AxKit.pm
Index: AxKit.pm
===================================================================
RCS file: /home/cvs/xml-axkit/lib/AxKit.pm,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- AxKit.pm 18 Mar 2003 15:20:46 -0000 1.43
+++ AxKit.pm 18 Jun 2003 13:30:06 -0000 1.44
@@ -35,6 +35,17 @@
# AxKit Utility Functions
###############################################################
+sub open(*$;$) {
+ my $res = open($_[0],$_[1]);
+ binmode($_[0],($] >= 5.008?(':'.($_[2]||'utf8')):()));
+ return $res;
+}
+sub sysopen(*$$;$) {
+ my $res = sysopen($_[0],$_[1],$_[2]);
+ binmode($_[0],($] >= 5.008?(':'.($_[2]||'utf8')):()));
+ return $res;
+}
+
sub FromUTF8($) {
if (!$AxKit::Cfg->{from_utf8}) {
return $_[0] if (exists $AxKit::Cfg->{from_utf8});
@@ -695,8 +706,8 @@
if ($interm_prefix) {
my $fh = Apache->gensym();
- if (sysopen($fh, $interm_prefix.$interm_count,
O_WRONLY|O_CREAT|O_TRUNC)) {
- syswrite($fh,${$provider->get_strref});
+ if (open($fh, ">".$interm_prefix.$interm_count)) {
+ print $fh ${$provider->get_strref};
close($fh);
$interm_count++;
} else {
1.10 +7 -6 xml-axkit/lib/Apache/AxKit/Cache.pm
Index: Cache.pm
===================================================================
RCS file: /home/cvs/xml-axkit/lib/Apache/AxKit/Cache.pm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- Cache.pm 25 Dec 2002 17:59:21 -0000 1.9
+++ Cache.pm 18 Jun 2003 13:30:07 -0000 1.10
@@ -9,6 +9,7 @@
use Digest::MD5 ();
use Compress::Zlib qw(gzopen);
use Fcntl qw(:flock O_RDWR O_WRONLY O_CREAT O_RDONLY);
+use bytes;
# use vars qw/$COUNT/;
@@ -110,7 +111,7 @@
AxKit::Debug(7, "[Cache] writing cache file $self->{file}");
my $fh = Apache->gensym();
my $tmp_filename = $self->{file}."new$$";
- if (sysopen($fh, $tmp_filename, O_WRONLY|O_CREAT)) {
+ if (AxKit::sysopen($fh, $tmp_filename, O_WRONLY|O_CREAT, 'raw')) {
# flock($fh, LOCK_EX);
# seek($fh, 0, 0);
# truncate($fh, 0);
@@ -141,7 +142,7 @@
my $self = shift;
return if $self->{no_cache};
my $fh = Apache->gensym();
- if (sysopen($fh, $self->{file}, O_RDONLY)) {
+ if (AxKit::sysopen($fh, $self->{file}, O_RDONLY, 'raw')) {
flock($fh, LOCK_SH);
local $/;
return <$fh>;
@@ -155,7 +156,7 @@
my $self = shift;
return if $self->{no_cache};
my $fh = Apache->gensym();
- if (sysopen($fh, $self->{file}, O_RDONLY)) {
+ if (AxKit::sysopen($fh, $self->{file}, O_RDONLY, 'raw')) {
flock($fh, LOCK_SH);
return $fh;
}
@@ -169,7 +170,7 @@
return if $self->{no_cache};
my $fh = Apache->gensym();
- if (sysopen($fh, $self->{file}.'newtype', O_RDWR|O_CREAT)) {
+ if (AxKit::sysopen($fh, $self->{file}.'newtype', O_RDWR|O_CREAT, 'raw'))
{
flock($fh, LOCK_EX);
seek($fh, 0, 0);
truncate($fh, 0);
@@ -187,7 +188,7 @@
my $self = shift;
return if $self->{no_cache};
my $fh = Apache->gensym();
- if (sysopen($fh, $self->{file}.'.type', O_RDONLY)) {
+ if (AxKit::sysopen($fh, $self->{file}.'.type', O_RDONLY, 'raw')) {
flock($fh, LOCK_SH);
local $/;
return <$fh>;
1.40 +15 -7 xml-axkit/lib/Apache/AxKit/Language/XSP.pm
Index: XSP.pm
===================================================================
RCS file: /home/cvs/xml-axkit/lib/Apache/AxKit/Language/XSP.pm,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- XSP.pm 18 Mar 2003 15:18:20 -0000 1.39
+++ XSP.pm 18 Jun 2003 13:30:07 -0000 1.40
@@ -3,11 +3,13 @@
package Apache::AxKit::Language::XSP;
use strict;
+use AxKit;
use Apache::AxKit::Language;
use Apache::Request;
use Apache::AxKit::Exception;
use Apache::AxKit::Cache;
use Fcntl;
+use utf8;
use vars qw/@ISA/;
@@ -49,7 +51,7 @@
my $handler = AxKit::XSP::SAXHandler->new_handler(
XSP_Package => $package,
XSP_Line => $key,
- XSP_Debug => 1,
+ XSP_Debug => 0,
);
my $parser = AxKit::XSP::SAXParser->new(
provider => $xml,
@@ -77,6 +79,7 @@
}
}
else {
+ my $xcache = Apache::AxKit::Cache->new($r, $package, 'compiled
XSP');
# check mtime.
my $mtime = $xml->mtime();
no strict 'refs';
@@ -86,15 +89,18 @@
)
{
# cached
- AxKit::Debug(5, 'XSP: xsp script cached');
- }
- else {
+ AxKit::Debug(5, 'XSP: xsp script cached in memory');
+ } elsif (!$xml->has_changed($xcache->mtime())) {
+ AxKit::Debug(5, 'XSP: xsp script cached on disk');
+ $to_eval = $xcache->read();
+ } else {
AxKit::Debug(5, 'XSP: parsing fh');
$to_eval = eval {
$parser->parse($xml->get_fh());
} || $parser->parse(${ $xml->get_strref() });
$cache->{$key}{mtime} = $mtime;
+ $xcache->write($to_eval);
}
}
};
@@ -127,11 +133,12 @@
if ($AxKit::Cfg->TraceIntermediate) {
my $interm_prefix = $r->uri;
- $interm_prefix =~ s{/}{|}g;
+ $interm_prefix =~ s{%}{%25}g;
+ $interm_prefix =~ s{/}{%2f}g;
$interm_prefix =~ s/[^0-9a-zA-Z.,_|-]/_/g;
$interm_prefix =
$AxKit::Cfg->TraceIntermediate.'/'.$interm_prefix;
my $fh = Apache->gensym();
- if (open($fh, '>'.$interm_prefix.'.XSP')) {
+ if (AxKit::open($fh, '>'.$interm_prefix.'.XSP')) {
print($fh $to_eval);
} else {
AxKit::Debug(1,"could not open $interm_prefix.XSP for
writing: $!");
@@ -349,6 +356,7 @@
"use Apache::Constants qw(:common);",
"use XML::LibXML;",
"Apache::AxKit::Language::XSP::Page->import(
qw(__mk_text_node __mk_comment_node __mk_ns_element_node __mk_element_node) );",
+ ($] >= 5.008?"use utf8;":""),
);
foreach my $ns (keys %Apache::AxKit::Language::XSP::tag_lib) {
1.8 +29 -11 xml-axkit/lib/Apache/AxKit/Language/XSP/SimpleTaglib.pm
Index: SimpleTaglib.pm
===================================================================
RCS file: /home/cvs/xml-axkit/lib/Apache/AxKit/Language/XSP/SimpleTaglib.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- SimpleTaglib.pm 29 Jan 2003 01:35:50 -0000 1.7
+++ SimpleTaglib.pm 18 Jun 2003 13:30:08 -0000 1.8
@@ -36,10 +36,11 @@
for my $spec ($_[0]) {
my $result = {};
while (length($spec)) {
- (my ($type, $token, $next) = ($spec =~ m/^([\&[EMAIL
PROTECTED])([^ {}]+)(.|$)/))
+ $spec = substr($spec,1), return $result if (substr($spec,0,1) eq
'}');
+ (my ($type, $token, $next) = ($spec =~ m/^([!\&[EMAIL
PROTECTED])([^ {}]+)(.|$)/))
|| die("childStruct specification invalid. Parse error at:
'$spec'");
substr($spec,0,length($token)+1+($type?1:0)) = '';
- #warn("type: $type, token: $token, next: $next");
+ #warn("type: $type, token: $token, next: $next, spec: $spec");
my ($realtoken, $params);
if ((($realtoken,$params) = ($token =~ m/^([^\(]+)((?:\([^
\)]+\))+)$/))) {
my $i = 0;
@@ -58,8 +59,12 @@
next;
}
$$result{$token}{'type'} = $type || '$';
- die("childStruct specification invalid. '*' cannot be used with
'{'.")
- if ($next eq '{' and $type eq '*');
+ die("childStruct specification invalid. '${type}' cannot be used
with '{'.")
+ if ($next eq '{' and ($type eq '*' || $type eq '!'));
+ die("childStruct specification invalid. '${type}' cannot be used
with '(,,,)'.")
+ if ($$result{$token}{'param'} and ($type eq '*' || $type eq
'!'));
+ die("childStruct specification invalid. '**' is not supported.")
+ if ($token eq '*' and $type eq '*');
$$result{''}{'name'} = $token if ($type eq '*');
$$result{$token}{'name'} = $token;
return $result if (!$next || $next eq '}');
@@ -151,7 +156,8 @@
my $spec = $param[0];
#warn("parsing $spec");
$spec =~ s/\s+/ /g;
- $spec =~ s/ ?([{}]) ?/$1/g;
+ $spec =~ s/ ?{ ?/{/g;
+ $spec =~ s/ ?} ?/}/g;
$$handlerAttributes{'struct'} = parseChildStructSpec($spec,{});
#warn("parsed $param[0], got
".serializeChildStructSpec($$handlerAttributes{'struct'}));
die("childStruct parse error") unless
$$handlerAttributes{'struct'};
@@ -307,6 +313,7 @@
return '; ';
}
+my @ignore;
sub set_childStruct_value__open {
my ($e, $tag, %attribs) = @_;
my $var = '$_{'.makeSingleQuoted($tag).'}';
@@ -316,6 +323,13 @@
return '';
}
my $desc = $$structStack[0][0]{'sub'}{$tag};
+ if (!$desc) {
+ $desc = $$structStack[0][0]{'sub'}{'*'};
+ #warn("$tag desc: ".Data::Dumper::Dumper($desc));
+ }
+ die("Tag $tag not found in childStruct specification.") if (!$desc);
+ push(@ignore, 1), return '' if ($$desc{'type'} eq '!');
+ push @ignore, 0;
unshift @{$$structStack[0]},$desc;
if ($$desc{'param'}) {
$e->append_to_script("{ \n");
@@ -363,6 +377,8 @@
return '';
}
my $desc = $$structStack[0][0];
+ my $ignore = pop @ignore;
+ return '' if ($ignore);
shift @{$$structStack[0]};
if ($$desc{'sub'}) {
$e->append_to_script(' \%_; }; ');
@@ -576,14 +592,16 @@
if ($$structStack[0][0]{'param'} && exists
$$structStack[0][0]{'param'}{$tag}) {
$sub = \&set_childStruct_value;
$subOpen = \&set_childStruct_value__open;
- } elsif ($$structStack[0][0]{'sub'} && exists
$$structStack[0][0]{'sub'}{$tag}) {
- if ($$structStack[0][0]{'sub'}{$tag}{'sub'}) {
- foreach my $key (keys
%{$$structStack[0][0]{'sub'}{$tag}{'sub'}}) {
+ } elsif ($$structStack[0][0]{'sub'} && (exists
$$structStack[0][0]{'sub'}{$tag} || exists $$structStack[0][0]{'sub'}{'*'})) {
+ my $tkey = $tag;
+ $tkey = '*' if (!exists $$structStack[0][0]{'sub'}{$tag});
+ if ($$structStack[0][0]{'sub'}{$tkey}{'sub'}) {
+ foreach my $key (keys
%{$$structStack[0][0]{'sub'}{$tkey}{'sub'}}) {
$$attribs{$key} = $attribs{$key} if exists $attribs{$key};
}
}
- if ($$structStack[0][0]{'sub'}{$tag}{'param'}) {
- foreach my $key (keys
%{$$structStack[0][0]{'sub'}{$tag}{'param'}}) {
+ if ($$structStack[0][0]{'sub'}{$tkey}{'param'}) {
+ foreach my $key (keys
%{$$structStack[0][0]{'sub'}{$tkey}{'param'}}) {
$$attribs{$key} = $attribs{$key} if exists $attribs{$key};
}
}
