Permalink
Browse files

revert tidying

  • Loading branch information...
1 parent 8f5678e commit 221ba83a8ad2c50f25b011eb3993f119ccd334a1 @jonswar committed Jul 12, 2012
Showing with 5,445 additions and 6,619 deletions.
  1. +73 −95 bin/convert0.6.pl
  2. +111 −119 bin/convert0.8.pl
  3. +35 −40 bin/mason.pl
  4. +38 −22 lib/HTML/Mason.pm
  5. +0 −4 lib/HTML/Mason/.cvsignore
  6. +12 −0 lib/HTML/Mason/Admin.pod
  7. +6 −2 lib/HTML/Mason/Apache/Request.pm
  8. +377 −404 lib/HTML/Mason/ApacheHandler.pm
  9. +85 −85 lib/HTML/Mason/CGIHandler.pm
  10. +29 −28 lib/HTML/Mason/Cache/BaseCache.pm
  11. +304 −317 lib/HTML/Mason/Compiler.pm
  12. +0 −237 lib/HTML/Mason/Compiler/Events.pm
  13. +0 −223 lib/HTML/Mason/Compiler/ToClass.pm
  14. +289 −300 lib/HTML/Mason/Compiler/ToObject.pm
  15. +115 −142 lib/HTML/Mason/Component.pm
  16. +12 −17 lib/HTML/Mason/Component/FileBased.pm
  17. +18 −16 lib/HTML/Mason/Component/Subcomponent.pm
  18. +26 −27 lib/HTML/Mason/ComponentSource.pm
  19. +16 −2 lib/HTML/Mason/Devel.pod
  20. +9 −5 lib/HTML/Mason/Escapes.pm
  21. +162 −181 lib/HTML/Mason/Exceptions.pm
  22. +95 −112 lib/HTML/Mason/FakeApache.pm
  23. +12 −9 lib/HTML/Mason/Handler.pm
  24. +375 −468 lib/HTML/Mason/Interp.pm
  25. +184 −174 lib/HTML/Mason/Lexer.pm
  26. +66 −49 lib/HTML/Mason/MethodMaker.pm
  27. +12 −4 lib/HTML/Mason/Params.pod
  28. +3 −3 lib/HTML/Mason/Parser.pm
  29. +9 −5 lib/HTML/Mason/Plugin.pm
  30. +11 −15 lib/HTML/Mason/Plugin/Context.pm
  31. +576 −758 lib/HTML/Mason/Request.pm
  32. +10 −7 lib/HTML/Mason/Resolver.pm
  33. +28 −23 lib/HTML/Mason/Resolver/File.pm
  34. +4 −0 lib/HTML/Mason/Resolver/Null.pm
  35. +237 −241 lib/HTML/Mason/Tests.pm
  36. +69 −60 lib/HTML/Mason/Tools.pm
  37. +9 −6 lib/HTML/Mason/Utils.pm
  38. +0 −9 t/.gitignore
  39. +106 −126 t/01-syntax.t
  40. +110 −144 t/01a-comp-calls.t
  41. +111 −127 t/02-sections.t
  42. +126 −143 t/02a-filter.t
  43. +141 −155 t/04-misc.t
  44. +303 −352 t/05-request.t
  45. +17 −19 t/05a-stack-corruption.t
  46. +461 −555 t/06-compiler.t
  47. +3 −5 t/06a-compiler_obj.t
  48. +36 −41 t/06b-compiler-named-subs.t
  49. +370 −417 t/07-interp.t
  50. +82 −130 t/07a-interp-mcr.t
  51. +61 −79 t/07b-interp-static-source.t
  52. +101 −117 t/09-component.t
Sorry, we could not display the entire diff because it was too big.
View
168 bin/convert0.6.pl
@@ -1,12 +1,12 @@
#!/usr/bin/perl -w
use Data::Dumper;
-use File::Find;
+use File::Find;
use Getopt::Std;
use IO::File;
use strict;
-my ( $EXCLUDE, $HELP, $LOWER, $QUIET, $TEST, $UPPER );
+my ($EXCLUDE, $HELP, $LOWER, $QUIET, $TEST, $UPPER);
my $usage = <<EOF;
Usage: $0 -hlqtu [-e <regexp>] <directory> [<directory>...]
@@ -51,131 +51,109 @@
modified destructively and no automatic backups are created.
EOF
-sub usage {
+sub usage
+{
print $usage;
exit;
}
-sub main {
+sub main
+{
my (%opts);
- getopts( 'e:hlqtu', \%opts );
- ( $EXCLUDE, $HELP, $LOWER, $QUIET, $TEST, $UPPER ) = @opts{qw(e h l q t u)};
- if ($HELP) { print "$helpmsg\n$usage"; exit }
- if ( !@ARGV ) { print "$usage\n$helpmsg"; exit }
+ getopts('e:hlqtu',\%opts);
+ ($EXCLUDE, $HELP, $LOWER, $QUIET, $TEST, $UPPER) = @opts{qw(e h l q t u)};
+ if ($HELP) { print "$helpmsg\n$usage"; exit }
+ if (!@ARGV) { print "$usage\n$helpmsg"; exit }
my @dirs = @ARGV;
-
- if ( !$TEST ) {
- print "*** Mason 0.6 Conversion ***\n\n";
- print "Quiet mode.\n" if defined($QUIET);
- print "Excluding paths matching ($EXCLUDE).\n" if defined($EXCLUDE);
- print "Processing "
- . ( @dirs == 1 ? "directory " : "directories " )
- . join( ",", @dirs ) . "\n";
- print $warning;
- print "\nProceed? [n] ";
- exit if ( ( my $ans = <STDIN> ) !~ /[Yy]/ );
+
+ if (!$TEST) {
+ print "*** Mason 0.6 Conversion ***\n\n";
+ print "Quiet mode.\n" if defined($QUIET);
+ print "Excluding paths matching ($EXCLUDE).\n" if defined($EXCLUDE);
+ print "Processing ".(@dirs==1 ? "directory " : "directories ").join(",",@dirs)."\n";
+ print $warning;
+ print "\nProceed? [n] ";
+ exit if ((my $ans = <STDIN>) !~ /[Yy]/);
}
my $sub = sub {
- if ( -f $_ && -s _ ) {
- return if defined($EXCLUDE) && "$File::Find::dir/$_" =~ /$EXCLUDE/i;
- convert( $_, "$File::Find::dir/$_" );
- }
+ if (-f $_ && -s _) {
+ return if defined($EXCLUDE) && "$File::Find::dir/$_" =~ /$EXCLUDE/i;
+ convert($_,"$File::Find::dir/$_");
+ }
};
- find( $sub, @dirs );
+ find($sub,@dirs);
}
-sub convert {
- my ( $file, $path ) = @_;
+sub convert
+{
+ my ($file,$path) = @_;
my $buf;
my $infh = new IO::File $file;
- if ( !$infh ) { warn "cannot read $path: $!"; return }
+ if (!$infh) { warn "cannot read $path: $!"; return }
{ local $/ = undef; $buf = <$infh> }
my $c = 0;
my @changes;
- my $report = sub { push( @changes, "$_[0] --> $_[1]" ) };
+ my $report = sub { push(@changes,"$_[0] --> $_[1]") };
#
# Convert section names to short versions
#
my $pat = "<(/?%)perl_(args|cleanup|doc|init|once|text)>";
- if ( !$TEST ) {
- if ($UPPER) {
- $c += ( $buf =~ s{$pat}{"<$1".uc($2).">"}geio );
- }
- elsif ($LOWER) {
- $c += ( $buf =~ s{$pat}{"<$1".lc($2).">"}geio );
- }
- else {
- $c += ( $buf =~ s{$pat}{<$1$2>}gio );
- }
- }
- else {
- while ( $buf =~ m{($pat)}gio ) {
- $report->(
- $1, "<$2" . ( $UPPER ? uc($3) : $LOWER ? lc($3) : $3 ) . ">"
- );
- }
+ if (!$TEST) {
+ if ($UPPER) {
+ $c += ($buf =~ s{$pat}{"<$1".uc($2).">"}geio);
+ } elsif ($LOWER) {
+ $c += ($buf =~ s{$pat}{"<$1".lc($2).">"}geio);
+ } else {
+ $c += ($buf =~ s{$pat}{<$1$2>}gio);
+ }
+ } else {
+ while ($buf =~ m{($pat)}gio) {
+ $report->($1,"<$2".($UPPER ? uc($3) : $LOWER ? lc($3) : $3).">");
+ }
}
#
# Convert <% mc_comp ... %> to <& ... &>
#
- if ( !$TEST ) {
- $c +=
- ( $buf =~
- s{<%\s*mc_comp\s*\(\s*\'([^\']+)\'\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g
- );
- $c +=
- ( $buf =~
- s{<%\s*mc_comp\s*\(\s*\"([^\"\$]+)\"\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g
- );
- $c +=
- ( $buf =~
- s{<%\s*mc_comp\s*\(\s*(\"[^\"]+\")\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g
- );
- $c += ( $buf =~ s{<%\s*mc_comp\s*\(\s*(.*?)\s*\)\s*%>} {<& $1 &>}g );
- }
- else {
- while (
- $buf =~ m{(<%\s*mc_comp\s*\(\s*\'([^\']+)\'\s*(.*?)\s*\)\s*%>)}g )
- {
- $report->( $1, "<& $2$3 &>" );
- }
- $buf =~
- s{<%\s*mc_comp\s*\(\s*\'([^\']+)\'\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g;
- while (
- $buf =~ m{(<%\s*mc_comp\s*\(\s*\"([^\"\$]+)\"\s*(.*?)\s*\)\s*%>)}g )
- {
- $report->( $1, "<& $2$3 &>" );
- }
- $buf =~
- s{<%\s*mc_comp\s*\(\s*\"([^\"\$]+)\"\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g;
- while (
- $buf =~ m{(<%\s*mc_comp\s*\(\s*(\"[^\"]+\")\s*(.*?)\s*\)\s*%>)}g )
- {
- $report->( $1, "<& $2$3 &>" );
- }
- $buf =~
- s{<%\s*mc_comp\s*\(\s*(\"[^\"]+\")\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g;
- while ( $buf =~ m{(<%\s*mc_comp\s*\((.*?)\s*\)\s*%>)}g ) {
- $report->( $1, "<& $2 &>" );
- }
+ if (!$TEST) {
+ $c += ($buf =~ s{<%\s*mc_comp\s*\(\s*\'([^\']+)\'\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g);
+ $c += ($buf =~ s{<%\s*mc_comp\s*\(\s*\"([^\"\$]+)\"\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g);
+ $c += ($buf =~ s{<%\s*mc_comp\s*\(\s*(\"[^\"]+\")\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g);
+ $c += ($buf =~ s{<%\s*mc_comp\s*\(\s*(.*?)\s*\)\s*%>} {<& $1 &>}g);
+ } else {
+ while ($buf =~ m{(<%\s*mc_comp\s*\(\s*\'([^\']+)\'\s*(.*?)\s*\)\s*%>)}g) {
+ $report->($1,"<& $2$3 &>");
+ }
+ $buf =~ s{<%\s*mc_comp\s*\(\s*\'([^\']+)\'\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g;
+ while ($buf =~ m{(<%\s*mc_comp\s*\(\s*\"([^\"\$]+)\"\s*(.*?)\s*\)\s*%>)}g) {
+ $report->($1,"<& $2$3 &>");
+ }
+ $buf =~ s{<%\s*mc_comp\s*\(\s*\"([^\"\$]+)\"\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g;
+ while ($buf =~ m{(<%\s*mc_comp\s*\(\s*(\"[^\"]+\")\s*(.*?)\s*\)\s*%>)}g) {
+ $report->($1,"<& $2$3 &>");
+ }
+ $buf =~ s{<%\s*mc_comp\s*\(\s*(\"[^\"]+\")\s*(.*?)\s*\)\s*%>} {<& $1$2 &>}g;
+ while ($buf =~ m{(<%\s*mc_comp\s*\((.*?)\s*\)\s*%>)}g) {
+ $report->($1,"<& $2 &>");
+ }
}
if ($TEST) {
- if (@changes) {
- print scalar(@changes) . " substitutions in $path:\n";
- print join( "\n", @changes ) . "\n\n";
- }
+ if (@changes) {
+ print scalar(@changes)." substitutions in $path:\n";
+ print join("\n",@changes)."\n\n";
+ }
}
-
- if ( $c && !$TEST ) {
- print "$c substitutions in $path\n" if !$QUIET;
- my $outfh = new IO::File ">$file";
- if ( !$outfh ) { warn "cannot write $path: $!"; return }
- $outfh->print($buf);
+
+ if ($c && !$TEST) {
+ print "$c substitutions in $path\n" if !$QUIET;
+ my $outfh = new IO::File ">$file";
+ if (!$outfh) { warn "cannot write $path: $!"; return }
+ $outfh->print($buf);
}
}
+
main();
View
230 bin/convert0.8.pl
@@ -1,12 +1,12 @@
#!/usr/bin/perl -w
use Data::Dumper;
-use File::Find;
+use File::Find;
use Getopt::Std;
use IO::File;
use strict;
-my ( $EXCLUDE, $HELP, $QUIET, $TEST );
+my ($EXCLUDE, $HELP, $QUIET, $TEST);
my $usage = <<EOF;
Usage: $0 -hqt [-e <regexp>] <directory> [<directory>...]
@@ -37,170 +37,162 @@
modified destructively and no automatic backups are created.
EOF
-sub usage {
+sub usage
+{
print $usage;
exit;
}
-sub main {
+sub main
+{
my (%opts);
- getopts( 'e:hlqtu', \%opts );
- ( $EXCLUDE, $HELP, $QUIET, $TEST ) = @opts{qw(e h q t)};
- if ($HELP) { print "$helpmsg\n$usage"; exit }
- if ( !@ARGV ) { print "$usage\n$helpmsg"; exit }
+ getopts('e:hlqtu',\%opts);
+ ($EXCLUDE, $HELP, $QUIET, $TEST) = @opts{qw(e h q t)};
+ if ($HELP) { print "$helpmsg\n$usage"; exit }
+ if (!@ARGV) { print "$usage\n$helpmsg"; exit }
my @dirs = @ARGV;
-
- if ( !$TEST ) {
- print "*** Mason 0.8 Conversion ***\n\n";
- print "Quiet mode.\n" if defined($QUIET);
- print "Excluding paths matching ($EXCLUDE).\n" if defined($EXCLUDE);
- print "Processing "
- . ( @dirs == 1 ? "directory " : "directories " )
- . join( ",", @dirs ) . "\n";
- print $warning;
- print "\nProceed? [n] ";
- exit if ( ( my $ans = <STDIN> ) !~ /[Yy]/ );
+
+ if (!$TEST) {
+ print "*** Mason 0.8 Conversion ***\n\n";
+ print "Quiet mode.\n" if defined($QUIET);
+ print "Excluding paths matching ($EXCLUDE).\n" if defined($EXCLUDE);
+ print "Processing ".(@dirs==1 ? "directory " : "directories ").join(",",@dirs)."\n";
+ print $warning;
+ print "\nProceed? [n] ";
+ exit if ((my $ans = <STDIN>) !~ /[Yy]/);
}
my $sub = sub {
- if ( -f $_ && -s _ ) {
- return if defined($EXCLUDE) && "$File::Find::dir/$_" =~ /$EXCLUDE/i;
- convert( $_, "$File::Find::dir/$_" );
- }
+ if (-f $_ && -s _) {
+ return if defined($EXCLUDE) && "$File::Find::dir/$_" =~ /$EXCLUDE/i;
+ convert($_,"$File::Find::dir/$_");
+ }
};
- find( $sub, @dirs );
+ find($sub,@dirs);
}
-sub convert {
- my ( $file, $path ) = @_;
+sub convert
+{
+ my ($file,$path) = @_;
my $buf;
my $infh = new IO::File $file;
- if ( !$infh ) { warn "cannot read $path: $!"; return }
+ if (!$infh) { warn "cannot read $path: $!"; return }
{ local $/ = undef; $buf = <$infh> }
my $c = 0;
- my ( @changes, @failures );
- my $report =
- sub { push( @changes, $_[1] ? "$_[0] --> $_[1]" : "removed $_[0]" ) };
- my $report_failure = sub { push( @failures, $_[0] ) };
+ my (@changes,@failures);
+ my $report = sub { push(@changes,$_[1] ? "$_[0] --> $_[1]" : "removed $_[0]") };
+ my $report_failure = sub { push(@failures,$_[0]) };
#
# Convert mc_ commands to $m-> method equivalents
#
# Easy substitutions
#
- my $easy_cmds = join( "|",
- qw(abort cache cache_self call_self comp comp_exists dhandler_arg file file_root out time)
- );
- if ( !$TEST ) {
- $c += ( $buf =~ s{mc_($easy_cmds)(?![A-Za-z0-9 _])}{"\$m->$1"}geo );
- }
- else {
- while ( $buf =~ m{(mc_($easy_cmds)(?![A-Za-z0-9 _]))}go ) {
- $report->( $1, "\$m->$2" );
- }
+ my $easy_cmds = join("|",qw(abort cache cache_self call_self comp comp_exists dhandler_arg file file_root out time));
+ if (!$TEST) {
+ $c += ($buf =~ s{mc_($easy_cmds)(?![A-Za-z0-9 _])}{"\$m->$1"}geo);
+ } else {
+ while ($buf =~ m{(mc_($easy_cmds)(?![A-Za-z0-9 _]))}go) {
+ $report->($1,"\$m->$2");
+ }
}
# Boilerplate substitutions for methods with no arguments
- my @subs = (
- [ 'mc_auto_comp', '$m->fetch_next->path' ],
- [ 'mc_caller', '$m->callers(1)->path' ],
- [ 'mc_comp_source', '$m->current_comp->source_file' ],
- [ 'mc_comp_stack', 'map($_->title,$m->callers)' ],
- );
+ my @subs =
+ (['mc_auto_comp', '$m->fetch_next->path'],
+ ['mc_caller', '$m->callers(1)->path'],
+ ['mc_comp_source', '$m->current_comp->source_file'],
+ ['mc_comp_stack', 'map($_->title,$m->callers)'],
+ );
foreach my $sub (@subs) {
- my ( $mc_cmd, $repl ) = @$sub;
- if ( !$TEST ) {
- $c += ( $buf =~ s{$mc_cmd(\s*\(\))?(?!\s*[\(])}{$repl}ge );
- }
- else {
- while ( $buf =~ m{($mc_cmd(\s*\(\))?(?!\s*[\(]))}g ) {
- $report->( $1, $repl );
- }
- }
+ my ($mc_cmd,$repl) = @$sub;
+ if (!$TEST) {
+ $c += ($buf =~ s{$mc_cmd(\s*\(\))?(?!\s*[\(])}{$repl}ge);
+ } else {
+ while ($buf =~ m{($mc_cmd(\s*\(\))?(?!\s*[\(]))}g) {
+ $report->($1,$repl);
+ }
+ }
}
# Boilerplate substitutions for methods with arguments
- @subs = ( [ 'mc_auto_next', '$m->call_next' ], );
+ @subs =
+ (['mc_auto_next', '$m->call_next'],
+ );
foreach my $sub (@subs) {
- my ( $mc_cmd, $repl ) = @$sub;
- if ( !$TEST ) {
- $c += ( $buf =~ s{$mc_cmd}{$repl}ge );
- }
- else {
- while ( $buf =~ m{($mc_cmd)}g ) {
- $report->( $1, $repl );
- }
- }
+ my ($mc_cmd,$repl) = @$sub;
+ if (!$TEST) {
+ $c += ($buf =~ s{$mc_cmd}{$repl}ge);
+ } else {
+ while ($buf =~ m{($mc_cmd)}g) {
+ $report->($1,$repl);
+ }
+ }
}
# mc_comp_source with simple argument
- if ( !$TEST ) {
- $c +=
- ( $buf =~
- s{mc_comp_source\s*\(([^\(\)]+)\)}{"\$m->fetch_comp($1)->source_file"}ge
- );
- }
- else {
- while ( $buf =~ m{(mc_comp_source\s*\(([^\(\)]+)\))}g ) {
- $report->( $1, "\$m->fetch_comp($2)->source_file" );
- }
+ if (!$TEST) {
+ $c += ($buf =~ s{mc_comp_source\s*\(([^\(\)]+)\)}{"\$m->fetch_comp($1)->source_file"}ge);
+ } else {
+ while ($buf =~ m{(mc_comp_source\s*\(([^\(\)]+)\))}g) {
+ $report->($1,"\$m->fetch_comp($2)->source_file");
+ }
}
# mc_suppress_http_header with and without arguments
- if ( !$TEST ) {
- $c += ( $buf =~ s{mc_suppress_http_header\s*(?!\s*\();?}{}g );
- $c += ( $buf =~ s{mc_suppress_http_header\s*\([^\(\)]*\)\s*;?}{}g );
- }
- else {
- while ( $buf =~ m{(mc_suppress_http_header\s*(?!\s*\();?)}g ) {
- $report->( $1, "" );
- }
- while ( $buf =~ m{(mc_suppress_http_header\s*\([^\(\)]*\)\s*;?)}g ) {
- $report->( $1, "" );
- }
- }
-
+ if (!$TEST) {
+ $c += ($buf =~ s{mc_suppress_http_header\s*(?!\s*\();?}{}g);
+ $c += ($buf =~ s{mc_suppress_http_header\s*\([^\(\)]*\)\s*;?}{}g);
+ } else {
+ while ($buf =~ m{(mc_suppress_http_header\s*(?!\s*\();?)}g) {
+ $report->($1,"");
+ }
+ while ($buf =~ m{(mc_suppress_http_header\s*\([^\(\)]*\)\s*;?)}g) {
+ $report->($1,"");
+ }
+ }
+
#
# Convert $REQ to $m
#
- if ( !$TEST ) {
- $c += ( $buf =~ s{\$REQ(?![A-Za-z0-9_])}{\$m}go );
- }
- else {
- while ( $buf =~ m{(\$REQ(?![A-Za-z0-9_]))}go ) {
- $report->( $1, "\$m" );
- }
- }
-
+ if (!$TEST) {
+ $c += ($buf =~ s{\$REQ(?![A-Za-z0-9_])}{\$m}go);
+ } else {
+ while ($buf =~ m{(\$REQ(?![A-Za-z0-9_]))}go) {
+ $report->($1,"\$m");
+ }
+ }
+
# Report substitutions we can't handle
foreach my $cmd (qw(mc_comp_source mc_suppress_http_header)) {
- if ( $buf =~ m{$cmd\s*\([^\)]*\(} ) {
- $report_failure->("Can't convert $cmd with complex arguments");
- }
+ if ($buf =~ m{$cmd\s*\([^\)]*\(}) {
+ $report_failure->("Can't convert $cmd with complex arguments");
+ }
}
- if ( $buf =~ m{mc_date} ) {
- $report_failure->("Can't convert mc_date");
+ if ($buf =~ m{mc_date}) {
+ $report_failure->("Can't convert mc_date");
}
-
+
if ($TEST) {
- if (@changes) {
- print scalar(@changes) . " substitutions in $path:\n";
- print join( "\n", @changes ) . "\n";
- }
- }
-
- if ( $c && !$TEST ) {
- print "$c substitutions in $path\n" if !$QUIET;
- my $outfh = new IO::File ">$file";
- if ( !$outfh ) { warn "cannot write $path: $!"; return }
- $outfh->print($buf);
- }
-
+ if (@changes) {
+ print scalar(@changes)." substitutions in $path:\n";
+ print join("\n",@changes)."\n";
+ }
+ }
+
+ if ($c && !$TEST) {
+ print "$c substitutions in $path\n" if !$QUIET;
+ my $outfh = new IO::File ">$file";
+ if (!$outfh) { warn "cannot write $path: $!"; return }
+ $outfh->print($buf);
+ }
+
foreach my $failure (@failures) {
- print "** Warning: $failure; must fix manually\n";
+ print "** Warning: $failure; must fix manually\n";
}
- print "\n" if ( ( $TEST && @changes ) || @failures );
+ print "\n" if (($TEST && @changes) || @failures);
}
+
main();
View
75 bin/mason.pl
@@ -4,61 +4,56 @@
use HTML::Mason '1.11';
use File::Basename qw(dirname basename);
use File::Spec ();
-use Cwd ();
+use Cwd ();
-my ( $params, $component, $args ) = parse_command_line(@ARGV);
+my ($params, $component, $args) = parse_command_line(@ARGV);
# Set a default comp_root
-unless ( exists $params->{comp_root} ) {
- if ( File::Spec->file_name_is_absolute($component) ) {
- $params->{comp_root} = dirname($component);
- $component = '/' . basename($component);
- }
- else {
- $params->{comp_root} = Cwd::cwd;
-
- # Convert local path syntax to slashes
- my ( $dirs, $file ) = ( File::Spec->splitpath($component) )[ 1, 2 ];
- $component = '/' . join '/', File::Spec->splitdir($dirs), $file;
- }
+unless (exists $params->{comp_root}) {
+ if (File::Spec->file_name_is_absolute($component)) {
+ $params->{comp_root} = dirname($component);
+ $component = '/' . basename($component);
+ } else {
+ $params->{comp_root} = Cwd::cwd;
+ # Convert local path syntax to slashes
+ my ($dirs, $file) = (File::Spec->splitpath($component))[1,2];
+ $component = '/' . join '/', File::Spec->splitdir($dirs), $file;
+ }
}
my $interp = HTML::Mason::Interp->new(%$params);
-$interp->exec( $component, @$args );
+$interp->exec($component, @$args);
#######################################################################################
sub parse_command_line {
- die usage() unless @_;
-
- my %params;
- while (@_) {
- if ( $_[0] eq '--config_file' ) {
- shift;
- my $file = shift;
- eval { require YAML; 1 }
- or die
- "--config_file requires the YAML Perl module to be installed.\n";
- my $href = YAML::LoadFile($file);
- @params{ keys %$href } = values %$href;
-
- }
- elsif ( $_[0] =~ /^--/ ) {
- my ( $k, $v ) = ( shift, shift );
- $k =~ s/^--//;
- $params{$k} = $v;
+ die usage() unless @_;
- }
- else {
- my $comp = shift;
- return ( \%params, $comp, \@_ );
- }
+ my %params;
+ while (@_) {
+ if ( $_[0] eq '--config_file' ) {
+ shift;
+ my $file = shift;
+ eval {require YAML; 1}
+ or die "--config_file requires the YAML Perl module to be installed.\n";
+ my $href = YAML::LoadFile($file);
+ @params{keys %$href} = values %$href;
+
+ } elsif ( $_[0] =~ /^--/ ) {
+ my ($k, $v) = (shift, shift);
+ $k =~ s/^--//;
+ $params{$k} = $v;
+
+ } else {
+ my $comp = shift;
+ return (\%params, $comp, \@_);
}
+ }
- die usage();
+ die usage();
}
sub usage {
- return <<EOF;
+ return <<EOF;
Usage: $0 [--param1 value1 ...] [--config_file file] component [arg1 arg2 ...]
e.g.: $0 --comp_root /mason/comps component.mas
View
60 lib/HTML/Mason.pm
@@ -1,14 +1,16 @@
package HTML::Mason;
-
# Copyright (c) 1998-2005 by Jonathan Swartz. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
use 5.006;
+$HTML::Mason::VERSION = '1.49';
+
use HTML::Mason::Interp;
-sub version {
+sub version
+{
return $HTML::Mason::VERSION;
}
@@ -29,20 +31,6 @@ Mason - High-performance, dynamic web site authoring system
PerlHandler HTML::Mason::ApacheHandler
</Location>
-=head1 STOP - HAVE YOU CHECKED OUT MASON 2?
-
-Version 1 of Mason (which you are looking at now) has been around since
-1998, is in wide use, and is very stable. However it has not changed much in
-years and is no longer actively developed.
-
-Version 2 of Mason -- L<Mason|Mason> -- was released in February of 2011.
-It is being very actively developed and has a much more modern architecture.
-If you are just starting out, we recommend you go directly to Mason 2.
-
-For a summary of differences between Mason 1 and 2 see
-
- http://www.openswartz.com/2011/02/21/announcing-mason-2/
-
=head1 DESCRIPTION
Mason is a tool for building, serving and managing large web
@@ -99,6 +87,21 @@ of Perl code (say, to pull records from a database). They can also
call other components, cache results for later reuse, and perform all
the tricks you expect from a regular Perl program.
+=head1 MASON 1 (HTML::MASON) VERSUS MASON 2 (MASON)
+
+Version 1 of Mason -- L<HTML::Mason|HTML::Mason> -- has been around since
+1998, is in wide use, and is very stable. However it has not changed much in
+years and is no longer actively developed.
+
+Version 2 of Mason -- L<Mason|Mason> -- was released in February of 2011.
+It is being very actively developed and has a much more modern
+architecture. If you are just starting out, we recommend you give Mason 2 a
+try.
+
+For a summary of differences between Mason 1 and 2 see
+
+ http://www.openswartz.com/2011/02/21/announcing-mason-2/
+
=head1 INSTALLATION
Mason has been tested under Linux, FreeBSD, Solaris, HPUX, and
@@ -109,8 +112,6 @@ modules.
Mason has a standard MakeMaker-driven installation. See the README
file for details.
-=for readme stop
-
=head1 CONFIGURING MASON
This section assumes that you are able to install and configure a
@@ -135,7 +136,7 @@ running mod_perl.
The <Location> section routes all requests to the Mason handler, which
is a simple way to try out Mason. A more refined setup is discussed
-in L<Controlling Access via Filename Extension|HTML::Mason::Admin/Controlling Access via Filename Extension>.
+in the L<Controlling Access via Filename Extension|HTML::Mason::Admin/Controlling Access via Filename Extension> section of the administrator's manual.
Once you have added the configuration directives, restart the
server. First, go to a standard URL on your site to make sure you
@@ -173,15 +174,30 @@ mod_perl, since that is the most common configuration. If you would
like to run Mason via a CGI script, refer to the
L<HTML::Mason::CGIHandler|HTML::Mason::CGIHandler> documentation.
If you are using Mason from a standalone program, refer to
-L<Using Mason from a Standalone Script|HTML::Mason::Admin/Using Mason from a Standalone Script>.
+the L<Using Mason from a Standalone Script|HTML::Mason::Admin/Using Mason from a Standalone Script> section of the administrator's manual.
There is also a book about Mason, I<Embedding Perl in HTML with
Mason>, by Dave Rolsky and Ken Williams, published by O'Reilly and
Associates. The book's website is at http://www.masonbook.com/. This
book goes into detail on a number of topics, and includes a chapter of
recipes as well as a sample Mason-based website.
-Finally, don't forget to check out L<Mason 2|Mason> to see it will serve
-your needs!
+=head1 AUTHORS
+
+Jonathan Swartz <swartz@pobox.com>, Dave Rolsky <autarch@urth.org>, Ken Williams <ken@mathforum.org>, John Williams <williams@tni.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998-2005 Jonathan Swartz. All rights reserved. This
+program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+The full text of the license can be found in the LICENSE file included
+with this module.
+
+=head1 SEE ALSO
+
+L<HTML::Mason::Devel|HTML::Mason::Devel>,
+L<HTML::Mason::Admin|HTML::Mason::Admin>
=cut
View
4 lib/HTML/Mason/.cvsignore
@@ -1,4 +0,0 @@
-pod2html-*
-test.pl
-test.csh
-Params.pod
View
12 lib/HTML/Mason/Admin.pod
@@ -1124,4 +1124,16 @@ sending to standard output:
# Do something with $outbuf
+=head1 AUTHORS
+
+Jonathan Swartz <swartz@pobox.com>, Dave Rolsky <autarch@urth.org>, Ken Williams <ken@mathforum.org>
+
+=head1 SEE ALSO
+
+L<HTML::Mason|HTML::Mason>,
+L<HTML::Mason::Interp|HTML::Mason::Interp>,
+L<HTML::Mason::ApacheHandler|HTML::Mason::ApacheHandler>,
+L<HTML::Mason::Lexer|HTML::Mason::Lexer>,
+L<HTML::Mason::Compiler|HTML::Mason::Compiler>
+
=cut
View
8 lib/HTML/Mason/Apache/Request.pm
@@ -11,14 +11,17 @@ use warnings;
use base 'Apache::Request';
-sub new {
+
+sub new
+{
my $class = shift;
my $r = Apache::Request->instance(shift);
return bless { r => $r }, $class;
}
-sub send_http_header {
+sub send_http_header
+{
my $self = shift;
return if $self->notes('sent_http_header');
@@ -28,4 +31,5 @@ sub send_http_header {
$self->notes( 'sent_http_header' => 1 );
}
+
1;
View
781 lib/HTML/Mason/ApacheHandler.pm
@@ -10,27 +10,32 @@ use warnings;
package HTML::Mason::ApacheHandler;
use vars qw($VERSION);
-
# do not change the version number
$VERSION = 1.69;
+
# PerlAddVar was introduced in mod_perl-1.24
# Support for modperl2 < 1.999022 was removed due to API changes
-BEGIN {
- if ( $ENV{MOD_PERL} && $ENV{MOD_PERL} =~ /1\.99|2\.0/ ) {
+BEGIN
+{
+ if ( $ENV{MOD_PERL} && $ENV{MOD_PERL} =~ /1\.99|2\.0/ )
+ {
require mod_perl2;
}
- elsif ( $ENV{MOD_PERL} ) {
+ elsif ( $ENV{MOD_PERL} )
+ {
require mod_perl;
}
- my $mpver = ( mod_perl2->VERSION || mod_perl->VERSION || 0 );
+ my $mpver = (mod_perl2->VERSION || mod_perl->VERSION || 0);
# This is the version that introduced PerlAddVar
- if ( $mpver && $mpver < 1.24 ) {
+ if ($mpver && $mpver < 1.24)
+ {
die "mod_perl VERSION >= 1.24 required";
}
- elsif ( $mpver >= 1.99 && $mpver < 1.999022 ) {
+ elsif ($mpver >= 1.99 && $mpver < 1.999022)
+ {
die "mod_perl-1.99 is not supported; upgrade to 2.00";
}
}
@@ -44,71 +49,56 @@ package HTML::Mason::Request::ApacheHandler;
use HTML::Mason::Request;
use Class::Container;
use Params::Validate qw(BOOLEAN);
-Params::Validate::validation_options(
- on_fail => sub { param_error( join '', @_ ) } );
+Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } );
use base qw(HTML::Mason::Request);
use HTML::Mason::Exceptions( abbr => [qw(param_error error)] );
-use constant APACHE2 => ( $mod_perl2::VERSION || $mod_perl::VERSION || 0 ) >=
- 1.999022;
-use constant OK => 0;
-use constant HTTP_OK => 200;
-use constant DECLINED => -1;
-use constant NOT_FOUND => 404;
-use constant REDIRECT => 302;
+use constant APACHE2 => ($mod_perl2::VERSION || $mod_perl::VERSION || 0) >= 1.999022;
+use constant OK => 0;
+use constant HTTP_OK => 200;
+use constant DECLINED => -1;
+use constant NOT_FOUND => 404;
+use constant REDIRECT => 302;
-BEGIN {
+BEGIN
+{
my $ap_req_class = APACHE2 ? 'Apache2::RequestRec' : 'Apache';
- __PACKAGE__->valid_params(
- ah => {
- isa => 'HTML::Mason::ApacheHandler',
- descr => 'An ApacheHandler to handle web requests',
- public => 0
- },
-
- apache_req => {
- isa => $ap_req_class,
- default => undef,
- descr => "An Apache request object",
- public => 0
- },
-
- cgi_object => {
- isa => 'CGI',
- default => undef,
- descr => "A CGI.pm request object",
- public => 0
- },
-
- auto_send_headers => {
- parse => 'boolean',
- type => BOOLEAN,
- default => 1,
- descr => "Whether HTTP headers should be auto-generated"
- },
- );
+ __PACKAGE__->valid_params
+ ( ah => { isa => 'HTML::Mason::ApacheHandler',
+ descr => 'An ApacheHandler to handle web requests',
+ public => 0 },
+
+ apache_req => { isa => $ap_req_class, default => undef,
+ descr => "An Apache request object",
+ public => 0 },
+
+ cgi_object => { isa => 'CGI', default => undef,
+ descr => "A CGI.pm request object",
+ public => 0 },
+
+ auto_send_headers => { parse => 'boolean', type => BOOLEAN, default => 1,
+ descr => "Whether HTTP headers should be auto-generated" },
+ );
}
-use HTML::Mason::MethodMaker (
- read_write => [
- map { [ $_ => __PACKAGE__->validation_spec->{$_} ] }
- qw( ah apache_req auto_send_headers )
- ]
-);
+use HTML::Mason::MethodMaker
+ ( read_write => [ map { [ $_ => __PACKAGE__->validation_spec->{$_} ] }
+ qw( ah apache_req auto_send_headers ) ] );
# A hack for subrequests
sub _properties { qw(ah apache_req), shift->SUPER::_properties }
-sub new {
+sub new
+{
my $class = shift;
- my $self = $class->SUPER::new(@_); # Magic!
+ my $self = $class->SUPER::new(@_); # Magic!
- unless ( $self->apache_req or $self->cgi_object ) {
- param_error __PACKAGE__
- . "->new: must specify 'apache_req' or 'cgi_object' parameter";
+ unless ($self->apache_req or $self->cgi_object)
+ {
+ param_error __PACKAGE__ . "->new: must specify 'apache_req' or 'cgi_object' parameter";
}
# Record a flag indicating whether the user passed a custom out_method
@@ -118,16 +108,16 @@ sub new {
return $self;
}
-sub cgi_object {
+sub cgi_object
+{
my ($self) = @_;
error "Can't call cgi_object() unless 'args_method' is set to CGI.\n"
- unless $self->ah->args_method eq 'CGI';
+ unless $self->ah->args_method eq 'CGI';
- if ( defined( $_[1] ) ) {
+ if (defined($_[1])) {
$self->{cgi_object} = $_[1];
- }
- else {
+ } else {
# We may not have created a CGI object if, say, request was a
# GET with no query string. Create one on the fly if necessary.
$self->{cgi_object} ||= CGI->new('');
@@ -142,19 +132,21 @@ sub cgi_object {
# Apache into not reading POST content again. Wish there were
# a more standardized way to do this...
#
-sub exec {
+sub exec
+{
my $self = shift;
- my $r = $self->apache_req;
+ my $r = $self->apache_req;
my $retval;
- if ( $self->is_subrequest ) {
-
+ if ( $self->is_subrequest )
+ {
# no need to go through all the rigamorale below for
# subrequests, and it may even break things to do so, since
# $r's print should only be redefined once.
$retval = $self->SUPER::exec(@_);
}
- else {
+ else
+ {
# ack, this has to be done at runtime to account for the fact
# that Apache::Filter changes $r's class and implements its
# own print() method.
@@ -181,11 +173,10 @@ sub exec {
# headers, this will typically only apply after $m->abort.
# On an error code, leave it to Apache to send the headers.
if ( !$self->is_subrequest
- and !APACHE2
- and $self->auto_send_headers
- and !$r->notes('mason-sent-headers')
- and ( !$retval or $retval eq HTTP_OK ) )
- {
+ and !APACHE2
+ and $self->auto_send_headers
+ and !$r->notes('mason-sent-headers')
+ and ( !$retval or $retval eq HTTP_OK ) ) {
$r->send_http_header();
}
@@ -198,13 +189,13 @@ sub exec {
# Override this method to always die when top level component is not found,
# so we can return NOT_FOUND.
#
-sub _handle_error {
- my ( $self, $err ) = @_;
+sub _handle_error
+{
+ my ($self, $err) = @_;
- if ( isa_mason_exception( $err, 'TopLevelNotFound' ) ) {
+ if (isa_mason_exception($err, 'TopLevelNotFound')) {
rethrow_exception $err;
- }
- else {
+ } else {
if ( $self->error_format eq 'html' ) {
$self->apache_req->content_type('text/html');
@@ -216,14 +207,15 @@ sub _handle_error {
}
}
-sub redirect {
- my ( $self, $url, $status ) = @_;
+sub redirect
+{
+ my ($self, $url, $status) = @_;
my $r = $self->apache_req;
$r->method('GET');
$r->headers_in->unset('Content-length');
$r->err_headers_out->{Location} = $url;
- $self->clear_and_abort( $status || REDIRECT );
+ $self->clear_and_abort($status || REDIRECT);
}
#----------------------------------------------------------------------
@@ -239,28 +231,25 @@ use HTML::Mason::Interp;
use HTML::Mason::Tools qw( load_pkg );
use HTML::Mason::Utils;
use Params::Validate qw(:all);
-Params::Validate::validation_options(
- on_fail => sub { param_error( join '', @_ ) } );
+Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } );
-use constant APACHE2 => ( $mod_perl2::VERSION || $mod_perl::VERSION || 0 ) >=
- 1.999022;
-use constant OK => 0;
-use constant HTTP_OK => 200;
-use constant DECLINED => -1;
-use constant NOT_FOUND => 404;
-use constant REDIRECT => 302;
+use constant APACHE2 => ($mod_perl2::VERSION || $mod_perl::VERSION || 0) >= 1.999022;
+use constant OK => 0;
+use constant HTTP_OK => 200;
+use constant DECLINED => -1;
+use constant NOT_FOUND => 404;
+use constant REDIRECT => 302;
BEGIN {
- if ( $ENV{MOD_PERL} ) {
+ if ($ENV{MOD_PERL}) {
if (APACHE2) {
require Apache2::RequestRec;
require Apache2::RequestIO;
require Apache2::ServerUtil;
require Apache2::RequestUtil;
require Apache2::Log;
require APR::Table;
- }
- else {
+ } else {
require Apache;
require Apache::Request;
require HTML::Mason::Apache::Request;
@@ -269,105 +258,91 @@ BEGIN {
}
}
-if ( $ENV{MOD_PERL} && !APACHE2 ) {
-
+if ( $ENV{MOD_PERL} && ! APACHE2 )
+{
# No modern distro/OS packages a mod_perl without all of this
# stuff turned on, does it?
- error
- "mod_perl must be compiled with PERL_METHOD_HANDLERS=1 (or EVERYTHING=1) to use ",
- __PACKAGE__, "\n"
- unless Apache::perl_hook('MethodHandlers');
+ error "mod_perl must be compiled with PERL_METHOD_HANDLERS=1 (or EVERYTHING=1) to use ", __PACKAGE__, "\n"
+ unless Apache::perl_hook('MethodHandlers');
- error
- "mod_perl must be compiled with PERL_TABLE_API=1 (or EVERYTHING=1) to use ",
- __PACKAGE__, "\n"
- unless Apache::perl_hook('TableApi');
+ error "mod_perl must be compiled with PERL_TABLE_API=1 (or EVERYTHING=1) to use ", __PACKAGE__, "\n"
+ unless Apache::perl_hook('TableApi');
}
use base qw(HTML::Mason::Handler);
-BEGIN {
- __PACKAGE__->valid_params(
- apache_status_title => {
- parse => 'string',
- type => SCALAR,
- default => 'HTML::Mason status',
- descr => "The title of the Apache::Status page"
- },
-
- args_method => {
- parse => 'string',
- type => SCALAR,
- default => APACHE2 ? 'CGI' : 'mod_perl',
- regex => qr/^(?:CGI|mod_perl)$/,
- descr =>
- "Whether to use CGI.pm or Apache::Request for parsing the incoming HTTP request",
- },
-
- decline_dirs => {
- parse => 'boolean',
- type => BOOLEAN,
- default => 1,
- descr =>
- "Whether Mason should decline to handle requests for directories"
- },
-
- # the only required param
- interp => {
- isa => 'HTML::Mason::Interp',
- descr => "A Mason interpreter for processing components"
- },
- );
+BEGIN
+{
+ __PACKAGE__->valid_params
+ (
+ apache_status_title =>
+ { parse => 'string', type => SCALAR, default => 'HTML::Mason status',
+ descr => "The title of the Apache::Status page" },
+
+ args_method =>
+ { parse => 'string', type => SCALAR,
+ default => APACHE2 ? 'CGI' : 'mod_perl',
+ regex => qr/^(?:CGI|mod_perl)$/,
+ descr => "Whether to use CGI.pm or Apache::Request for parsing the incoming HTTP request",
+ },
+
+ decline_dirs =>
+ { parse => 'boolean', type => BOOLEAN, default => 1,
+ descr => "Whether Mason should decline to handle requests for directories" },
+
+ # the only required param
+ interp =>
+ { isa => 'HTML::Mason::Interp',
+ descr => "A Mason interpreter for processing components" },
+ );
- __PACKAGE__->contained_objects(
- interp => {
- class => 'HTML::Mason::Interp',
- descr =>
- 'The interp class coordinates multiple objects to handle request execution'
- },
- );
+ __PACKAGE__->contained_objects
+ (
+ interp =>
+ { class => 'HTML::Mason::Interp',
+ descr => 'The interp class coordinates multiple objects to handle request execution'
+ },
+ );
}
-use HTML::Mason::MethodMaker (
- read_only => ['args_method'],
- read_write => [
- map { [ $_ => __PACKAGE__->validation_spec->{$_} ] }
- qw( apache_status_title
- decline_dirs
- interp )
- ]
-);
-
-sub _get_apache_server {
- return APACHE2 ? Apache2::ServerUtil->server() : Apache->server();
+use HTML::Mason::MethodMaker
+ ( read_only => [ 'args_method' ],
+ read_write => [ map { [ $_ => __PACKAGE__->validation_spec->{$_} ] }
+ qw( apache_status_title
+ decline_dirs
+ interp ) ]
+ );
+
+sub _get_apache_server
+{
+ return APACHE2 ? Apache2::ServerUtil->server() : Apache->server();
}
my ($STARTED);
# The "if _get_apache_server" bit is a hack to let this module load
# when not under mod_perl, which is needed to generate Params.pod
__PACKAGE__->_startup() if eval { _get_apache_server };
-
-sub _startup {
+sub _startup
+{
my $pack = shift;
- return
- if $STARTED++
- ; # Allows a subclass to call this method without running it twice
+ return if $STARTED++; # Allows a subclass to call this method without running it twice
- if ( my $args_method = $pack->_get_string_param('MasonArgsMethod') ) {
- if ( $args_method eq 'CGI' ) {
+ if ( my $args_method = $pack->_get_string_param('MasonArgsMethod') )
+ {
+ if ($args_method eq 'CGI')
+ {
eval { require CGI unless defined CGI->VERSION; };
-
# mod_perl2 does not warn about this, so somebody should
- if ( APACHE2 && CGI->VERSION < 3.08 ) {
+ if (APACHE2 && CGI->VERSION < 3.08) {
die "CGI version 3.08 is required to support mod_perl2 API";
}
die $@ if $@;
}
- elsif ( $args_method eq 'mod_perl' && APACHE2 ) {
- eval "require Apache2::Request"
- unless defined Apache2::Request->VERSION;
+ elsif ( $args_method eq 'mod_perl' && APACHE2 )
+ {
+ eval "require Apache2::Request" unless defined Apache2::Request->VERSION;
}
}
}
@@ -376,18 +351,18 @@ sub _startup {
# with a more informative status once an interpreter has been created.
my $status_name = 'mason0001';
my $apstat_module = APACHE2 ? 'Apache2::Status' : 'Apache::Status';
-if ( load_pkg($apstat_module) ) {
- $apstat_module->menu_item(
- $status_name =>
- __PACKAGE__->allowed_params->{apache_status_title}{default},
- sub { ["<b>(no interpreters created in this child yet)</b>"] }
- );
+if ( load_pkg($apstat_module) )
+{
+ $apstat_module->menu_item
+ ($status_name => __PACKAGE__->allowed_params->{apache_status_title}{default},
+ sub { ["<b>(no interpreters created in this child yet)</b>"] });
}
-my %AH_BY_CONFIG;
-sub make_ah {
- my ( $package, $r ) = @_;
+my %AH_BY_CONFIG;
+sub make_ah
+{
+ my ($package, $r) = @_;
my $config = $r->dir_config;
@@ -400,31 +375,31 @@ sub make_ah {
# comp root), we append the document root for the current request
# to the key.
#
- my $key = (
- join $;, $r->document_root, map { $_, sort $config->get($_) }
+ my $key =
+ ( join $;,
+ $r->document_root,
+ map { $_, sort $config->get($_) }
grep { /^Mason/ }
keys %$config
- );
+ );
return $AH_BY_CONFIG{$key} if exists $AH_BY_CONFIG{$key};
my %p = $package->_get_mason_params($r);
# can't use hash_list for this one because it's _either_ a string
# or a hash_list
- if ( exists $p{comp_root} ) {
- if ( @{ $p{comp_root} } == 1 && $p{comp_root}->[0] !~ /=>/ ) {
- $p{comp_root} = $p{comp_root}[0]; # Convert to a simple string
- }
- else {
+ if (exists $p{comp_root}) {
+ if (@{$p{comp_root}} == 1 && $p{comp_root}->[0] !~ /=>/) {
+ $p{comp_root} = $p{comp_root}[0]; # Convert to a simple string
+ } else {
my @roots;
- foreach my $root ( @{ $p{comp_root} } ) {
+ foreach my $root (@{$p{comp_root}}) {
$root = [ split /\s*=>\s*/, $root, 2 ];
- param_error
- "Configuration parameter MasonCompRoot must be either "
- . "a single string value or multiple key/value pairs "
- . "like 'foo => /home/mason/foo'. Invalid parameter:\n$root"
- unless defined $root->[1];
+ param_error "Configuration parameter MasonCompRoot must be either ".
+ "a single string value or multiple key/value pairs ".
+ "like 'foo => /home/mason/foo'. Invalid parameter:\n$root"
+ unless defined $root->[1];
push @roots, $root;
}
@@ -433,7 +408,7 @@ sub make_ah {
}
}
- my $ah = $package->new( %p, $r );
+ my $ah = $package->new(%p, $r);
$AH_BY_CONFIG{$key} = $ah if $key;
return $ah;
@@ -442,33 +417,33 @@ sub make_ah {
# The following routines handle getting information from $r->dir_config
sub calm_form {
-
# Transform from StudlyCaps to name_like_this
- my ( $self, $string ) = @_;
+ my ($self, $string) = @_;
$string =~ s/^Mason//;
$string =~ s/(^|.)([A-Z])/$1 ? "$1\L_$2" : "\L$2"/ge;
return $string;
}
sub studly_form {
-
# Transform from name_like_this to StudlyCaps
- my ( $self, $string ) = @_;
+ my ($self, $string) = @_;
$string =~ s/(?:^|_)(\w)/\U$1/g;
return $string;
}
-sub _get_mason_params {
+sub _get_mason_params
+{
my $self = shift;
- my $r = shift;
+ my $r = shift;
my $config = $r ? $r->dir_config : _get_apache_server->dir_config;
# Get all params starting with 'Mason'
my %candidates;
- foreach my $studly ( keys %$config ) {
- ( my $calm = $studly ) =~ s/^Mason// or next;
+ foreach my $studly ( keys %$config )
+ {
+ (my $calm = $studly) =~ s/^Mason// or next;
$calm = $self->calm_form($calm);
$candidates{$calm} = $config->{$studly};
@@ -480,116 +455,127 @@ sub _get_mason_params {
# We will accumulate all the string versions of the keys and
# values here for later use.
#
- return (
- map { $_ => scalar $self->_get_param( $_, \%candidates, $config, $r ) }
- keys %candidates
- );
+ return ( map { $_ =>
+ scalar $self->_get_param( $_, \%candidates, $config, $r )
+ }
+ keys %candidates );
}
sub _get_param {
-
# Gets a single config item from dir_config.
- my ( $self, $key, $candidates, $config, $r ) = @_;
+ my ($self, $key, $candidates, $config, $r) = @_;
$key = $self->calm_form($key);
my $spec = $self->allowed_params( $candidates || {} )->{$key}
- or error "Unknown config item '$key'";
+ or error "Unknown config item '$key'";
# Guess the default parse type from the Params::Validate validation spec
- my $type = (
- $spec->{parse}
- or $spec->{type} & ARRAYREF ? 'list'
- : $spec->{type} & SCALAR ? 'string'
- : $spec->{type} & CODEREF ? 'code'
- : undef
- ) or error "Unknown parse type for config item '$key'";
+ my $type = ($spec->{parse} or
+ $spec->{type} & ARRAYREF ? 'list' :
+ $spec->{type} & SCALAR ? 'string' :
+ $spec->{type} & CODEREF ? 'code' :
+ undef)
+ or error "Unknown parse type for config item '$key'";
my $method = "_get_${type}_param";
- return $self->$method( 'Mason' . $self->studly_form($key), $config, $r );
+ return $self->$method('Mason'.$self->studly_form($key), $config, $r);
}
-sub _get_string_param {
+sub _get_string_param
+{
my $self = shift;
return scalar $self->_get_val(@_);
}
-sub _get_boolean_param {
+sub _get_boolean_param
+{
my $self = shift;
return scalar $self->_get_val(@_);
}
-sub _get_code_param {
+sub _get_code_param
+{
my $self = shift;
- my $p = $_[0];
- my $val = $self->_get_val(@_);
+ my $p = $_[0];
+ my $val = $self->_get_val(@_);
return unless $val;
my $sub_ref = eval $val;
param_error "Configuration parameter '$p' is not valid perl:\n$@\n"
- if $@;
+ if $@;
return $sub_ref;
}
-sub _get_list_param {
+sub _get_list_param
+{
my $self = shift;
- my @val = $self->_get_val(@_);
- if ( @val == 1 && !defined $val[0] ) {
+ my @val = $self->_get_val(@_);
+ if (@val == 1 && ! defined $val[0])
+ {
@val = ();
}
return \@val;
}
-sub _get_hash_list_param {
+sub _get_hash_list_param
+{
my $self = shift;
- my @val = $self->_get_val(@_);
- if ( @val == 1 && !defined $val[0] ) {
+ my @val = $self->_get_val(@_);
+ if (@val == 1 && ! defined $val[0])
+ {
return {};
}
my %hash;
- foreach my $pair (@val) {
- my ( $key, $val ) = split /\s*=>\s*/, $pair, 2;
- param_error "Configuration parameter $_[0] must be a key/value pair "
- . qq|like "foo => bar". Invalid parameter:\n$pair|
- unless defined $key && defined $val;
+ foreach my $pair (@val)
+ {
+ my ($key, $val) = split /\s*=>\s*/, $pair, 2;
+ param_error "Configuration parameter $_[0] must be a key/value pair ".
+ qq|like "foo => bar". Invalid parameter:\n$pair|
+ unless defined $key && defined $val;
$hash{$key} = $val;
}
return \%hash;
}
-sub _get_val {
- my ( $self, $p, $config, $r ) = @_;
+sub _get_val
+{
+ my ($self, $p, $config, $r) = @_;
my @val;
- if ( wantarray || !$config ) {
- if ($config) {
+ if (wantarray || !$config)
+ {
+ if ($config)
+ {
@val = $config->get($p);
}
- else {
+ else
+ {
my $c = $r ? $r : _get_apache_server;
@val = $c->dir_config->get($p);
}
}
- else {
+ else
+ {
@val = exists $config->{$p} ? $config->{$p} : ();
}
- param_error
- "Only a single value is allowed for configuration parameter '$p'\n"
- if @val > 1 && !wantarray;
+ param_error "Only a single value is allowed for configuration parameter '$p'\n"
+ if @val > 1 && ! wantarray;
return wantarray ? @val : $val[0];
}
-sub new {
+sub new
+{
my $class = shift;
# Get $r off end of params if its there
@@ -598,154 +584,141 @@ sub new {
my %params = @_;
my %defaults;
- $defaults{request_class} = 'HTML::Mason::Request::ApacheHandler'
- unless exists $params{request};
+ $defaults{request_class} = 'HTML::Mason::Request::ApacheHandler'
+ unless exists $params{request};
- my $allowed_params = $class->allowed_params( %defaults, %params );
+ my $allowed_params = $class->allowed_params(%defaults, %params);
- if ( exists $allowed_params->{comp_root}
- and my $req = $r
- || ( APACHE2 ? undef : Apache->request )
- ) # DocumentRoot is only available inside requests
+ if ( exists $allowed_params->{comp_root} and
+ my $req = $r || (APACHE2 ? undef : Apache->request) ) # DocumentRoot is only available inside requests
{
$defaults{comp_root} = $req->document_root;
}
- if ( exists $allowed_params->{data_dir} and not exists $params{data_dir} ) {
-
+ if (exists $allowed_params->{data_dir} and not exists $params{data_dir})
+ {
# constructs path to <server root>/mason
- if ( UNIVERSAL::can( 'Apache2::ServerUtil', 'server_root' ) ) {
- $defaults{data_dir} =
- File::Spec->catdir( Apache2::ServerUtil::server_root(), 'mason' );
- }
- else {
- $defaults{data_dir} = Apache->server_root_relative('mason');
+ if (UNIVERSAL::can('Apache2::ServerUtil','server_root')) {
+ $defaults{data_dir} = File::Spec->catdir(Apache2::ServerUtil::server_root(),'mason');
+ } else {
+ $defaults{data_dir} = Apache->server_root_relative('mason');
}
my $def = $defaults{data_dir};
- param_error
- "Default data_dir (MasonDataDir) '$def' must be an absolute path"
- unless File::Spec->file_name_is_absolute($def);
-
+ param_error "Default data_dir (MasonDataDir) '$def' must be an absolute path"
+ unless File::Spec->file_name_is_absolute($def);
+
my @levels = File::Spec->splitdir($def);
- param_error
- "Default data_dir (MasonDataDir) '$def' must be more than two levels deep (or must be set explicitly)"
- if @levels <= 3;
+ param_error "Default data_dir (MasonDataDir) '$def' must be more than two levels deep (or must be set explicitly)"
+ if @levels <= 3;
}
# Set default error_format based on error_mode
- if ( exists( $params{error_mode} ) and $params{error_mode} eq 'fatal' ) {
+ if (exists($params{error_mode}) and $params{error_mode} eq 'fatal') {
$defaults{error_format} = 'line';
- }
- else {
- $defaults{error_mode} = 'output';
+ } else {
+ $defaults{error_mode} = 'output';
$defaults{error_format} = 'html';
}
# Push $r onto default allow_globals
- if ( exists $allowed_params->{allow_globals} ) {
+ if (exists $allowed_params->{allow_globals}) {
if ( $params{allow_globals} ) {
push @{ $params{allow_globals} }, '$r';
- }
- else {
+ } else {
$defaults{allow_globals} = ['$r'];
}
}
- my $self = eval { $class->SUPER::new( %defaults, %params ) };
+ my $self = eval { $class->SUPER::new(%defaults, %params) };
# We catch this exception just to provide a better error message
- if ( $@
- && isa_mason_exception( $@, 'Params' )
- && $@->message =~ /comp_root/ )
+ if ( $@ && isa_mason_exception( $@, 'Params' ) && $@->message =~ /comp_root/ )
{
- param_error "No comp_root specified and cannot determine DocumentRoot."
- . " Please provide comp_root explicitly.";
+ param_error "No comp_root specified and cannot determine DocumentRoot." .
+ " Please provide comp_root explicitly.";
}
rethrow_exception $@;
- unless ( $self->interp->resolver->can('apache_request_to_comp_path') ) {
- error "The resolver class your Interp object uses does not implement "
- . "the 'apache_request_to_comp_path' method. This means that ApacheHandler "
- . "cannot resolve requests. Are you using a handler.pl file created "
- . "before version 1.10? Please see the handler.pl sample "
- . "that comes with the latest version of Mason.";
+ unless ( $self->interp->resolver->can('apache_request_to_comp_path') )
+ {
+ error "The resolver class your Interp object uses does not implement " .
+ "the 'apache_request_to_comp_path' method. This means that ApacheHandler " .
+ "cannot resolve requests. Are you using a handler.pl file created ".
+ "before version 1.10? Please see the handler.pl sample " .
+ "that comes with the latest version of Mason.";
}
# If we're running as superuser, change file ownership to http user & group
- if ( !( $> || $< ) && $self->interp->files_written ) {
+ if (!($> || $<) && $self->interp->files_written)
+ {
chown $self->get_uid_gid, $self->interp->files_written
- or system_error(
- "Can't change ownership of files written by interp object: $!\n");
+ or system_error( "Can't change ownership of files written by interp object: $!\n" );
}
$self->_initialize;
return $self;
}
-sub get_uid_gid {
- return ( Apache->server->uid, Apache->server->gid ) unless APACHE2;
+sub get_uid_gid
+{
+ return (Apache->server->uid, Apache->server->gid) unless APACHE2;
# Apache2 lacks $s->uid.
# Workaround by searching the config tree.
require Apache2::Directive;
my $conftree = Apache2::Directive::conftree();
- my $user = $conftree->lookup('User');
- my $group = $conftree->lookup('Group');
+ my $user = $conftree->lookup('User');
+ my $group = $conftree->lookup('Group');
- $user =~ s/^["'](.*)["']$/$1/;
+ $user =~ s/^["'](.*)["']$/$1/;
$group =~ s/^["'](.*)["']$/$1/;
- my $uid = $user ? getpwnam($user) : $>;
+ my $uid = $user ? getpwnam($user) : $>;
my $gid = $group ? getgrnam($group) : $);
- return ( $uid, $gid );
+ return ($uid, $gid);
}
sub _initialize {
my ($self) = @_;
my $apreq_module = APACHE2 ? 'Apache2::Request' : 'Apache::Request';
- if ( $self->args_method eq 'mod_perl' ) {
- unless ( defined $apreq_module->VERSION ) {
- warn "Loading $apreq_module at runtime. You could "
- . "increase shared memory between Apache processes by "
- . "preloading it in your httpd.conf or handler.pl file\n";
+ if ($self->args_method eq 'mod_perl') {
+ unless (defined $apreq_module->VERSION) {
+ warn "Loading $apreq_module at runtime. You could " .
+ "increase shared memory between Apache processes by ".
+ "preloading it in your httpd.conf or handler.pl file\n";
eval "require $apreq_module";
}
- }
- else {
- unless ( defined CGI->VERSION ) {
- warn "Loading CGI at runtime. You could increase shared "
- . "memory between Apache processes by preloading it in "
- . "your httpd.conf or handler.pl file\n";
+ } else {
+ unless (defined CGI->VERSION) {
+ warn "Loading CGI at runtime. You could increase shared ".
+ "memory between Apache processes by preloading it in ".
+ "your httpd.conf or handler.pl file\n";
require CGI;
}
}
# Add an HTML::Mason menu item to the /perl-status page.
my $apstat_module = APACHE2 ? 'Apache2::Status' : 'Apache::Status';
- if ( defined $apstat_module->VERSION ) {
-
+ if (defined $apstat_module->VERSION) {
# A closure, carries a reference to $self
my $statsub = sub {
- my ( $r, $q ) = @_; # request and CGI objects
+ my ($r,$q) = @_; # request and CGI objects
return [] if !defined($r);
- if ( $r->path_info and $r->path_info =~ /expire_code_cache=(.*)/ ) {
+ if ($r->path_info and $r->path_info =~ /expire_code_cache=(.*)/) {
$self->interp->delete_from_code_cache($1);
}
- return [
- "<center><h2>" . $self->apache_status_title . "</h2></center>",
- $self->status_as_html( apache_req => $r ),
- $self->interp->status_as_html( ah => $self, apache_req => $r )
- ];
+ return ["<center><h2>" . $self->apache_status_title . "</h2></center>" ,
+ $self->status_as_html(apache_req => $r),
+ $self->interp->status_as_html(ah => $self, apache_req => $r)];
};
- local $^W = 0; # to avoid subroutine redefined warnings
- $apstat_module->menu_item( $status_name, $self->apache_status_title,
- $statsub );
+ local $^W = 0; # to avoid subroutine redefined warnings
+ $apstat_module->menu_item($status_name, $self->apache_status_title, $statsub);
}
my $interp = $self->interp;
@@ -757,14 +730,14 @@ sub _initialize {
# needed since the user may simply create their own interp.
#
$interp->compiler->add_allowed_globals('$r')
- if $interp->compiler->can('add_allowed_globals');
+ if $interp->compiler->can('add_allowed_globals');
}
# Generate HTML that describes ApacheHandler's current status.
# This is used in things like Apache::Status reports.
sub status_as_html {
- my ( $self, %p ) = @_;
+ my ($self, %p) = @_;
# Should I be scared about this? =)
@@ -828,30 +801,32 @@ foreach my $property (sort keys %$ah) {
EOF
my $interp = $self->interp;
- my $comp = $interp->make_component( comp_source => $comp_source );
+ my $comp = $interp->make_component(comp_source => $comp_source);
my $out;
- $self->interp->make_request(
- comp => $comp,
- args => [ ah => $self, valid => $interp->allowed_params ],
- ah => $self,
- apache_req => $p{apache_req},
- out_method => \$out,
- )->exec;
+ $self->interp->make_request
+ ( comp => $comp,
+ args => [ah => $self, valid => $interp->allowed_params],
+ ah => $self,
+ apache_req => $p{apache_req},
+ out_method => \$out,
+ )->exec;
return $out;
}
-sub handle_request {
- my ( $self, $r ) = @_;
+sub handle_request
+{
+ my ($self, $r) = @_;
my $req = $self->prepare_request($r);
return $req unless ref($req);
return $req->exec;
}
-sub prepare_request {
+sub prepare_request
+{
my $self = shift;
my $r = $self->_apache_request_object(@_);
@@ -865,9 +840,7 @@ sub prepare_request {
#
# Compute the component path via the resolver. Return NOT_FOUND on failure.
#
- my $comp_path =
- $interp->resolver->apache_request_to_comp_path( $r,
- $interp->comp_root_array );
+ my $comp_path = $interp->resolver->apache_request_to_comp_path($r, $interp->comp_root_array);
unless ($comp_path) {
#
# Append path_info if filename does not represent an existing file
@@ -876,12 +849,12 @@ sub prepare_request {
my $pathname = $r->filename;
$pathname .= $r->path_info unless $fs_type eq 'file';
- warn "[Mason] Cannot resolve file to component: "
- . "$pathname (is file outside component root?)";
+ warn "[Mason] Cannot resolve file to component: " .
+ "$pathname (is file outside component root?)";
return $self->return_not_found($r);
}
- my ( $args, undef, $cgi_object ) = $self->request_args($r);
+ my ($args, undef, $cgi_object) = $self->request_args($r);
#
# Set up interpreter global variables.
@@ -892,43 +865,35 @@ sub prepare_request {
# 'ah' and 'apache_req' that's their problem.
#
my $m = eval {
- $interp->make_request(
- comp => $comp_path,
- args => [%$args],
- ah => $self,
- apache_req => $r,
- );
+ $interp->make_request( comp => $comp_path,
+ args => [%$args],
+ ah => $self,
+ apache_req => $r,
+ );
};
- if ( my $err = $@ ) {
-
+ if (my $err = $@) {
# We rethrow everything but TopLevelNotFound, Abort, and Decline errors.
-
- if ( isa_mason_exception( $@, 'TopLevelNotFound' ) ) {
- $r->log_error(
- "[Mason] File does not exist: ",
- $r->filename . ( $r->path_info || "" )
- );
+
+ if ( isa_mason_exception($@, 'TopLevelNotFound') ) {
+ $r->log_error("[Mason] File does not exist: ", $r->filename . ($r->path_info || ""));
return $self->return_not_found($r);
}
- my $retval = (
- isa_mason_exception( $err, 'Abort' ) ? $err->aborted_value
- : isa_mason_exception( $err, 'Decline' ) ? $err->declined_value
- : rethrow_exception $err
- );
+ my $retval = ( isa_mason_exception($err, 'Abort') ? $err->aborted_value :
+ isa_mason_exception($err, 'Decline') ? $err->declined_value :
+ rethrow_exception $err );
$retval = OK if defined $retval && $retval eq HTTP_OK;
unless ($retval) {
unless (APACHE2) {
- unless ( $r->notes('mason-sent-headers') ) {
+ unless ($r->notes('mason-sent-headers')) {
$r->send_http_header();
}
}
}
return $retval;
}
- $self->_set_mason_req_out_method( $m, $r )
- unless $self->{has_custom_out_method};
+ $self->_set_mason_req_out_method($m, $r) unless $self->{has_custom_out_method};
$m->cgi_object($cgi_object) if $m->can('cgi_object') && $cgi_object;
@@ -937,8 +902,8 @@ sub prepare_request {
my $do_filter = sub { $_[0]->filter_register };
my $no_filter = sub { $_[0] };
-
-sub _apache_request_object {
+sub _apache_request_object
+{
my $self = shift;
# We need to be careful to never assign a new apache (subclass)
@@ -947,31 +912,33 @@ sub _apache_request_object {
my $r_sub;
my $filter = $_[0]->dir_config('Filter');
- if ( defined $filter && lc $filter eq 'on' ) {
- die
- "To use Apache::Filter with Mason you must have at least version 1.021 of Apache::Filter\n"
- unless Apache::Filter->VERSION >= 1.021;
+ if ( defined $filter && lc $filter eq 'on' )
+ {
+ die "To use Apache::Filter with Mason you must have at least version 1.021 of Apache::Filter\n"
+ unless Apache::Filter->VERSION >= 1.021;
$r_sub = $do_filter;
}
- else {
+ else
+ {
$r_sub = $no_filter;
}
my $apreq_instance =
- APACHE2
- ? sub { Apache2::Request->new( $_[0] ) }
- : sub { $_[0] };
-
- return $r_sub->(
- $self->args_method eq 'mod_perl'
- ? $apreq_instance->($new_r)
- : $new_r
- );
+ APACHE2
+ ? sub { Apache2::Request->new( $_[0] ) }
+ : sub { $_[0] };
+
+ return
+ $r_sub->( $self->args_method eq 'mod_perl' ?
+ $apreq_instance->( $new_r ) :
+ $new_r
+ );
}
-sub _request_fs_type {
- my ( $self, $r ) = @_;
+sub _request_fs_type
+{
+ my ($self, $r) = @_;
#
# If filename is a directory, then either decline or simply reset
@@ -986,43 +953,45 @@ sub _request_fs_type {
return $is_dir ? 'dir' : -f _ ? 'file' : 'other';
}
-sub request_args {
- my ( $self, $r ) = @_;
+sub request_args
+{
+ my ($self, $r) = @_;
#
# Get arguments from Apache::Request or CGI.
#
- my ( $args, $cgi_object );
- if ( $self->args_method eq 'mod_perl' ) {
+ my ($args, $cgi_object);
+ if ($self->args_method eq 'mod_perl') {
$args = $self->_mod_perl_args($r);
- }
- else {
+ } else {
$cgi_object = CGI->new;
- $args = $self->_cgi_args( $r, $cgi_object );
+ $args = $self->_cgi_args($r, $cgi_object);
}
# we return $r solely for backwards compatibility
- return ( $args, $r, $cgi_object );
+ return ($args, $r, $cgi_object);
}
#
# Get $args hashref via CGI package
#
-sub _cgi_args {