HTML-Mason-1.59/0000755000175000017500000000000013660015140013123 5ustar autarchautarchHTML-Mason-1.59/benchmarks/0000755000175000017500000000000013660015140015240 5ustar autarchautarchHTML-Mason-1.59/benchmarks/multiple_benches.pl0000755000175000017500000000045313660015140021124 0ustar autarchautarch#!/usr/bin/perl # This program accepts a list of CVS revision tags (or dates) and a # benchmark to run. It then checks out the versions of Mason # indicated and uses them when running the benchmark indicated. This # helps facilitate tracking how Mason has changed over time on the # benchmarks. HTML-Mason-1.59/benchmarks/bench.pl0000755000175000017500000001126413660015140016663 0ustar autarchautarch#!/usr/bin/perl -w use strict; use lib '../lib'; use Benchmark; use Cwd; use Fcntl qw( O_RDWR O_CREAT ); use Getopt::Long; use MLDBM qw( DB_File Storable ); use Proc::ProcessTable; use File::Path; use File::Spec; my %tests = ( print => { code => sub { call_comp( '/comps/print.mas', title => 'print', integer => 1000 ) }, description => 'Calls $m->print many times.', }, one_comp => { code => sub { call_comp( '/comps/comp.mas' ) }, description => 'Calls a single component', }, large => { code => sub { call_comp( '/comps/large.mas' ) }, description => 'Calls a very large text-only component', }, ); my %flags = ( test => {type => ':s', descr => 'Specify one or more tests to perform.', default => []}, profile => {descr => '(Not implemented)'}, reps => {type => ':i', descr => 'Number of times to repeat each test. Defaults to 1000.', default => 1000}, save => {descr => 'Saves information to result_history.db (an MLDBM DB_File).'}, cvs_tag => {type => ':s', descr => 'A CVS tag (like "-r release-1-1-5") to check out in lib/ first.'}, tag => {type => ':s', descr => 'Specifies a tag to save to result_history.db. '. 'Default is $HTML::Mason::VERSION or --cvs_tag value.'}, clear_cache => {descr => 'Will clear on-disk cache first. Useful for exercising the compiler.'}, help => {descr => 'Prints this message and exits.'}, ); my %opts; $opts{$_} = $flags{$_}{default} foreach grep exists($flags{$_}{default}), keys %flags; { local $^W; GetOptions( \%opts, map "$_$flags{$_}{type}", keys %flags ); } if ( $opts{help} ) { usage(); exit; } die "$0 must be run from inside the benchmarks/ directory\n" unless -e 'comps' and -d 'comps'; my $large_comp = File::Spec->catfile( 'comps', 'large.mas' ); # Don't check this into CVS because it's big: unless ( -e $large_comp ) { open my $fh, ">$large_comp" or die "Can't create $large_comp: $!"; print $fh 'x' x 79, "\n" for 1..30_000; # 80 * 30_000 = 2.4 MB } if ($opts{cvs_tag}) { my $cwd = cwd(); my $lib = File::Spec->catdir( $cwd, '..', 'lib' ); print "chdir $lib\n"; chdir $lib or die "Can't chdir($lib): $!"; my $cmd = "cvs update $opts{cvs_tag}"; print "$cmd\n"; open my($fh), "$cmd |" or die "Can't execute '$cmd': $!"; print while <$fh>; close $fh or die "Can't close command: $!"; $opts{tag} ||= $opts{cvs_tag}; chdir $cwd or die "Can't chdir($lib): $!"; } # Do this only after updating lib/ to proper CVS version require HTML::Mason; $opts{tag} ||= $HTML::Mason::VERSION; # Clear out the mason-data directory, otherwise we might include # compilation in one run and not the next my $data_dir = File::Spec->rel2abs( File::Spec->catdir( cwd, 'mason-data' ) ); rmtree($data_dir) if $opts{clear_cache}; foreach my $test ( @{ $opts{test} } ) { unless ( exists $tests{$test} ) { print "\n*** Invalid test: $test\n"; usage(); exit; } } my $interp = HTML::Mason::Interp->new( comp_root => File::Spec->rel2abs(cwd), data_dir => $data_dir, ); my ($proc) = grep { $_->pid == $$ } @{ Proc::ProcessTable->new->table }; print "\n"; foreach my $name ( @{ $opts{test} } ) { my $results = Benchmark::timethis( $opts{reps}, $tests{$name}{code}, $name ); my $per_sec = sprintf( '%.2f', $opts{reps} / ($results->[1] + $results->[2]) ); my $rss = sprintf( '%.2f', ( $proc->rss / 1024 ) ); my $size = sprintf( '%.2f', ( $proc->size / 1024 ) ); # my ($rss, $vsz) = `ps -eo rss,vsz -p $$` =~ /(\d+)\s+(\d+)/; print " Real mem: $rss MB\n"; print "Virtual mem: $size MB\n"; if ( $opts{save} ) { my %save; tie %save, 'MLDBM', 'result_history.db', O_CREAT | O_RDWR, 0644 or die "Cannot tie to result_history.db: $!"; my $tag = $opts{tag}; my $old = $save{$tag}; $old->{$name} ||= []; push @{ $old->{$name} }, $per_sec; $save{$tag} = $old; } } print "\n"; sub call_comp { my ($comp, @args) = @_; my $out; $interp->out_method(\$out); $interp->exec( $comp, @args ); } sub usage { my $comps; foreach my $name ( sort keys %tests ) { $comps .= sprintf( " %-10s %s\n", $name, $tests{$name}{description} ); } my $opts; foreach my $name ( sort keys %flags ) { $opts .= sprintf " %13s %s\n", "--$name", $flags{$name}{descr}; } print <<"EOF"; Usage: $0 $opts Valid tests include: $comps EOF } HTML-Mason-1.59/benchmarks/comps/0000755000175000017500000000000013660015140016361 5ustar autarchautarchHTML-Mason-1.59/benchmarks/comps/comp_helper.mas0000644000175000017500000000004613660015140021360 0ustar autarchautarchbar! % my $x = 2; <% $x %> bar again! HTML-Mason-1.59/benchmarks/comps/comp.mas0000644000175000017500000000025213660015140020020 0ustar autarchautarchcall comp_helper.mas a bunch <& comp_helper.mas &> <& comp_helper.mas &> <& comp_helper.mas &> <& comp_helper.mas &> <& comp_helper.mas &> <& comp_helper.mas &> called itHTML-Mason-1.59/benchmarks/comps/print.mas0000644000175000017500000000645313660015140020227 0ustar autarchautarch<%args> $title $integer <% $title %> <%perl> # build tight loop table with array data, multidimensional 5x6 my @array = sort ("Hello", "World", "2000", "Hello", "World", "2000"); my @multi = (\@array, \@array, \@array, \@array, \@array); % for my $row (0..$#multi) { % for my $col (0..$#array) { % } % }
<% $multi[$row][$col] %>
<%perl> for my $i (1..5) { my $var = $i+$integer; <%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%$var%> Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
<%perl> } HTML-Mason-1.59/eg/0000755000175000017500000000000013660015140013516 5ustar autarchautarchHTML-Mason-1.59/eg/httpd.conf0000644000175000017500000000103713660015140015511 0ustar autarchautarch# # Simple Mason configuration via httpd.conf directives. # # Make sure to preload as much code as we can in the parent process. PerlModule HTML::Mason::ApacheHandler PerlModule Apache::Request # Serve these requests through Mason. SetHandler perl-script PerlHandler HTML::Mason::ApacheHandler # Hide private components from users. SetHandler perl-script PerlInitHandler Apache::Constants::NOT_FOUND HTML-Mason-1.59/eg/MyApp/0000755000175000017500000000000013660015140014544 5ustar autarchautarchHTML-Mason-1.59/eg/MyApp/MasonWithSession.pm0000644000175000017500000000202713660015140020360 0ustar autarchautarchpackage MyApp::MasonPlusSession; use strict; use warnings; use HTML::Mason::ApacheHandler; # This does not come with the Mason core code. It must be installed # from CPAN separately. use MasonX::Request::PlusApacheSession; my $ah = new HTML::Mason::ApacheHandler ( request_class => 'MasonX::Request::PlusApacheSession', session_class => 'Apache::Session::File', # Let MasonX::Request::PlusApacheSession automatically # set and read cookies containing the session id session_use_cookie => 1, session_directory => '/tmp/sessions', session_lock_directory => '/tmp/session-locks', comp_root => '', data_dir => '' ); sub handler { my ($r) = @_; my $status = $ah->handle_request($r); return $status; } 1; __END__ In your httpd.conf, add something like this: PerlRequire MyApp::MasonPlusSession SetHandler perl-script PerlHandler MyApp::MasonPlusSession HTML-Mason-1.59/eg/MyApp/Mason.pm0000644000175000017500000000127013660015140016157 0ustar autarchautarchpackage MyApp::Mason; # Bring in Mason with Apache support. use HTML::Mason::ApacheHandler; use strict; # List of modules that you want to use within components. { package HTML::Mason::Commands; use Data::Dumper; } # Create ApacheHandler object at startup. my $ah = new HTML::Mason::ApacheHandler( comp_root => '', data_dir => '' ); sub handler { my ($r) = @_; my $status = $ah->handle_request($r); return $status; } 1; __END__ In your httpd.conf, add something like this: PerlRequire MyApp::Mason SetHandler perl-script PerlHandler MyApp::Mason HTML-Mason-1.59/Makefile.PL0000644000175000017500000000365713660015140015110 0ustar autarchautarch# This Makefile.PL for HTML-Mason was generated by # Dist::Zilla::Plugin::DROLSKY::MakeMaker 1.08 # and Dist::Zilla::Plugin::MakeMaker::Awesome 0.48. # Don't edit it but the dist.ini and plugins used to construct it. use strict; use warnings; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "High-performance, dynamic web site authoring system", "AUTHOR" => "Jonathan Swartz , Dave Rolsky , Ken Williams ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "HTML-Mason", "EXE_FILES" => [ "bin/convert0.6.README", "bin/convert0.6.pl", "bin/convert0.8.README", "bin/convert0.8.pl", "bin/mason.pl" ], "LICENSE" => "perl", "NAME" => "HTML::Mason", "PREREQ_PM" => { "CGI" => "2.46", "Cache::Cache" => "1.00", "Class::Container" => "0.07", "Exception::Class" => "1.15", "File::Spec" => "0.8", "HTML::Entities" => 0, "Log::Any" => "0.08", "Params::Validate" => "0.70", "Scalar::Util" => "1.01" }, "TEST_REQUIRES" => { "ExtUtils::MakeMaker" => 0, "File::Spec" => "0.8", "Test::Deep" => 0, "Test::More" => "0.96" }, "VERSION" => "1.59", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "CGI" => "2.46", "Cache::Cache" => "1.00", "Class::Container" => "0.07", "Exception::Class" => "1.15", "ExtUtils::MakeMaker" => 0, "File::Spec" => "0.8", "HTML::Entities" => 0, "Log::Any" => "0.08", "Params::Validate" => "0.70", "Scalar::Util" => "1.01", "Test::Deep" => 0, "Test::More" => "0.96" ); unless ( eval { ExtUtils::MakeMaker->VERSION('6.63_03') } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); HTML-Mason-1.59/CREDITS0000644000175000017500000000755313660015140014155 0ustar autarchautarchMason was created by Jonathan Swartz over several years at CMP Media. The main development team shifts over time, as with most open source projects. However, at the time of writing, most development is done by Dave Rolsky and Jonathan Swartz. Other contributors, most recent first: (Summer '01) John Williams (no relation) helped implement a number of new features for what became Mason 1.10, including buffer objects and component calls with content. (July '01) Matthew Lewinski created the design for the second overhaul of Mason HQ. (November '00) Dave Rolsky was the first new member to the development team since Mason's inception. Before joining Dave revamped the parser module, answered numerous queries on the user's list and initiated discussions on Mason's future. Ken Williams has submitted a variety of code cleanups/speedups and hosted the first mailing list archive at the math forum. Michael Dorman, Ken Miller and Ken Williams currently administer the mailing lists. Thanks to Hank Leininger and the folks at MARC for their excellent mail archive interface, on which all of Mason's lists are archived. (July '99) Matt Jalbert lent his artistic flair to the Mason HQ web site design. (February '99) Patrick Kane was an early Mason adopter providing useful feedback from the beginning. He acted briefly as FAQ maintainer and contributed the first session-related examples. Patrick currently hosts the Mason site and core development server. Kirrily 'Skud' Robert started the first Mason mailing list and hosted it at netizen for over a year. (October '98) The original idea for Mason was inspired by the component system used by NetGuide Live at CMP Media in 1996. HTML++ lives on! Gady Costeff formulated the need for a better component-based web engine and blessed us with a creative, open-minded environment. Tom Smith protected our core development team from hostile forces, kept calm during the storms, and was (and continues to be) a great ally of the Mason open source initiative. Thanks to Debra Robinson and CMP management for generously supporting the Mason and Content Management open source releases. Chris Dobosz helped design the predecessor to Mason (Scribe) and implemented the predecessor to Content Management system. He had the first non-CMP production web site to use Mason, Mojam.com. Dennis Watson also helped design Scribe and was a never-ending source of Perl and Oracle wisdom. Kurt Hurtado helped convert Scribe to Mason and created the CD-ME example. Mark Schmick wrote all of the original Mason documentation and helped greatly in getting the first release out the door. He also created the Mason Content Management system. The Internet technology team at CMP was supportive and patient with me as I brought down the systems with my periodic Mason "improvements". ----- Besides those mentioned above, the following people have contributed suggestions or patches, as listed in the Changes file: John Arnold Alexei V. Barantsev Oleg Bartunov Vadim Belman John Beppu Jeremy Blain Manuel Capinha Paolo Campanella Benoit Caron Sean Cazzell Nicholas Clark Caleb Crome Joe Edmonds Ewan Edwards Pascal Eeftinck Joe Frisbie Jon Frisby Radu Greab Philip Gwyn Eric Hammond Gordon Henriksen Mark A. Hershberger Tom Higgins Brian Holmes Matt Hoskins Tom Hughes Tom Hukins Chris Hutchinson Pelle Johnsen Bojan Jovanovic Ilmari Karonen Dirk Koopman Fen Lebalme Austin S. Lin John Michael Mars Ilya Martynov Brent Michalski Louis-David Mitterrand Jim Mortko Chuck O'Donnell Ivan E. Panchenko Rob Perelman Carl Raiha Alex Robinson Aaron Ross Adam Roth Paul Schilling Randal Schwartz Lee Semel Denis Shaposhnikov Michael Shulman John Siracusa Barrie Slaymaker Scott Straley Adam Stubbs Jeremy Taylor Gert Thiel John Tobey Renzo Toma Doug Treder Benjamin John Turner Jindra Vavruska Jesse Vincent Kees Vonk Viacheslav Voytovich Rafael Weinstein David Wheeler Mikhail Zabaluev Thanks y'all! HTML-Mason-1.59/META.yml0000644000175000017500000006110413660015140014376 0ustar autarchautarch--- abstract: 'High-performance, dynamic web site authoring system' author: - 'Jonathan Swartz ' - 'Dave Rolsky ' - 'Ken Williams ' build_requires: ExtUtils::MakeMaker: '0' File::Spec: '0.8' Test::Deep: '0' Test::More: '0.96' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.014, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: HTML-Mason no_index: directory: - eg file: - lib/HTML/Mason/Tests.pm requires: CGI: '2.46' Cache::Cache: '1.00' Class::Container: '0.07' Exception::Class: '1.15' File::Spec: '0.8' HTML::Entities: '0' Log::Any: '0.08' Params::Validate: '0.70' Scalar::Util: '1.01' resources: bugtracker: https://github.com/houseabsolute/HTML-Mason/issues homepage: https://metacpan.org/release/HTML-Mason repository: git://github.com/houseabsolute/HTML-Mason.git version: '1.59' x_Dist_Zilla: perl: version: '5.030001' plugins: - class: Dist::Zilla::Plugin::FileFinder::Filter name: SkipApacheHandler version: '6.014' - class: Dist::Zilla::Plugin::PkgVersion name: PkgVersion version: '6.014' - class: Dist::Zilla::Plugin::Git::GatherDir config: Dist::Zilla::Plugin::GatherDir: exclude_filename: - CODE_OF_CONDUCT.md - CONTRIBUTING.md - LICENSE - Makefile.PL - README.md - cpanfile exclude_match: [] follow_symlinks: 0 include_dotfiles: 0 prefix: '' prune_directory: [] root: . Dist::Zilla::Plugin::Git::GatherDir: include_untracked: 0 name: '@DROLSKY/Git::GatherDir' version: '2.046' - class: Dist::Zilla::Plugin::ManifestSkip name: '@DROLSKY/ManifestSkip' version: '6.014' - class: Dist::Zilla::Plugin::License name: '@DROLSKY/License' version: '6.014' - class: Dist::Zilla::Plugin::ExecDir name: '@DROLSKY/ExecDir' version: '6.014' - class: Dist::Zilla::Plugin::ShareDir name: '@DROLSKY/ShareDir' version: '6.014' - class: Dist::Zilla::Plugin::Manifest name: '@DROLSKY/Manifest' version: '6.014' - class: Dist::Zilla::Plugin::CheckVersionIncrement name: '@DROLSKY/CheckVersionIncrement' version: '0.121750' - class: Dist::Zilla::Plugin::TestRelease name: '@DROLSKY/TestRelease' version: '6.014' - class: Dist::Zilla::Plugin::ConfirmRelease name: '@DROLSKY/ConfirmRelease' version: '6.014' - class: Dist::Zilla::Plugin::UploadToCPAN name: '@DROLSKY/UploadToCPAN' version: '6.014' - class: Dist::Zilla::Plugin::Authority name: '@DROLSKY/Authority' version: '1.009' - class: Dist::Zilla::Plugin::CopyFilesFromBuild name: '@DROLSKY/CopyFilesFromBuild' version: '0.170880' - class: Dist::Zilla::Plugin::GitHub::Meta name: '@DROLSKY/GitHub::Meta' version: '0.47' - class: Dist::Zilla::Plugin::GitHub::Update config: Dist::Zilla::Plugin::GitHub::Update: metacpan: 1 name: '@DROLSKY/GitHub::Update' version: '0.47' - class: Dist::Zilla::Plugin::MetaResources name: '@DROLSKY/MetaResources' version: '6.014' - class: Dist::Zilla::Plugin::Meta::Contributors name: '@DROLSKY/Meta::Contributors' version: '0.003' - class: Dist::Zilla::Plugin::MetaConfig name: '@DROLSKY/MetaConfig' version: '6.014' - class: Dist::Zilla::Plugin::MetaJSON name: '@DROLSKY/MetaJSON' version: '6.014' - class: Dist::Zilla::Plugin::MetaYAML name: '@DROLSKY/MetaYAML' version: '6.014' - class: Dist::Zilla::Plugin::NextRelease name: '@DROLSKY/NextRelease' version: '6.014' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: test type: requires name: '@DROLSKY/Test::More with subtest' version: '6.014' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: develop type: requires name: '@DROLSKY/Modules for use with tidyall' version: '6.014' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: develop type: requires name: '@DROLSKY/Test::Version which fixes https://github.com/plicease/Test-Version/issues/7' version: '6.014' - class: Dist::Zilla::Plugin::PromptIfStale config: Dist::Zilla::Plugin::PromptIfStale: check_all_plugins: 0 check_all_prereqs: 0 modules: - Dist::Zilla::PluginBundle::DROLSKY phase: build run_under_travis: 0 skip: [] name: '@DROLSKY/Dist::Zilla::PluginBundle::DROLSKY' version: '0.057' - class: Dist::Zilla::Plugin::PromptIfStale config: Dist::Zilla::Plugin::PromptIfStale: check_all_plugins: 1 check_all_prereqs: 1 modules: [] phase: release run_under_travis: 0 skip: - Dist::Zilla::Plugin::DROLSKY::Contributors - Dist::Zilla::Plugin::DROLSKY::Git::CheckFor::CorrectBranch - Dist::Zilla::Plugin::DROLSKY::License - Dist::Zilla::Plugin::DROLSKY::TidyAll - Dist::Zilla::Plugin::DROLSKY::WeaverConfig - Pod::Weaver::PluginBundle::DROLSKY name: '@DROLSKY/PromptIfStale' version: '0.057' - class: Dist::Zilla::Plugin::Test::PodSpelling config: Dist::Zilla::Plugin::Test::PodSpelling: directories: - bin - lib spell_cmd: '' stopwords: - AUTOHANDLERS - Adminstrator - ApacheModPerl - ApacheReload - Autohandlers - Bekman - CGI - ContactUs - DROLSKY - "DROLSKY's" - DSO - DeWitt - DocumentRoot - DocumentRoots - FastCGI - FilesMatch - Follett - ForceFileDownload - GIF - Georgiou - HPUX - HUP - HandlingDirectoriesWithDhandlers - Khera - Kiriakos - Kirwan - Kumar - LFU - LogLevel - MSIE - MailingLists - Mallah - MasonAllowGlobals - MasonApacheStatusTitle - MasonArgsMethod - MasonAutoSendHeaders - MasonAutoflush - MasonAutohandlerName - MasonBufferPreallocateSize - MasonCodeCacheMaxSize - MasonCompClass - MasonCompRoot - MasonCompilerClass - MasonComponentErrorHandler - MasonDataCacheApi - MasonDataCacheDefaults - MasonDataDir - MasonDeclineDirs - MasonDefaultEscapeFlags - MasonDefineArgsHash - MasonDhandlerName - MasonDynamicCompRoot - MasonEnableAutoflush - MasonErrorFormat - MasonErrorMode - MasonEscapeFlags - MasonIgnoreWarningsExpr - MasonInPackage - MasonInterpClass - MasonLexerClass - MasonMaxRecurse - MasonNamedComponentSubs - MasonObjectFileExtension - MasonOutMethod - MasonPlugins - MasonPostamble - MasonPostprocessPerl - MasonPostprocessText - MasonPreamble - MasonPreloads - MasonPreprocess - MasonRequestClass - MasonResolverClass - MasonStaticSource - MasonStaticSourceTouchFile - MasonSubcompClass - MasonUseObjectFiles - MasonUseSourceLineNumbers - MasonUseStrict - MasonUseWarnings - NullCache - "O'Reilly" - PRs - PayPal - PerlFreshRestart - PerlHandler - PerlModule - PerlSetVar - Preallocating - Preloading - RPMs - Rajesh - RedHat - ReloadAll - Rolsky - "Rolsky's" - SUBCLASSABLE - SYNOPIS - Solaris - SpeedyCGI - Stas - Subcomponents - Subrequests - TIEHASH - USR - UserDir - Vivek - ala - apachectl - apachehandler - attr - autohandler - autohandlers - bgcolor - "breakpoint'able" - certian - checksum - conf - corrup - "defined'ness" - dhandler - dhandlers - drolsky - dynamicImage - faq - fh - fido - filenaming - foobarbaz - gif - gifs - htaccess - html - interp - isNetscape - ized - izing - jpegs - lexed - libapreq - libexpat - mc - mcomp - mhtml - mpl - mtxt - nh - onwards - optimizations - overrideable - perlsub - postprocess - predeclaring - preload - preloaded - preloading - preloads - prepopulate - preprocess - profiler - rdist - reallocations - reparsed - reuseability - scomp - se - serializable - sql - srm - subcomponent - subcomponents - subcomps - subexec - subrequest - subrequests - taglibs - tgz - tmp - todo - un - undeclarable - unweakened - updateable - uring - "use'd" - xml wordlist: Pod::Wordlist name: '@DROLSKY/Test::PodSpelling' version: '2.007005' - class: Dist::Zilla::Plugin::PodSyntaxTests name: '@DROLSKY/PodSyntaxTests' version: '6.014' - class: Dist::Zilla::Plugin::DROLSKY::RunExtraTests config: Dist::Zilla::Role::TestRunner: default_jobs: 24 name: '@DROLSKY/DROLSKY::RunExtraTests' version: '1.08' - class: Dist::Zilla::Plugin::MojibakeTests name: '@DROLSKY/MojibakeTests' version: '0.8' - class: Dist::Zilla::Plugin::Test::CPAN::Meta::JSON name: '@DROLSKY/Test::CPAN::Meta::JSON' version: '0.004' - class: Dist::Zilla::Plugin::Test::NoTabs config: Dist::Zilla::Plugin::Test::NoTabs: filename: xt/author/no-tabs.t finder: - ':InstallModules' - ':ExecFiles' - ':TestFiles' name: '@DROLSKY/Test::NoTabs' version: '0.15' - class: Dist::Zilla::Plugin::Test::ReportPrereqs name: '@DROLSKY/Test::ReportPrereqs' version: '0.027' - class: Dist::Zilla::Plugin::Test::Version name: '@DROLSKY/Test::Version' version: '1.09' - class: Dist::Zilla::Plugin::DROLSKY::Contributors name: '@DROLSKY/DROLSKY::Contributors' version: '1.08' - class: Dist::Zilla::Plugin::Git::Contributors config: Dist::Zilla::Plugin::Git::Contributors: git_version: 2.20.1 include_authors: 0 include_releaser: 1 order_by: name paths: [] name: '@DROLSKY/Git::Contributors' version: '0.035' - class: Dist::Zilla::Plugin::SurgicalPodWeaver config: Dist::Zilla::Plugin::PodWeaver: config_plugins: - '@DROLSKY' finder: - ':InstallModules' - ':ExecFiles' plugins: - class: Pod::Weaver::Plugin::EnsurePod5 name: '@CorePrep/EnsurePod5' version: '4.015' - class: Pod::Weaver::Plugin::H1Nester name: '@CorePrep/H1Nester' version: '4.015' - class: Pod::Weaver::Plugin::SingleEncoding name: '@DROLSKY/SingleEncoding' version: '4.015' - class: Pod::Weaver::Plugin::Transformer name: '@DROLSKY/List' version: '4.015' - class: Pod::Weaver::Plugin::Transformer name: '@DROLSKY/Verbatim' version: '4.015' - class: Pod::Weaver::Section::Region name: '@DROLSKY/header' version: '4.015' - class: Pod::Weaver::Section::Name name: '@DROLSKY/Name' version: '4.015' - class: Pod::Weaver::Section::Version name: '@DROLSKY/Version' version: '4.015' - class: Pod::Weaver::Section::Region name: '@DROLSKY/prelude' version: '4.015' - class: Pod::Weaver::Section::Generic name: SYNOPSIS version: '4.015' - class: Pod::Weaver::Section::Generic name: DESCRIPTION version: '4.015' - class: Pod::Weaver::Section::Generic name: OVERVIEW version: '4.015' - class: Pod::Weaver::Section::Collect name: ATTRIBUTES version: '4.015' - class: Pod::Weaver::Section::Collect name: METHODS version: '4.015' - class: Pod::Weaver::Section::Collect name: FUNCTIONS version: '4.015' - class: Pod::Weaver::Section::Collect name: TYPES version: '4.015' - class: Pod::Weaver::Section::Leftovers name: '@DROLSKY/Leftovers' version: '4.015' - class: Pod::Weaver::Section::Region name: '@DROLSKY/postlude' version: '4.015' - class: Pod::Weaver::Section::GenerateSection name: '@DROLSKY/generate SUPPORT' version: '1.06' - class: Pod::Weaver::Section::AllowOverride name: '@DROLSKY/allow override SUPPORT' version: '0.05' - class: Pod::Weaver::Section::GenerateSection name: '@DROLSKY/generate SOURCE' version: '1.06' - class: Pod::Weaver::Section::Authors name: '@DROLSKY/Authors' version: '4.015' - class: Pod::Weaver::Section::Contributors name: '@DROLSKY/Contributors' version: '0.009' - class: Pod::Weaver::Section::Legal name: '@DROLSKY/Legal' version: '4.015' - class: Pod::Weaver::Section::AllowOverride name: '@DROLSKY/allow override Legal' version: '0.05' - class: Pod::Weaver::Section::Region name: '@DROLSKY/footer' version: '4.015' name: '@DROLSKY/SurgicalPodWeaver' version: '0.0023' - class: Dist::Zilla::Plugin::DROLSKY::WeaverConfig name: '@DROLSKY/DROLSKY::WeaverConfig' version: '1.08' - class: Dist::Zilla::Plugin::ReadmeAnyFromPod config: Dist::Zilla::Role::FileWatcher: version: '0.006' name: '@DROLSKY/README.md in build' version: '0.163250' - class: Dist::Zilla::Plugin::GenerateFile::FromShareDir config: Dist::Zilla::Plugin::GenerateFile::FromShareDir: destination_filename: CONTRIBUTING.md dist: Dist-Zilla-PluginBundle-DROLSKY encoding: UTF-8 has_xs: '0' location: build source_filename: CONTRIBUTING.md Dist::Zilla::Role::RepoFileInjector: allow_overwrite: 1 repo_root: . version: '0.009' name: '@DROLSKY/Generate CONTRIBUTING.md' version: '0.014' - class: Dist::Zilla::Plugin::GenerateFile::FromShareDir config: Dist::Zilla::Plugin::GenerateFile::FromShareDir: destination_filename: CODE_OF_CONDUCT.md dist: Dist-Zilla-PluginBundle-DROLSKY encoding: UTF-8 has_xs: '0' location: build source_filename: CODE_OF_CONDUCT.md Dist::Zilla::Role::RepoFileInjector: allow_overwrite: 1 repo_root: . version: '0.009' name: '@DROLSKY/Generate CODE_OF_CONDUCT.md' version: '0.014' - class: Dist::Zilla::Plugin::InstallGuide config: Dist::Zilla::Role::ModuleMetadata: Module::Metadata: '1.000037' version: '0.006' name: '@DROLSKY/InstallGuide' version: '1.200013' - class: Dist::Zilla::Plugin::CPANFile name: '@DROLSKY/CPANFile' version: '6.014' - class: Dist::Zilla::Plugin::DROLSKY::License name: '@DROLSKY/DROLSKY::License' version: '1.08' - class: Dist::Zilla::Plugin::CheckStrictVersion name: '@DROLSKY/CheckStrictVersion' version: '0.001' - class: Dist::Zilla::Plugin::CheckSelfDependency config: Dist::Zilla::Plugin::CheckSelfDependency: finder: - ':InstallModules' Dist::Zilla::Role::ModuleMetadata: Module::Metadata: '1.000037' version: '0.006' name: '@DROLSKY/CheckSelfDependency' version: '0.011' - class: Dist::Zilla::Plugin::CheckPrereqsIndexed name: '@DROLSKY/CheckPrereqsIndexed' version: '0.020' - class: Dist::Zilla::Plugin::DROLSKY::Git::CheckFor::CorrectBranch config: Dist::Zilla::Role::Git::Repo: git_version: 2.20.1 repo_root: . name: '@DROLSKY/DROLSKY::Git::CheckFor::CorrectBranch' version: '1.08' - class: Dist::Zilla::Plugin::EnsureChangesHasContent name: '@DROLSKY/EnsureChangesHasContent' version: '0.02' - class: Dist::Zilla::Plugin::Git::Check config: Dist::Zilla::Plugin::Git::Check: untracked_files: die Dist::Zilla::Role::Git::DirtyFiles: allow_dirty: - CODE_OF_CONDUCT.md - CONTRIBUTING.md - Changes - LICENSE - Makefile.PL - README.md - cpanfile - tidyall.ini allow_dirty_match: [] changelog: Changes Dist::Zilla::Role::Git::Repo: git_version: 2.20.1 repo_root: . name: '@DROLSKY/Git::Check' version: '2.046' - class: Dist::Zilla::Plugin::Git::Commit config: Dist::Zilla::Plugin::Git::Commit: add_files_in: [] commit_msg: v%V%n%n%c Dist::Zilla::Role::Git::DirtyFiles: allow_dirty: - CODE_OF_CONDUCT.md - CONTRIBUTING.md - Changes - LICENSE - Makefile.PL - README.md - cpanfile - tidyall.ini allow_dirty_match: [] changelog: Changes Dist::Zilla::Role::Git::Repo: git_version: 2.20.1 repo_root: . Dist::Zilla::Role::Git::StringFormatter: time_zone: local name: '@DROLSKY/Commit generated files' version: '2.046' - class: Dist::Zilla::Plugin::Git::Tag config: Dist::Zilla::Plugin::Git::Tag: branch: ~ changelog: Changes signed: 0 tag: v1.59 tag_format: v%V tag_message: v%V Dist::Zilla::Role::Git::Repo: git_version: 2.20.1 repo_root: . Dist::Zilla::Role::Git::StringFormatter: time_zone: local name: '@DROLSKY/Git::Tag' version: '2.046' - class: Dist::Zilla::Plugin::Git::Push config: Dist::Zilla::Plugin::Git::Push: push_to: - origin remotes_must_exist: 1 Dist::Zilla::Role::Git::Repo: git_version: 2.20.1 repo_root: . name: '@DROLSKY/Git::Push' version: '2.046' - class: Dist::Zilla::Plugin::Git::Commit config: Dist::Zilla::Plugin::Git::Commit: add_files_in: [] commit_msg: 'Bump version after release' Dist::Zilla::Role::Git::DirtyFiles: allow_dirty: - Changes - dist.ini allow_dirty_match: - (?^:.+) changelog: Changes Dist::Zilla::Role::Git::Repo: git_version: 2.20.1 repo_root: . Dist::Zilla::Role::Git::StringFormatter: time_zone: local name: '@DROLSKY/Commit version bump' version: '2.046' - class: Dist::Zilla::Plugin::Git::Push config: Dist::Zilla::Plugin::Git::Push: push_to: - origin remotes_must_exist: 1 Dist::Zilla::Role::Git::Repo: git_version: 2.20.1 repo_root: . name: '@DROLSKY/Push version bump' version: '2.046' - class: Dist::Zilla::Plugin::DROLSKY::MakeMaker config: Dist::Zilla::Plugin::MakeMaker: make_path: make version: '6.014' Dist::Zilla::Plugin::MakeMaker::Awesome: version: '0.48' Dist::Zilla::Role::TestRunner: default_jobs: 24 version: '6.014' name: '@DROLSKY/DROLSKY::MakeMaker' version: '1.08' - class: Dist::Zilla::Plugin::MetaNoIndex name: MetaNoIndex version: '6.014' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: develop type: requires name: DevelopRequires version: '6.014' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: runtime type: requires name: RuntimeRequires version: '6.014' - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: test type: requires name: TestRequires version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':InstallModules' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':IncModules' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':TestFiles' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':ExtraTestFiles' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':ExecFiles' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':PerlExecFiles' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':ShareFiles' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':MainModule' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':AllFiles' version: '6.014' - class: Dist::Zilla::Plugin::FinderCode name: ':NoFiles' version: '6.014' zilla: class: Dist::Zilla::Dist::Builder config: is_trial: '0' version: '6.014' x_authority: cpan:DROLSKY x_contributors: - 'Ævar Arnfjörð Bjarmason ' - 'Alex Balhatchet ' - 'Alex Vandiver ' - 'Florian Schlichting ' - 'John Williams ' - 'Kent Fredric ' - 'Kevin Falcone ' - 'Patrick Kane ' - 'Ricardo Signes ' - 'Shlomi Fish ' x_generated_by_perl: v5.30.1 x_serialization_backend: 'YAML::Tiny version 1.73' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' HTML-Mason-1.59/Changes0000644000175000017500000026300713660015140014426 0ustar autarchautarchRevision history for HTML::Mason. ** denotes an incompatible change 1.59 2020-05-16 - Moved issues to GH issues and added a note about lack of maintenance. 1.58 2017-10-29 - Redid the release because of some dzil issues. 1.57 might be a little wonky. 1.57 2017-10-29 [ BUG FIXES ] - Fix test failures under 5.26.0+ due to "." no longer being in @INC. PR By Kent Fredric. GH #6. Fixed RT #121443. 1.56 2014-11-14 [ BUG FIXES ] - Fix a packaging issue with the last release that prevented PAUSE from indexing some modules in the tarball. 1.55 2014-11-14 [ BUG FIXES ] - Shut up warnings from recent versions of CGI.pm. Patch by Kevin Falcone. GitHub PR #1. 1.54 Jan 19, 2014 [ DISTRIBUTION ] - Remake with gnutar 1.53 Jan 18, 2014 [ DISTRIBUTION ] - Attempt to fix corrupted tar 1.52 Oct 9, 2013 [ BUG FIXES ] - Ignore 'Software caused connection abort' errors. RT #49031. Submitted by Morten Bjoernsvik. - Sort hash keys to deal with Perl 5.18+ hash randomization. RT #88708. Submitted by Zefram. - Fix 'and' precedence with explicit parens. RT #87050. Submitted by Alex Vandiver. - Escape each part of substitution, not their concatenation. github.com/jonswar/perl-HTML-Mason/pull/1. Submitted by Ricardo Signes. [ ENHANCEMENTS ] - Add use_warnings flag, similar to use_strict. github.com/jonswar/perl-HTML-Mason/pull/4. Submitted by Aevar Bjarmason. 1.51 May 8, 2013 [ DISTRIBUTION ] - Fix hardcoded version [DOCS] - Add HTML::Mason::FAQ, from old masonhq.com website 1.50 Jul 11, 2012 [ DISTRIBUTION ] - Switch to Dist::Zilla - Eliminate HTML docs from distribution, available on web - Move live Apache tests to author-only 1.49 Feb 27, 2012 [ DOCS ] - Fixed misspellings in docs. RT #74676. Reported by Salvatore Bonaccorso. 1.48 Feb 3, 2012 [ BUG FIXES ] - Calling a subcomponent from inside an anonymous component (created via $interp->make_component) caused an uninitialized value warning. Reported by Javier Amor Garcia. 1.47 Oct 21, 2011 [ BUG FIXES ] - Silenced an uninitalized value warning from ApacheHandler with newer versions of Perl. RT #61900. 1.46 Aug 1, 2011 [ DOCS ] - Mention Mason 2 in documentation 1.45 Apr 3, 2010 [ BUG FIXES ] - Silenced some new warnings that appeared when using Mason with Perl 5.12.0+. Reported by Jesse Vincent. 1.44 Jan 4, 2010 [ ENHANCEMENTS ] - Use Log::Any to log various events, such as the start and end of each request and each component call. - Add $m->log, allowing easy logging to a component-specific namespace. - Fix use of CHI when no data directory is specified. 1.43 Dec 25, 2009 [ BUG FIXES ] - If a component was located in a patch with spaces, the feature which referred to errors by their source file line number was broken. This could cause test failures if the package was downloaded into a path with spaces by CPAN. Reported by Shawn Moore. RT #53072. - HTML::Entities is no longer an optional dependency. This fixes some issues with packaged versions of Mason. Reported by Jens Rehsack. RT #48890. - $m->flush_buffer is now ignored when inside $m->scomp or $m->content. Patch by Frédéric Brière, with extra tests from Ruslan Zakirov. RT #38924. 1.42 May 7, 2009 [ BUG FIXES ] - Fix 10b-cache-chi.t to work with latest version of CHI - expire_if and ref of cache changed - Fixed a bug where attempting to load a module that failed to compile in a Mason component could mask the compilation error. RT #39803. - Fixed the print method in HTML::Mason::FakeApache. It was including the object itself in the output. Patch by Martin Petricek. RT #43035. 1.41 May 5, 2009 [ BUG FIXES ] - This is a one-fix release to get this module working with the latest version of Exception::Class (1.27). 1.40 Jul 24, 2008 [ BUG FIXES ] - Attempting to set multiple cookies when running under CGIHandler failed. Patch by Andrej Czapszys. RT #33710. - The Request->alter_superclass() method could cause a segfault (sometimes) with perl 5.10.0. Reported and patched by Jesse Vincent. 1.39 Jan 30, 2008 [ ENHANCEMENTS ] - CHI may now be used as the backend for $m->cache as an updated alternative to Cache::Cache. Among other things, this facilitates easy use of Cache::FastMmap and memcached for data caching. Cache::Cache is still the default for now, and is still listed as a prereq for Mason. 1.38 Dec 20, 2007 [ BUG FIXES ] - (Hopefully) fixed a problem where the cpan shell thought that Mason needed mod_perl1 as a prereq when it was trying to require a newish version of mod_perl2. - If you called $r->send_http_header() explicitly in a component under mod_perl 1.x, headers would end up getting sent again once the component finished executing. Reported by Brett Gardner. - Component call with content end tags could not span multiple lines. Fixing this makes it consistent with the opening tag. Patch by Alex Robinson. - Includes a possible fix for a test failure in 10-cache.t. This failure is a problem in the test code, not the Mason core code. 1.37 Sep 6, 2007 [ BUG FIXES ] - Mason could send the HTTP headers twice under mod_perl 1.x when making a request for a directory path that was handled by a dhandler. Reported by David Beaudet. - If you set the Content-Type header in a handler sub before passing control to Mason via ApacheHandler, this value was overwritten if the request was for a directory path. [ ENHANCEMENTS ] - Make t/08-ah.t and t/16-live-cgi.t more verbose about why they are skipping tests when they do so. Based on a patch from C.J. Adams-Collier. 1.36 Jun 10, 2007 [ BUG FIXES ] - If a component with content call ending tag appeared inside a subcomp or method without an opening tag, then the compiler dies with a Perl error, rather than reporting the error usefully. Reported by Rich Williams. - Under mod_perl 2, if decline_dirs was false and a directory was requested, you got a "Use of uninitialized value" warning from ApacheHandler in your logs. Reported by Ogden Nefix. - HTML::Entities is now a prereq. Not requiring it made for various weird gyrations in the tests that didn't seem to work all the time, causing various failures. Fixes RT #24827. - Request::CGIHandler->exec() now returns the return value from executing the component, just like a normal Request. Reported by Adrian Irving-Beer. [ ENHANCEMENTS ] - Added a new Compiler::ToObject parameter, named_component_subs. Turning this on makes it possible to profile components. - Added a new Request parameter, component_error_handler. This can be set to change how component compilation and runtime errors are handled. It can also be set to false to just let errors go unhandled, which could speed up apps that throw a lot of non-object exceptions. 1.35 Oct 17, 2006 [ BUG FIXES ] - Version 1.34 introduced a bug that caused corruption of the callers stack when a component call with content was used. - When Mason tried to load a package required for a feature (like Cache::Cache for $m->cache) and this failed, the error message would say something like "Can't locate Cache::Cache". However, the real error could be that Cache::Cache was present, but a module required by Cache::Cache was not. Now we report the real missing module. - Some people saw a spurious test failure in 05-request.t. RT #22099. - Added Module::Build to the build_requires prereqs. 1.34 Oct 14, 2006 [ BUG FIXES ] - List Module::Build as a build prereq in the Build.PL, so it shows up in META.yml. Reported by Colin Henein. RT #22097. - Apache::Request and mod_perl{1,2} will no longer show up as prereqs in META.yml. Requested by Jesse Vincent. - Fixed a serious memory leak bug where an object referenced in arguments to another component was never destroyed. Reported by Dominic Mitchell. - Using $m->call_next from a helper component should reset base_comp to the request_comp. Reported by Mark Elrod. - The 08-ah.t and 16-live-cgi.t test files could fail with an error like "Failed to re-load 'Mason::Build'" when Mason was being installed via the CPANPLUS shell (and maybe other cases). Reported by David Wheeler. - Fixed a bug where $m->clear_buffer inside a component called from a comp_with_content did not clear all buffers. [ ENHANCEMENTS ] - Added support for get_server_port() in FakeApache. Patch from Dieter Piercey. 1.33 May 28, 2006 [ BUG FIXES ] - If $m->flush_buffer() was called when there was a filter somewhere in the component chain, the flush did nothing. Task id #596. Reported by Shane McCarron. - Added several tests for $m->flush_buffer() and $m->clear_buffer(), which will hopefully avoid more bugs in this part of the code. - On Win32, a test failed when Mason tried to use rename to move a dir into an existing dir. Patch by Shane McCarron. Task id #594 and RT #17828. - Trying to load HTML::Mason::ApacheHandler outside of mod_perl caused an error "like Undefined subroutine &Apache::perl_hook called at /usr/local/share/perl/5.8.7/HTML/Mason/ApacheHandler.pm line 257". While it will never _run_ outside of mod_perl, it should at least load. - Fixed test in 14a-fake_apache.t that failed with CGI.pm >= 3.16. - The example code in the HTML::Mason::Resolver::Null code was just wrong. Fixed by John Siracusa. - Fixed a test failure in 06-compile.t when using bleadperl. RT #17118. 1.32 January 3, 2006 [ BUG FIXES ] - Under mod_perl 1.x with error_mode set to output, the headers were sent after the content when a compilation error occurred. Reported by Gareth Kirwan. Task id #592. - URI-escape utf8 characters the same way that CGI::escape and URI::Escape::uri_escape_utf8 do. Patch by Denis Shaposhnikov. - On startup Mason creates a file named ".__obj_create_marker" in the object directory. Under mod_perl, Mason was not chmod'ing the file when Apache was started as root. This led to permission errors in environments where the Interp is created anew every request. Task id #593. - Treat the return value of component execution as a string in ApacheHandler. This prevent warnings about comparing the empty string to a number when a component returns "". Reported by Benjamin Franz. - Setting a MasonPlugins Apache parameter caused a fatal error. Patch by David Jack Olrik. - Calling base_comp() on the Request object inside a plugin's start_request_hook method caused an infinite recursion in Mason. Reported by Jesse Vincent. 1.3101 August 23, 2005 [ BUG FIXES ] - One last fix for CGIHandler. If you provided your own out_method it was ignoring it and using its own. Reported by David Glasser. 1.31 August 20, 2005 [ BUG FIXES ] - Fix several regressions in the CGIHandler and FakeApache modules. Some changes from the stable branch were never merged into the trunk before 1.30. Reported by Jesse Vincent. Task id #589. - Under Apache2, if an ApacheHandler object was created during server startup and the associated Interp object created any files or directories, Mason would crash when attempting to chown those files/dirs to the uid/gid that Apache will use after forking. Task #586. - The compiler was adding an extra block around a component's body, which meant that variables declared in the body (in perl lines or blocks) were not seen in the cleanup section. Task id #587. - The compiler was also adding "no warnings 'uninitialized'" in this block, which could hide various errors. - Hopefully fix $VERSION in ApacheHandler so PAUSE will not be confused and think we have regressed. - Turned off some prompts during the module's installation. These were intended to help new users configure Apache to run Mason components, but they're probably a bit confusing. Will return in a future release as a separate script that can be run from the command line. 1.30 August 11, 2005 [ INCOMPATIBLE CHANGES ] - ** Under mod_perl2, MasonArgsMethod will default to "CGI", since libapreq2 is still in development. If you have successfully installed libapreq2, just set MasonArgsMethod to "mod_perl" to use it. [ ENHANCEMENTS ] - Some doc tweaks to clarify that Mason should work out of the box with both mod_perl 1 and 2. - Added "use warnings" to all modules and made sure all tests ran warnings-free. [ BUG FIXES ] - Silence a warning when HTML::Mason::ApacheHandler was loaded outside of mod_perl. - Support renamed Apache2::Status module. 1.29_02 June 22, 2005 [ ENHANCEMENTS ] - ** Support for mod_perl-2.00 (mod_perl-1.99 is no longer supported because of API changes in 2.0RC5). - Mason recovers more gracefully from an empty or corrupted object file. Task id #579. [ BUG FIXES ] - Fixed bug with content type being reset when decline_dirs=0. Submitted by Brian Phillips. Task id #584. - Put "Mason" prefix back in Params.pod. Task id #575. - Fixed fetch_comp(undef) to not return an empty hash. Task id #578. - static_source_touch_file did not take effect until after one request for a top-level component. Reported by Lai Zit Seng. Task id #576. 1.29_01 January 25, 2005 [ INCOMPATIBLE CHANGES ] - ** Mason now requires Perl 5.6.0 or later. However, because 5.6.0 has so many problems, it cannot be officially supported; we strongly recommend upgrading to at least 5.6.1. - ** Mason now requires version 1.24 of mod_perl in the ApacheHandler module. - ** The behaviors of $m->flush_buffer and $m->clear_buffer have been simplified. $m->flush_buffer only acts on the top-level output buffer; $m->clear_buffer clears all output buffers. Task id #554. - ** max_code_cache_size is now kept in terms of number of components, not bytes, and its default value is 'unlimited'. - ** Components with a <%filter> and a cache_self are no longer cached in their filtered state. Performance-related code simplifications made this behavior difficult to maintain. Long term this would be easier to implement with a cache_self component <%flag>. - ** All compiler properties are now read-only. If you need to change compiler properties on a per-request basis, you'll need to create multiple compiler and interpreter objects. - ** comp_exists may try to load the designated component, and may throw an error if it contains a syntax error. - ** The current_time method, deprecated in 1.1x, has been removed. - ** The HTML::Mason::Buffer class has been eliminated for performance reasons. You can use separate components, methods, or subcomponents and scomp to achieve the same effects as buffer pushes and pops. [ ENHANCEMENTS ] - Significantly improved performance in component execution, especially in static_source mode. - Added static_source_touch_file, making it much easier to update a server running in static_source mode. - Added a plugin architecture. Plugin classes can perform actions at key points, e.g. before and after each request and each component call. See HTML::Mason::Plugin for documentation. Task id #24. Initial implementation by Doug Treder. - Added the ability to change component root(s) on the fly if the dynamic_comp_root parameter is turned on. Task id #561. Suggested by Alex Robinson. - Added enable_autoflush parameter. When turned off, Mason can compile components to a more efficient form. - Changed the tag to allow the starting component name to be included. e.g. <&| /foo &> ... . Task id #556. Suggested by Alex Robinson, John Williams, and others. - Moved the notion of component roots (single and multiple) from the Resolver to the Interpreter. This improved the performance of multiple component roots in conjunction with static source mode. Any resolver, file-based or otherwise, can benefit from component root settings or choose to ignore them. - Added the compiler object_id to the object file path, so that multiple versions of Mason do not collide in the same object directory. Task id #569. - Added .obj (or a configurable extension) to object filenames. Task id #152. Suggested by John Tobey. - Added $m->clear_and_abort, syntactic sugar for the common idiom of calling clear_buffer() and then abort(). Task id #505. - Added an official comment syntax, <% # ... %>, and documented the various comment markers in the developer's manual. Task id #566. - Added buffer_preallocate_size parameter, which allows you to potentially reduce buffer reallocations. - Augmented the 'could not find component' error message with the current component root(s). Task id #562. [ BUG FIXES ] - Mason now throws an error if the path specified in a component's 'inherit' flag cannot be found. Task id #480. - Fixed comp_exists to work with any path accepted by comp or fetch_comp, and fixed fetch_comp to stop throwing errors for certain bad paths. Task id #572. - Fixed $m->decline to work from /dhandler. Task id #573. Submitted by Carl Raiha. - Using 'next' or 'last' without a loop can no longer corrupt the component stack. Task id #539. 1.28 November 6, 2004 This version is entirely identical to 1.27 except for a fix to make CPAN/PAUSE properly index the version number in HTML::Mason::ApacheHandler. If you already installed 1.27 you do not need to install this version unless you want to fix the "out of date modules" report from the CPAN or CPANPLUS shells. 1.27 October 28, 2004 [ ENHANCEMENTS ] - Full support for Apache2/mod_perl2. [ BUG FIXES ] - The request object was not available as $m in the preamble if in_package was set. Reported by David Wheeler and David Baird. Task id #538. - Component with subcomponents or methods were not getting freed when they were purged from the code cache. Task id #549. - Component calls (<& &>) starting with a newline were compiled incorrectly. Reported by Rick Delaney. Task id #564. - If both a parent request and subrequest had autoflush set, output from the subrequest wasn't actually flushed. Reported by Tony Clayton. Task id #550. - The documentation in HTML::Mason::Tests for the path and call_path parameters was wrong. Reported by Michael Gray. Task id #528. - Line numbers in errors were incorrectly reported if the error happened in code after an <%args>, <%attr>, or <%flags> block. Reported by Tony Clayton. Task id #552. - The Apache handler now only sends headers once if make_request() aborts, such as when a redirect is executed in a MasonX::Interp::WithCallbacks callback. 1.26 April 5, 2004 [ BUG FIXES ] - The fix to make CGIHandler support flush_buffer and autoflush caused it to not rethrow any exceptions created during the request. If error_mode was set to 'fatal', then an error would simply cause no output to be generated. Task id #531. - A comment in the last line of a component call with content caused a syntax error in the compiled component. Reported by Todd Goldenbaum. Task id #530. - The various request handling methods in CGIHandler once again return the value of calling the Interp object's exec() method. - CGIHandler now explicitly handles redirect statuses when an abort exception is thrown from the Interp object's exec() method. This fixes some problems when this module was used with David Wheeler's MasonX::Interp::WithCallbacks module. - Using a <%shared> block when "in_package" was set to something other than HTML::Mason::Commands led to an error like "Can't call method "call_dynamic" on an undefined value". Reported by David Wheeler. Task id #535. 1.25 December 12, 2003 [ BUG FIXES ] - CGIHandler did not support $m->flush_buffer or autoflush. Reported by Shane McCarron. - Every line in the error stacktrace had a 'g' appended to it in HTML error mode. - The HTML error display of the stacktrace was not filtering out some packages that it should have, so there were extra lines that made it harder to find the real error. - Several FakeApache methods were broken: path_info, uri, and the_request. Reported by Matthias F. Brandstetter. [ ENHANCEMENTS ] - The CGIHandler request object now supports the autoflush parameter. 1.24 November 12, 2003 [ BUG FIXES ] - Two tests in 04-misc.t, #9 and #10, failed if Params::Validate 0.66+ was installed. This happened because an error message given by Params::Validate changed slightly, and was not a problem in the Mason core code. - The Component object method attr_if_exists returned 0 when the attribute didn't exist, instead of undef as is documented. Reported by Chris Reinhardt. - The HTML::Mason::Resolver::File glob_path method, which is used for the preloads feature, now uses File::Glob::bsd_glob when run with Perl 5.6.0+. This function properly handles spaces in filenames, which are legal on most systems, and common on Win32. Implemented by Autrijus Tang. - The Admin guide erroneously said that the default component root when running Mason outside a web environment was "/". It is the current working directory. Reported by Patrick Kane. 1.23 September 8, 2003 [ ENHANCEMENTS ] - Lots of enhancements to the Apache.pm emulation when using the CGIHandler module. Implemented by David Wheeler. - The fact that autohandlers or dhandlers can be turned off by setting autohandler_name or dhandler_name to "" has now been documented, and we explicitly check for this in the code. Task id #499. - The ApacheHandler module now handles certain exceptions (TopLevelNotFound, Abort, Decline) thrown from the Interp class's make_request method by returning the desired error code. With the default Mason Interp & Request classes, this will never happen. However, subclasses may want to throw exceptions when constructing a request. Implemented by David Wheeler. [ BUG FIXES ] - If any code type parameters were set in the httpd.conf file, Mason died trying to read them. This bug was introduced in version 1.20. Task id #496. Reported by David Wheeler. - $m->caller, $m->callers and $m->caller_args now return undef or an empty list instead of crashing when the specified stack level does not exist. Task id #495. Reported by Bernhard Schmalhofer. - The busy_lock option to $m->cache->get did not accept did not accept string values for durations, like "4m". Task id #484. Reported by Igor Muratov. - When generating the HTML error message page, we now only use basic HTML escaping. This fixes two problems. One is that if HTML::Entities is not installed, using the "|h" escape flag in the error display component causes an endless loop. The other is that the "|h" flag can mangle non-Latin-1 characters. Task ids #497 and #494. Reported by Harmen and Oleg Bartunov respectively. - If a component generated output, then called another component via $m->scomp, and that other component attempted to clear the buffer and then abort, any output generated before the call to $m->scomp was still sent to the client. This broke calling $m->redirect inside an $m->scomp call. Task id #498. Reported by Kim Alexander Hansen. 1.22 July 14, 2003 [ ENHANCEMENTS ] - Added $m->has_content to check for content without evaluating it. - Comments are now allowed on separate lines inside <%attr> and <%flags> blocks. Task id #475. - $m->subexec and $m->make_subrequest now accept relative paths which are interpreted relative to the current component directory, like $m->comp. - Documented potential problems if call to $m->redirect is trapped in an eval block, and then output is generated before the exception is rethrown. Task id #477. [ BUG FIXES ] - If a component with a filter section called abort, the filter was run twice. Task id #473. - If an exception was thrown when creating a request, memory was leaked. This can happen when the top-level component cannot be found (e.g. 404) or if there is an error in compiling the top-level component. Task id #478. Reported by Doug Treder. - Removed the use of alarm() and SIG{ALRM} to trap rare infinite loops inside the compilation of components. It interfered with Mason environments that use alarm() for their own purposes, and the associated test would crash in certain Perl environments. If you find that Mason sometimes enters an infinite loop, see the "Hanging Processes: Detection and Diagnostics" section of the mod_perl guide for hints on diagnosing the problem. Task id #472. - Mason allowed a component to define two subcomponents or methods with the same name. Task id #476. Reported by John Michael Mars. 1.21 June 4, 2003 [ INCOMPATIBLE CHANGES ] - ** The semantics of @_ for components now match Perl subroutines: @_ contains aliases to the caller's arguments, instead of copies. For example, if a component updates $_[0], the corresponding argument is updated (or an error occurs if it is not updateable). The only users that will notice this are those that update elements of @_ in components and do not expect those changes to affect the caller. If you have any doubts, grep your component tree for '\$_\[' and look for assignment statements. [ ENHANCEMENTS ] - Cache the result of taint_is_on() for performance. - Mason was copying arguments several times for a request, and several more times for each component call. The unnecessary copies have been eliminated. As part of eliminating these copies, a new compiler parameter has been added, "define_args_hash". The default setting, "auto", should work with all existing Mason components. See the HTML::Mason::Compiler::ToObject docs for details. Task id #464. Suggested by Doug Treder. - Added more details about subclassing the compiler to the Subclassing documentation. - There is now a compiler parameter called "use_source_line_numbers", which can be used to turn off line numbering based on the source file. This can be useful when single stepping a component through the debugger. Task id #461. [ BUG FIXES ] - Fixed a serious error in which a Compiler that was used on a component containing certain kinds of syntax errors would claim that any future components also contained syntax errors. Task id #467. - Now assigning runtime properties (such as interp) to method component objects as well as subcomponent objects. Task id #462. - Fixed the HTML error display. Errors were not being properly HTML-escaped. Task id #468. Reported by Jeremy Blain. - A bad interaction between the XS version of Params::Validate, Perl 5.00503 and taint mode has been "fixed" by requiring Params::Validate 0.59, where the problem is fixed. Task id #470. - The test suite now runs the taint mode tests with earlier versions of Perl. Task id #471. - The ApacheHandler module would go into an infinite memory-eating loop when run in taint mode with Perl 5.6.1. Task id #469. Reported by William McKee. 1.20 May 1, 2003 (May Day) [ ENHANCEMENTS ] - Added an $m->notes() method, which is similar to $r->pnotes() but may be used outside a mod_perl environment. Task id #449. - Mason will now only convert non-reference exceptions to HTML::Mason::Exception objects, so it should cooperate better with modules like Error.pm. Task id #446. - Added more documentation on Mason's error handling and exception system. Task id #446. - If Mason was configured via the Apache httpd.conf file, it could in many cases be quite a bit slower than configuration via a custom handler subroutine. Now configuration via the httpd.conf is much faster, and is only about 5% slower than a custom handler subroutine. Reported by Jeremy Blain. - Mason's test harness now gives verbose output when the TEST_VERBOSE environment variable is true. This eliminates the need for setting MASON_VERBOSE. - ** It is now an error to have a subcomponent and method with the same name in a single component. [ BUG FIXES ] - Mason would die if asked to compile a component that evaluates to a false value. Task id #444. Reported by David Wheeler. - Mason now gives a better error message if you try to call a component's methods or subcomponents from its <%shared> block. Task id #448. Reported by Randy Harmon. - If in_package was set, Mason would die if output was generated after a subrequest. Task id #453. Reported by David R. Baird. - If Perl's print() was called after a subrequest, Mason would die when run with any Perl before 5.8.0. Task id #458. - If a component called $m->cache_self, and then $m->decline, no output would be generated. Task id #454. Patch by Vadim Ustiansky. 1.19 March 3, 2003 [ BUG FIXES ] - Fixed a very nasty bug that could cause subcomponents or methods from one component to show up in another components. Task id #443 in todo list. - If the closing tag of a <%flags>, <%attr>, or <%args> block contained upper case characters, the component would not be parsed properly. Reported by Chris Snyder. Task id #440 in todo list. - Providing a Resolver object directly to the ApacheHandler constructor caused a fatal error. Reported by Kwindla Kramer. Task id #441 in todo list. 1.18 January 24, 2003 [ BUG FIXES ] - Require Exception::Class 1.09. Version 1.08 has a bug that causes problems with Mason when used with any Perl earlier than 5.8.0. - Fix a bug in the lexer code that caused Mason to not work with Perl 5.00503 at all. 1.17 January 17, 2003 [ ENHANCEMENTS ] - Added "REQUEST:" as a component specifier for method comp calls, similar to "SELF:" and "PARENT:". "REQUEST:" is short-hand for $m->request_comp. Suggested by Manuel Capinha, among others. - Added $m->call_self. This was present in Mason pre-1.10, and has been added back per Jon Swartz's request. - Added $comp->attributes, similar to $comp->methods. This just returns attributes for a given component object. It doesn't return attributes inherited from a parent. Suggested by Matti Makitalo. [ BUG FIXES ] - ** When $m->cache_self was used for a component with a filter block, the output would be cached _before_ filtering, and filtered every time it was retrieved from the cache. This has been fixed, and the documentation now specifies that the filtered output is cached. - Fixed failure of 12-taint.t #7 on Win32 boxes. Reported by Randy Kobes. - Without HTML::Entities installed, 13-errors.t #7 failed. Reported by Sam Kington. - $m->file did not handle relative paths properly when called from a subcomponent or method. Reported by Chris Hutchinson. - If $m->abort was called in the shared block of a component that had a filter, then a fatal error occured. Reported by Chris Pudney. - Mason was not cooperating with Apache::Filter, and attempts to filter Mason's output did not work. Fixing this also requires Apache::Filter 1.021, if you are using Apache::Request to handling incoming arguments. Reported by by Manuel Capinha. - Mason assumed that if Scalar::Util loaded without errors, it had a weaken() subroutine. However, Scalar::Util provides a pure Perl implementation that does not include this subroutine. Now we check for this subroutine explicitly. Reported by Autrijus Tang. - Some code constructs, such as qw() lists, would end up being turned into invalid code during component compilation. Reported by Robert Landrum. - Subclassing a subclass of HTML::Mason::Request broke when the class between HTML::Mason::Request and your own class called alter_superclass. - Under mod_perl 2.0, when ApacheHandler could't resolve a filename to a component, it would die instead of returning a not found status. [ INCOMPATIBLE CHANGES ] - ** Removed the long deprecated and undocumented $comp->parent_comp method. Use $comp->owner instead. 1.16 December 13, 2002 [ ENHANCEMENTS ] - Documented behavior of $m->flush_buffer when a filter is present. - Turned off "nowrap" for error message on HTML error page. No more horizontal scrolling! - Substantially rewrote portions of the Admin Guide, in order to improve and clarify the portions related to configuring and customizing Mason under mod_perl. - Added back "raw error" on HTML error page. - Replaced FilesMatch with LocationMatch in docs and FAQ, because using FilesMatch means you can't use dhandlers. - Reduced memory usage when compiling large components. Memory usage for smaller components hasn't changed much, but they weren't really a problem in the first place. - Added a cgi_request method to the CGIHandler::Request object, which parallels the apache_req method offered by the ApacheHandler::Request object. [ BUG FIXES ] - When using the code cache within an Interp, a circular reference was created which prevented the Interp object from ever being destroyed. With Perl 5.6.0+, this will be automatically prevented by using weak references as needed. With Perl 5.00503, you will need to call the new Interp->flush_code_cache method in order to break the circular reference. This bug could cause memory leaks with code that created new Interp objects over time, though most uses of Mason do not do this. Reported by Kate Porter. - Fixed bad parsing of <% $foo || 50 %>. Mason was interpreting this as an escape flag. Escape flags now much match /^[[:alpha:]_]\w+/ and Mason specifically looks for || in a substitution as well. Reported by Kwindla Kramer. - If a dhandler one subdirectory down (like /foo/dhandler) called $m->decline, Mason threw a bogus exception. Fixed by Harmen. - Running the test suite caused an error in the shell on Win32 with newer versions of MakeMaker. Reported by Murat Unalan. (We _think_ this is fixed but we'd like confirmation from a Win32 user). - It was not possible to set the data_cache_defaults parameter from the httpd.conf file. Now it is. - Mason was using Apache::Request->new instead of Apache::Request->instance. This meant that if you had a handler that ran earlier (like a TransHandler) and that handler created an Apache::Request object, then the one Mason created would be missing any POST arguments. Reported by Ray Zimmerman. - Several different places in the docs said that Cache::Cache accepts a username option, but there is no such thing. - alter_superclass didn't work with CGIHandler because CGIHandler didn't define a $VERSION variable. Reported by Nadine and Harry Laxen. - Made CGIHandler merge together POST and query string arguments in order to be consistent with ApacheHandler. Reported by Nadine and Harry Laxen. - The CGIHandler module was overriding any out_method provided by the user. Reported by Nadine and Harry Laxen. 1.15 October 14, 2002 [ BUG FIXES ] - Fixed a number of problems with filters: -- They didn't see changes made to %ARGS (they were seeing a copy). -- They couldn't see any variables declared in <%args> blocks. -- The presence of a filter caused a call to $m->flush_buffer, breaking redirects. - Added a number of tests for filters (*cough*). - Fixed broken links and other bugs in the POD and HTML versions of the docs. - Fixed test failures when running as root. These failures were not reflective of bugs in Mason, simply problems in the tests or test setup. Now we skip the tests for end user installs (we still run them during development, never fear). - HTML::Mason::Request contained code that caused an error when using the CPAN shell's "r" command. 1.14 October 7, 2002 [ BACKWARDS COMPATIBILITY ] - Added compatibility layer for 1.0x cache API. It is now possible to use $m->cache and $m->cache_self in the old way by setting the data_cache_api parameter to '1.0'. - Added back $comp->create_time, which was renamed as $comp->load_time in 1.09_02, as a deprecated method. - Added back $interp->time and $m->current_time, which were removed in 1.09_01, as deprecated methods. [ ENHANCEMENTS ] - Implemented the long requested user-defined escapes feature. It is now possible to define your own escape flags, as well as overriding Mason's own 'h' and 'u' flags. - Implemented expire_if and busy_lock options in new $m->cache->get API. These retain the essence of the 1.0x options although both work a little differently. - Added new module to implement caching extensions, HTML::Mason::Cache::BaseCache, with accompanying documentation. - Enhanced Params.pod with TOC and full descriptions of all parameters. Standardized rest of documentation to link to Params.pod when referring to a parameter. - When a component path is not found, but that path matches a file on disk, we now print an extra warning, because this indicates that the user does not understand the distinction between component paths and filesystem paths. - The Request object's redirect() method now accepts an optional additional argument, allowing users to use a status code other than 302 for the redirect. - Mason should now work on a box with a fresh mod_perl 2/Apache 2 install. Previously, Mason unconditionally tried to load Apache::Status, which comes with mod_perl 1.x, but not (yet?) with mod_perl 2. [ BUG FIXES ] - Installation was failing when Exception::Class wasn't installed. - Calling <%def> subcomponents no longer changes base_comp, which is important in autohandlers. (reported by Ian Robertson) - The documentation incorrectly indicated that you could create an ApacheHandler object during server startup without providing a component root. This will also shown incorrectly in the sample handler.pl in the eg/ directory. - Reduced Mason's memory usage when compiling and serving components. This is particularly noticeable with very large components (1-2MB or greater). Work on this will continue for future versions. (reported by Todd Holbrook) - %ARGS and <%shared> variables could not be accessed from <%filter>. (reported by Adam Roth) - Switch.pm did not work in file-based components. (reported by Gert Thiel) - use_strict could not be turned off. (reported by Viacheslav Voytovich) - $m->clear_buffer (and $m->redirect) did not work inside a component call with content. (reported by Manuel Capinha) - Some tests were failing on Windows, because they assumed Unix style filesystem paths. This was a problem with the tests, not the core code, but still worth fixing. (reported by Adam Rinehart). - $m->caller() was inadvertently left out of the documentation - fixed. - Fixed a small documentation error about what kinds of things are valid keys in <%flags> and <%attr> blocks. - Configuring multiple component roots via the httpd.conf file failed silently (as opposed to releases 1.10 - 1.12, where this failed with an error). - Unreadable component source files caused the confusing error message "source callback returned no source". This will now throw a much more helpful exception. - Errors occurring in subrequests would cause error output to be mixed with regular output when the error_mode was "output" (the default with ApacheHandler and CGIHandler). Errors in subrequests should now look the same as errors in the top request. 1.13 August 26, 2002 (Taiwan time) [ ENHANCEMENTS ] - Replace the regex "[A-Za-z0-9]" with "\w", which should cooperate better with Unicode. - Added a section called "Avoiding Concurrent Recomputations" to the Developer's Manual. This describes how to achieve the same effect as was provided by the "busy locks" feature in 1.0x. [ BUG FIXES ] - When running under mod_perl, a warning was issued from HTML::Mason::Request::ApacheHandler's exec() method. (reported by Marius Feraru) - The request wrapper code did not work with anonymous component. (reported by Bob McElrath) - Mason 1.10-1.12 did not cooperate with Apache::Filter, or any other Apache subclass that overrode the print() method. (reported by Mark Moseley) - If an object blessed into Apache::Request was provided to ApacheHandler's handle_request method, and you were using the args_method parameter was set to "mod_perl" (the default), then ApacheHandler would die. This was a bug introduced in 1.12 as a result of fixing the memory leaks in 1.11. (reported by Autrijus Tang) - Configuring multiple component roots via the httpd.conf file failed. (reported and patched by Alexei V. Barantsev) - $interp->exec and $m->exec were not respecting wantarray. (reported by David Bushong) - Suppress a "subroutine redefined" warning from HTML::Mason::Request::Apachehandler's exec() method. (reported by Marius Feraru) - Combining cache_self, <%filter> blocks, and $m->scomp did not work. (reported by Calle Dybedahl) - Tests 4 & 5 for 06-compiler.t would fail if HTML::Entities was not installed. Now they will be skipped if necessary. - Tests 75 & 99 for 08-ah.t depended on hash key ordering and would fail with Perl 5.8.0. (submitted by Michael Gray) - Fixed a number of cases where the lexer/compiler's behavior differed from Mason 1.05 in unintended ways. -- Dashes were not being allowed in subcomponent and method names, even though this is documented as being allowed. (reported by Ken Miller) -- Space between a method or subcomponent name and the '>' at the end of the tag was not being allowed. It should be noted that this is not documented as being allowed in the docs, and so may change in the future. But for now, we'd rather be compatible with 1.05. (reported by Chris Hutchinson) -- Comments were not being allowed after flag and attribute assignments. Again, this is not documented as being allowed. (reported by Chris Hutchinson) - CPAN thought that version 1.68 of HTML::Mason::ApacheHandler (part of the 1.05 release), was newer than version 1.242 (part of the 1.1201 release). This is what we get for using CVS to set verson numbers. This version number is now set by hand in order to make sure that this does not happen in the future. 1.1201 July 24, 2002 [ ENHANCEMENTS ] - Added details to the UPGRADE document on what has changed with the caching system. - Added some documentation on how to arbitrarily expire items in the cache with the new caching system. This is in HTML::Mason::Devel. [ BUG FIXES ] - Fixed a compilation error in HTML::Mason::Tools that was occurring with Perl 5.00503. - Made sure that <%method> and <%def> tags are treated case-insensitively. 1.12 July 23, 2002 [ ENHANCEMENTS ] - Various optimizations have been added to this release in order to address the fact that Mason 1.11 is quite a bit slower than 1.05. One major factor was optimizing Params::Validate and Class::Container, so for that reason this version of Mason requires Params::Validate 0.24 and Class::Container 0.07. With these modules installed, this release shows improvements of up to 50-60% in benchmarks that stress Mason's weaknesses, with other benchmarks showing up to a 100% improvement. - Made subclassing CGIHandler more useful by breaking out its arg processing into a request_args method, just like ApacheHandler. - Added alter_superclass method to Request class, for use by Request subclasses. See the HTML::Mason::Subclassing document for details. [ BUG FIXES ] - Fix HTML generated for error messages so that tags balance out. Unbalanced table tags caused this page to not display properly with Netscape 4.x. - Fix nasty memory leaks in ApacheHandler. 1.11 July 3, 2002 [ BUG FIXES ] - The 08-ah.t tests failed with a runtime error if run by root. This was not a Mason bug, but a bug in the test code itself. - ApacheHandler did not work Perl 5.005. - Even if ApacheHandler was given an Apache::Request object to handle_request() or prepare_request(), it was still calling Apache::Request->new. (reported by Ray Zimmerman) - Fixed incorrect $m->make_subrequest documentation. (reported by Ray Zimmerman) - Added some incompatibilities in 1.10 to the UPGRADE document that were left out in previous versions. - HTML error output could be sent as plain text or some other content type depending on your Apache config and the file extension of the requested component. Now we explicitly set $r->content_type before sending HTML error output. - Fix failures of Resolver::File::glob_path() with Win32. (reported by Adam Reinhart) 1.10 June 25, 2002 This is a big release and there are a number of backwards incompatibilities with version 1.05 and earlier. Please make sure to read the UPGRADE document, which covers these in more detail. [ ENHANCEMENTS ] - Mason can always detect when an object file was compiled with an incompatible compiler/lexer, even if the object file contains syntax errors. - Method and subcomponent blocks with no name (<%method>) were caught as an error, but the error message was very confusing. This has been fixed. - Added HTML::Mason::Subclassing, documentation on subclassing Mason objects. - Added documentation on the interaction between <%once> sections and preloading components. - Mason automatically calls $m->clear_buffer when $m->decline is called. [ BUG FIXES ] - Fixed a bug in the lexer that made it think it had found a Perl-line where none existed. - Fixed a bug related to handling of parameters in httpd.conf files. This was only noticeable if you attempted to provide a subclass of one of Mason's classes (like your own Request class) that took its own parameters. Mason was not recognizing those additional parameters as valid. - Improved line number reporting from earlier releases. Line numbers are now reported properly for errors in any type of block. 1.09_02 June 4, 2002 [ INCOMPATIBLE CHANGES ] - ** The Component class's create_time method has been renamed as load_time. - ** Relative component paths in the $interp->exec() method are no longer resolved. All component paths must be absolute. Relative path resolution was added in 1.09_01 so this change is unlikely to affect most users. - ** Removed option to expire a component from the Apache::Status page. This option made little sense since components are cached per-process, and there's no guarantee that any particular process has cached a given component. Again, this is a feature added in 1.09_01 so this change should not cause most people any problems. - ** Renamed CGIHandler's handle_cgi method to handle_comp. - ** Removed the dev_dirs feature from CGIHandler. - ** The default component root when not using ApacheHandler or CGIHandler is now the current working directory at the time the HTML::Mason::Resolver::File class is loaded. [ ENHANCEMENTS ] - All the modules included with Mason are now documented. - Various pieces of existing documentation have been tweaked and modified. - Added handle_cgi_object method to CGIHandler. - Mason works with the CVS version of mod_perl 2.0 when mod_perl 2.0's backwards compatibility layer is used. AFAICT, the CVS version is close enough to what will be released as 2.0 that few, if any, changes should be required once 2.0 is out. - When running Mason with the ApacheHandler or CGIHandler modules, the Mason request object ($m) now has a "redirect" method, which can be used to send an HTTP redirect to the client. [ BUG FIXES ] - $m->flush_buffer was sending out '' to the buffer, even if no output existed. This caused ApacheHandler to send headers, which broke redirects, for example. - Fix broken Apache::Status page (reported by Thomas A. Lowery). - The lexing code now handles some weird edge case errors in a better way. One of these involved a component starting with a invalid block name like <%foo>. - A component that compiles into Perl code that causes syntax errors seems to trigger a Perl bug when Mason attempts to eval it. The symptom is that Mason simply hangs when it tries to eval the component's object file. This bug is present in Perls before 5.7.3, but appears to be fixed in the development branch. Mason will use alarm, if supported by the system, to work around this. - Output from subrequests was appearing _before_ other component output. The new default is that this output appears "inline" in the calling component, which we think is most DWIM-ish. Alternate behavior can be achieved by explicitly setting the subrequest's out_method parameter. - The $r object provided by CGIHandler.pm was not passing header values to CGI.pm in a way that CGI.pm liked. Now we add a '-' to the front of the header name if necessary, and all headers are canonized to lower case in order to avoid having duplicates. - Mason only requires Apache::Request if you have mod_perl installed already. 1.09_01 April 4, 2002 [ INCOMPATIBLE CHANGES ] - ** Errors now report line numbers from the component source file. - ** The Parser class has been removed entirely. Its functionality has been split between the Lexer and Compiler objects. - ** The debug file feature has been removed. - ** The previewer has been removed. - ** The system log feature has been removed. - ** The Interp use_reload_files parameter has been removed. The new static_source parameter provides a useful, and conceptually simpler, replacement. - ** Mason's built in caching now uses Cache::Cache to do all the heavy lifting. This means that parameters for both the $m->cache and $m->cache_self methods have changed. - ** The ApacheHandler's top_level_predicate parameter has been removed. - ** The mc_* commands have been removed entirely. - ** The Interp's taint_check parameter has been removed. Mason now simply determines whether or not it is running in taint mode and acts appropriately without user intervention. - ** Mason now uses Apache::Request as its default argument processing module. You can explicitly use CGI.pm if you prefer. - ** The ApacheHandler module no longers accepts parameters when imported. Instead, you specify this parameter via the ApacheHandler constructor. - ** The ApacheHandler module now requires a minimum of mod_perl 1.22. - ** The Component's run_count() and first_time() methods have been removed. - ** The HTML::Mason::Config module is no longer needed, and is no longer generated during the installation process. - ** The Interp's autohandler_name and dhandler_name params no longer take undef as a valid value. - ** The Interp's use_autohandlers, use_dhandlers, and allow_recursive_autohandlers parameters have all been removed. - ** The $m->top_args and $m->top_comp methods have been renamed to $m->request_args and $m->request_comp. The old methods are deprecated but will work until the 1.20 release. - ** Passing an Interp object to the ApacheHandler constructor (as in a handler.pl file) will no longer work unless you set the Interp's resolver_class parameter to 'HTML::Mason::Resolver::File::ApacheHandler'. However, you can now pass Interp constructor params directly to the ApacheHandler constructor, which will create the interp object internally. - ** The MasonMultipleConfig httpd.conf parameter has been removed. Mason can now figure this out by itself. - ** The HTML::Mason::Interp time() method has gone away. - ** The base_comp is now changed for each component call, unless that component call uses a component object for its first argument, or the call starts with SELF: or PARENT:. - ** The "perl_" prefix for Mason tags is no longer supported. - ** The backslash character now eliminates a newline at the end of any line, not just before %-lines and section tags. [ ENHANCEMENTS AND NEW FEATURES ] - It is now possible to pass chunks of component content as part of a component call. - Mason now supports subrequests via the new $m->subexec and $m->make_subrequest methods. - Mason no longer requires you to specify a component root or data directory. The component root now defaults to your document root in a web context, or your filesystem root in a standalone context. The data directory will be a subdirectory of your server root under mod_perl, and Mason can work without any data directory at all in other contexts. - The Resolver class API has been redesigned and is documented for the first time. - The installation process will offer to help you setup Mason for use with mod_perl if it can find your Apache configuration file and it cannot find an existing Mason configuration. - The HTML::Mason::Request->instance method is now the officially supported way of getting at the current request object outside of a Mason component (suggested by John Siracusa). - The HTML::Mason::Interp->comp_exists method now checks for a component's existence without loading the component (suggested by Randal Schwartz). - Mason now includes a module called HTML::Mason::CGIHandler, which greatly simplifies the use of Mason via CGI scripts. - Mason now uses File::Spec for all filesystem operations. - All the .pod files have been merged into their corresponding .pm files, where appropriate. - Added the Component attr_if_exists method (suggested by Joe Frisbie). - We now use the HTML::Entities module's encode function for the 'h' substitution escape flag. This module escapes high-ascii characters properly. - Calling a method via $m->comp('comp:method') works just like $comp->call_method('method'). - When an object contains other objects then the containing object's constructor accepts parameters intended for the contained objects. For example, the Interp object contains a Resolver object and Request objects. The Interp's new method will accept constructor parameter for both the Resolver and Request objects. - The ApacheHandler args_method is now a per-object parameter. - Mason is now much smarter about recompiling components. In general, it can detect if compiler options for a compiled component are different from the current options, and will recompile the component if necessary. The exception to this is that with compiler parameters which take callbacks (such as preprocess), Mason can only tell if such a parameter is present, not whether the actual callback has changed. - The ApacheHandler object will chown any files created during server startup as needed. [ BUG FIXES ] - The <%args> section can now contain comments which contain the string '=>' (reported by Chris Hutchinson). - Fixed the longstanding bug that using print() or $r->print() causes output/headers to appear out of order. You can now safely use these, though we still recommend that you use Mason to send output. - Filtered output now does appear when $m->abort() used. However, an abort inside a component called via $m->scomp() still cause the output generated by that component to disappear. [ INTERNALS ] - Output buffering and filtering is handled by the new HTML::Mason::Buffer class. - All fatal errors thrown during component execution are exception objects in the HTML::Mason::Exception class hierarchy. - The CGI GET/POST argument processing code has been simplified (submitted by Ilmari Karonen). - ApacheHandler now uses a special Resolver subclass to translate URIs to component paths. - Parameters passed to "set" accessors are now validated in the same way as constructor parameters. - The component requested and the arguments it was passed are now properties of the Request object. 1.05 April 30, 2002 - Fixed improper handling of parameters for non-GET/POST request. (submitted by Radu Greab) - Fixed Interp to accept a resolver object param. (reported by Bojan Jovanovic) - Fixed infinite loop when calling $m->decline with // in dhandler arg. (reported by Baldur Kristinsson) 1.04 October 30, 2001 - Fixed locale parser_version 0,8 problem. (submitted by Louis-David Mitterrand) - Fixed inability to use '/' for comp_root. (reported by Doug Hunt) - Fixed HTML::Mason::Parser::make_dirs dying when reload_file not defined. (reported by Ivan E. Panchenko) - Made error_process regexps more specific. (suggested by Vadim Belman) - Fixed $m->count. (reported by David Wheeler) - Fixed writing of object files in taint mode. (submitted by Barrie Slaymaker) - Made it possible to run Makefile.PL without prompts. 1.03 May 17, 2001 - Made raw error message accessible from the new error display via an unobtrusive link. - Fixed Apache tests when started by a non-root user. (reported by Barrie Slaymaker) - Added short-circuits for Apache tests on Win32 and on systems with Apache configurations that cannot be properly parsed. (reported by Jindra Vavruska) 1.02 April 17, 2001 - Completely redesigned error display. The new display includes a contextual source listing and readable stacktrace. You can access the old error behavior with the raw_html and raw_fatal error modes. (implemented by Matthew Lewinski) - Fixed $m->file to close its filehandle between uses. (reported by Matthew Lewinski) - Fixed bad interaction with Mason 1.01 and CPAN module, by adding version number to ApacheHandler.pm. - Fixed $m->top_comp to work as documented, and made documentation a bit more explicit. (reported by Gordon Henriksen) - Fixed specification of a component root as "foo => /foo" in httpd.conf. (reported by Chuck O'Donnell) - Added MasonDeclineDirs, accidentally omitted in 1.01. (reported by David Wheeler) - Changed sql examples in Devel.pod to use bind variables. (suggested by Austin S. Lin) 1.015 April 3, 2001 - Fixed incompatibility with mod_perl < 1.21_01, introduced in 1.01. - Added 'use Apache.pm' to ApacheHandler.pm, necessary for some mod_perl installations. 1.01 March 27, 2001 - Implemented configuration of Mason from httpd.conf via PerlSetVar directives. This removes the need for a handler.pl file in many cases. - Revamped ApacheHandler tests to use a real Apache web server and mod_perl (assuming this is installed). This allows for much better testing of Mason. However, the test suite takes a bit longer to run as starting and stopping the server can take a second or two each time. - ** Fixed handling of POST requests with query strings via CGI.pm; the query string arguments were previously ignored, and are now merged with POST arguments. This is an incompatible change only for those whose code relied on the arguments missing. - Added basic validation of arguments to Parser, Interp, and ApacheHandler constructors. - Added interp->die_handler, allowing you to install your own subroutine as $SIG{__DIE__} to catch errors during component execution. Alternately, you can simply turn the special error handling off. - Added interp->use_dhandlers and interp->use_autohandlers, more intuitive ways to turn on/off dhandlers and autohandlers. - Eliminated interp->verbose_compile_error, which is no longer needed and has not worked for some time. - Wrapped each component call in eval, allowing us to simplify the request stack code. No visible user change. - Documented that you cannot call return() from a <%shared> or <%once> section. (reported by Paolo Campanella) - Fixed documentation of escaped newline behavior. - Fixed incorrect code for using mod_perl args method in eg/session_handler.pl. 1.0 January 31, 2001 - Identical to 0.896 except for version. 0.896 January 5, 2001 - Fixed bug preventing Mason from working with PerlFreshRestart. - Fixed use_reload_file to work as documented and not stat() source files. (submitted by Benjamin John Turner) - Fixed display in Apache::Status. - Documented the significance of ordering in <%args> sections. - Fixed documentation of %ARGS with regards to hashes passed in query string. (suggested by Adam Stubbs) - Added version # to 'use Apache::Session::File' in session_handler.pl. - Fixed preloads documentation to match reality. 0.895 December 11, 2000 - ** Removed ApacheHandler from Mason.pm. It is now necessary to explicitly 'use' the HTML::Mason::ApacheHandler module in your handler.pl file (or elsewhere). This fixes an intermittent args_method bug and cleans up Mason.pod. - ** Changed $m->caller_args to return a hash reference in scalar context and a list/hash in list context. Older calls expecting a list reference will need to be changed. - Fixed Mason to work under Perl's tainting mode again. Thanks to John Tobey for pointing us in the right direction. - Modified the definition of "next component" to depend on the current component, not merely the number of times $m->call_next has been called. This allows $m->fetch_next to work as documented. Also added $m->fetch_next_all, which returns the rest of the wrapper chain. - Fixed bug with ../.. in component paths. Versions 0.88 and 0.89 would create multiple object files for a single component and would allow any filename to be treated as an internal component. This was _not_ exploitable externally via Apache, however. (reported by Pascal Eeftinck) - Implemented $m->top_comp and $m->top_args, and fixed documentation for $m->callers(-1). (suggested by Kees Vonk) - Added full line comments to <%args> sections. (suggested by Matthew Lewinski) - Revamped test harness system with HTML::Mason::Tests, greatly simplifying the new test creation process. - Implemented partial compliance with Apache::Filter; Mason can now be used as a pre-filter but not yet as a post-filter. i.e. Configurations like "PerlHandler HTML::Mason Apache::Compress" will work. - Implemented logging of NOT FOUND errors to match plain Apache. Also issue special warnings for Mason-specific causes of NOT FOUND. - Documented Mason request object's aborted and aborted_value methods. - Documented the fact that any variable declared in the <%args> section must be a valid Perl variable name. The parser will now give an error if it encounters an invalid name (such as $foo.x). - Eliminated upgrade of Apache request object to Apache::Request class if this were done previously. (submitted by Shevek) - Removed FAQ from distribution. Users should seek out the most current FAQ, now maintained by Kwindla Kramer, on the web. - Fixed bug where an attempt to escape a substitution that contained a function operating on a list (like sort or map) ended up appending the escape flag characters to the list being operated on. - Fixed the test 08-ah to work with CGI versions >= 3.0. (reported by Alexei V. Barantsev) - Fixed a problem with the parser when running with a locale that used a comma as the decimal separator instead of a period. (reported by Louis-David Mitterrand) - Clarified the 'u' escape flag in docs. - Removed use of $r->finfo in Apachehandler.pm, which causes random core dumps in certain versions of mod_perl. - Updated eg/session_handler.pl code to match Apache::Session 1.50+. - Fixed various problems with debug files. - Fixed a bug sometimes seen when the parser failed to parse a component called by another component. - Fixed a bug that prevented the $m->cache_self method from returning anything. - Fixed documentation regarding 'months' and 'years' units in expire_in cache flag. - Fixed bug in HTML/Mason/Component/Subcomponent.pm create_time method. (reported by Caleb Crome) - Fixed bug where Mason would try to escape undefined values in a substitution with an escape flag. (submitted by Denis Shaposhnikov) 0.89 September 14, 2000 - Fixed broken CGI args implementation from 0.88 (old arguments appearing in new requests) - Fixed system log bug from 0.88 0.88 August 30, 2000 - Fixed broken Parser postprocessor code (broken since 0.85). Added tests for this code path as well as the preprocessor feature. (reported by Tim Bishop) - Replaced lots of simple accessors with new HTML::Mason::MethodMaker (which just makes simple read-only and read-write accessor methods). - Removed all direct hash key access from one object into another. - Removed all unneeded uses of Exporter in various modules. - Added warning about using mod_perl as a DSO to README file. - Added 'cgi_object' method to HTML::Mason::Request::ApacheHandler. This method returns the CGI object Mason uses internally (unless you're using Apache::Request instead in which case its a fatal error). Added documentation for this. (suggested by many people). - Squashed warning in assignment to %ARGS in component sub body. - Fixed call_method and scall_method to take arbitrary list of args instead of hash. - Fixed expression escape flags to allow arbitrary following whitespace. (reported by Mikhail Zabaluev) - Added FAQ on how to handle file uploads. - $m->cache returns the value stored on a successful store action. - Reduced memory usage by removing unneeded uses of various modules. On my box I see about a 500k or so reduction in memory use (Dave). - Removed all uses of the IO::* modules. - Mason seems to be working under a mod_perl DSO, at least under mod_perl 1.24 and Apache 1.3.12. This probably has nothing to do with Mason but the very adventurous are encouraged to experiment with a mod_perl DSO and report back to the mason list. 0.87 May 24, 2000 - Fixed multiple GET/POST argument glitch introduced in 0.86. (reported by Matt Hoskins) 0.86 May 18, 2000 - Fixed multiple-<%perl>-section infinite loop bug introduced in 0.85. - (Re-)Fixed Apache hang on POST not-found bug. - Added $m->scall_method, analagous to $m->scomp. (suggested by Michael Shulman) - When using mod_perl args method, $r is upgraded to Apache::Request object. (suggested by Matt Hoskins) - Documented attr, methods, and flags in Component.pod. - Improved error msg for <%def> or <%method> lacking name. - Improved error msg for using invalid embedded tag in def or method. (submitted by Dave Rolsky) - Eliminated reliance on hash ordering in tests. - Changed test scripts to create separate data dirs for each test branch and clear data dir at start of test. - Added mixed case and repeated sections to <%perl> tests. - ** Removed mod_perl specific $m->http_input; can no longer be supported. - Fixed args processing loop to allow multiple file uploads. (submitted by Matt Hoskins) 0.85 May 7, 2000 - Added object-oriented primitives to components. Components can define methods and attributes and inherit from parent components. Templates can access the current page's methods and attributes for greater flexibility. - ** Major improvements/changes to autohandler feature. Autohandlers are now recursive by default, and all applicable autohandlers for a given page get a chance to run. If you have multiple autohandlers in parent/child directories, or if you used autohandlers with allow_recursive_autohandlers=0, you will need to adjust for the new policy. - Integrated a revamped parse_component that is cleaner, more modular and easier to subclass. Courtesy of Dave Rolsky. - New <%shared> section contains code that executes once per request and whose declarations are visible from the main component, methods and subcomponents alike. - Added escape flags for <% %> output. Can now HTML-escape or URI-escape expressions on a site-wide or per-expression basis. - Added choice of CGI or Apache::Request when using ApacheHandler. (submitted by Dave Rolsky) - Documented $m->clear_buffer, which removes all pending output from the buffer. - Fixed keys and expires cache actions from m->cache interface. (suggested by Matt Hoskins) - dhandlers can now serve their own directory; added documentation about handling directories. - Fixed dhandler bug introduced in 0.81 whereby $m->dhandler_arg only contains the first branch of a multi-branch argument. - Removed memory leak in ApacheHandler::handle_request_1. (submitted by Pascal Eeftinck and Renzo Toma) - Changed parent_comp() to owner() for subcomponents/methods. - Increased maximum recurse level from 16 to 32. - Reorganized syntax section of developer's manual and added a "how to use this manual" section. - Added an UPGRADE guide to distribution. - Added section about securing top-level components to Admin.pod. (suggested by Sean Cazzell) - Added section about declining image requests to Admin.pod. - Eliminated "Subroutine status_mason redefined" warning when creating multiple ApacheHandlers. - Updated cookie expiration in CD-ME example. (reported by Renzo Toma) - Added a "-f" flag to rm in faq Makefile. (reported by Jeremy Taylor) 0.81 February 20, 2000 - Fixed small 0.8 bugs with automatic header sending. Headers are now sent for blank pages and are not sent on an error status code. - Fixed bug with default system log file. (submitted by Renzo Toma) - Eliminated memory leak introduced in 0.8 for a few Linux platforms. (submitted by Renzo Toma and Pascal Eeftinck) - Fixed bug with component paths displaying two leading slashes. - Fixed $comp->source_file when multiple comp roots declared. - Fixed $m->decline in mod_perl mode. - Removed legacy dhandler code from ApacheHandler. - Replaced $r->filename with $r->finfo in ApacheHandler. (submitted by Dennis Watson) - Added dynamic virtual server configuration example to Admin.pod. (submitted by Caleb Crome) 0.8 January 23, 2000 - New integrated request API. $m replaces $REQ as the global variable containing the current request object. All mc_ commands have been incorporated into $m methods: mc_comp becomes $m->comp, mc_file becomes $m->file, etc. The old commands still work for now. - The utility bin/convert0.8.pl converts existing components to use the new request API. - Autohandler methods have been renamed: from mc_auto_next to $m->call_next and mc_auto_comp to $m->fetch_next. This is in preparation for a more general component inheritance system. convert0.8.pl handles this change. - Can now specify multiple component roots in the spirit of @INC. (suggested by Ewan Edwards and others) - Simplified HTTP header behavior. Headers are sent at the end of the request (in batch mode) or just before the first non-whitespace output (in stream mode). suppress_http_header no longer needed. - New organization of Component class into subclasses Component::FileBased and Component::Subcomponent. No outward change. - Updated object file format. Mason should generally auto-detect and recompile old object files, but may not catch everything. Try removing your object directory if errors persist. - ** mc_suppress_http_header command still exists but does nothing. In most cases this should not cause a problem. The only incompatibility is if you have used mc_suppress_http_header to suppress headers completely (i.e. you don't want Mason to send headers at all); in this case pass auto_send_headers=>0 to ApacheHandler. - Output mode parameter was moved from ah->output_mode to interp->out_mode, to make it independent of mod_perl. ah->output_mode still works. - New in-memory code cache keeps track of component usage, and discards the most infrequently used components as needed. You can specify the cache size with interp->max_code_cache_size. - ** Eliminated the now unnecessary interp->code_cache_mode. - ** Eliminated the "source references" optimization, a common source of bugs, no longer needed with the new code cache. - Allow arguments to be accessed via @_ as in regular subroutines; no longer required to be in hash form. (suggested by Ken Williams) - Added $m->scomp, which returns the output of the component call instead of printing it. This is a cleaner replacement for the STORE parameter, which still works but is no longer officially documented. - Added $m->flush_buffer, which forces the buffer to be sent to the client when in batch mode. - Added $m->caller_args, which returns the argument list for any point in the stack. (suggested by Lee Semel) - Added $m->decline, which passes control to the next dhandler. (suggested by Chuck O'Donnell) - Augmented $m->cache_self to cache return values as well as output. (suggested by Jon Frisby) - Changed data cache filenames from colon-separated to url-encode style for Win32 compatibility. (submitted by Ken Williams) - Added improved, separate session_handler.pl for session handling. - ** mc_comp_source no longer works for non-existent components. - ** Removed mc_date legacy command. - Many new test scripts. - Added warnings about using Mason with mod_perl DSO. - Added more site configuration examples to Admin.pod. - Split object parameter methods (interp->comp_root, etc.) into read/write and read-only as appropriate. - Fixed request stack corruption when die() or error from one component is caught by another component's eval. - Fixed doc_root / comp_root mismatch on case-insensitive O/S. (reported by John Arnold) - Fixed "directory not absolute" warning on "/" (reported by Joe Edmonds) - Fixed reload file scanning mechanism (submitted by Brian Holmes) - Added use_data_dumper_xs Config.pm item, which checks whether Data::Dumper::Dumpxs is available. (reported by Pelle Johnsen) - Added "code examples" section to README 0.72 October 15, 1999 - Eliminated long-standing infinite-block bug when POSTing to a non-existent URL - Fixed "keys" cache action which never worked as documented (submitted by Scott Straley) - Fixed source references on Win32 platforms by using text mode when reading object file (submitted by Michael Shulman) - Fixed various methods in FakeApache - Remove final slash from system paths (component root, etc.) and check that those paths are absolute - Fixed all-text subcomponents, by bypassing the pure-text optimization - Quoted all hash strings in object file to reduce "Ambiguous use of ..." warnings (suggested by Paul Schilling) - Replaced */* with default-handler as recommended way to bypass Mason (suggested by Dirk Koopman) - Removed defunct pure text section in Administrators Guide (reported by Michael Shulman) 0.71 September 14, 1999 - Logic of top_level_predicate was reversed in 0.7; fixed. (reported by Tom Hughes, Eric Hammond) - mc_suppress_http_header(0) was broken in 0.7; fixed. (reported by Michael Alan Dorman) - Fixed bug in parser section that determines whether % is at the beginning of a line. (reported by Tom Hughes) - Parser no longer inadvertently accepts argument names with whitespace. (reported by Phillip Gwyn) 0.7 September 1, 1999 - Improved core implementation with two new classes, HTML::Mason::Request and HTML::Mason::Component. Code is now cleaner and more scalable, and the new APIs give developers control and introspection over Mason's inner workings. - Added documentation to accommodate new classes: created Request.pod and Component.pod, and moved component developer's guide (previously at Components.pod) to Devel.pod to avoid confusion. - Object files have changed significantly (they now return a component object). Pre-0.7 object files will be detected and automatically updated, unless you are running in reload file mode in which case you are responsible for generating new object files. - New <%def> section defines a subcomponent embedded inside a larger component. This allows repeated code and HTML to be modularized without affecting the global component namespace. - <%args> section now accommodates optional comments for declarations - Improved Perl translation of <%args> section (submitted by Ken Williams) - Autohandler and dhandler file names are now configurable - Dhandlers, which formerly worked only in mod_perl mode, now work in stand-alone mode as well - Interp::exec is now re-entrant with all request specific information having been moved to Request class. - ** Reworked Parser API. parse is now called make_component, has a simplified set of options, and returns a component object directly. make is now called make_dirs. - Source references now read from the object file, cleaner for a variety of reasons. Preprocess and postprocess now work with source references. - Removed obsolete and undocumented Interp::vars and mc_var functions - Simplified chown/getpwuid usage in handler.pl (submitted by Randal Schwartz) 0.6.2 August 20, 1999 - Fixed problem with shared data cache locks over NFS (submitted by Tom Hughes) - Fixed mc_auto_comp, which never really worked as documented - Fixed preloading for directories (submitted by Dennis Watson) - Added back Utils::get_lock, which is used by content management 0.6.1 July 27, 1999 - Added warnings to convert-0.6.pl about occasional erroneous component call syntax conversions (reported by Oleg Bartunov) - Fixed conversion of <% mc_comp("/foo/$bar") %> (reported by Oleg Bartunov) - Fixed cache access under high concurrencies (reported by Oleg Bartunov) - Fixed uppercase <%PERL>, broken in 0.6 (reported by Daniel L. Jones) - Fixed mc_suppress_http_header(0), broken in 0.6 (reported by Jim Mortko) 0.6 July 16, 1999 - New <& &> tag provides a more convenient way to call components inside HTML. mc_comp still works. - The "perl_" prefix has been eliminated from section names: now simply use <%init>, <%cleanup>, <%args>, etc. The old names still work. - The utility bin/convert0.6.pl converts existing components to use the above new syntax. - New autohandler feature finally provides an easy way to specify a common template or behavior for a directory. An autohandler is invoked just before any top-level components in its directory begins executing. It can display header/footers, apply a filtering function, set up globals, etc. A good complement to dhandlers. - New <%once> section contains code that will be executed once when a component is loaded. It is useful for defining persistent variables and named subroutines. - New <%filter> section and mc_call_self command allow you to arbitrarily filter the output of the current component. - New <%text> section allows you to turn off Mason processing for a particular section of text. - Implemented first installation test suite! [modus] - HEAD optimization: we now automatically abort after headers are sent on a HEAD request. - New Parser make() utility traverses a tree of components, compiling any out-of-date components into object files and reporting errors. - New mc_comp_source command returns the source filename of this or any component. - mc_file now uses current component path by default for relative paths if no static_file_root defined (suggested by John Landahl) - Various previewer interface improvements - Removed link tags in pods documentation due to 5.004 problems - Took out previewer stub from Mason.pm to eliminate "subroutine redefined" warning - Updated makeconfig.pl to prefer GDBM_File, to avoid a bug in Berkeley DB 1.x - Cleaned and sped up interp hooks facility - Stopped substituting control characters for section strings in Parser [modus] - Fixed mc_cache 'expire' bug (reported by Aaron Ross) - Changed ignore_warnings default to ignore "subroutine redefined" warnings to make <%once> more useful - Removed defunct Safe code from Parser and defunct ALLOW_HANDLERS code from Interp - Added index file to htdocs/ 0.5.1 June 10, 1999 - Removed leftover "use File::Recurse" in ApacheHandler.pm [modus] - Added empty test target to FAQ Makefile, required on certain architectures [modus] 0.5 June 3, 1999 - Removed memory leak associated with "return sub { ... }" - Overhauled Config.pm, now maintains previous configuration when upgrading Mason (suggested by Patrick Kane) - Made filename processing compatible with Windows 32 (suggested by Rafael Weinstein) - Removed requirement of File::Tools/File::Recurse, replaced with standard File::Find - Switched output to STDOUT from $r->print, to facilitate chaining with other mod_perl tools - Switched to standard argument processing code, now handles multi-part forms [modus] - New preprocess and postprocess Parser options allow you to apply auomatic modifications to components, before or after they are compiled into code. (submitted by Philip Gwyn) - New in_package Parser option allows components to live in any package. (submitted by Philip Gwyn) - Added documentation about using globals in components, and some new facilities: Parser option 'allow_globals' and Interp method 'set_global'. - Documented how to save persistent user information with Apache::Session [modus] - ** Changed behavior of reload_file mode to read directly from object files. If you use reload files, you're now responsible for creating object files. [mschmick] - Reduced number of file stats when loading components [mschmick] - New apache_status_title ApacheHandler option makes it possible to use Mason's perl-status page with multiple ApacheHandler objects. (submitted by Philip Gwyn) - Upgraded FakeApache/debug files to work with mod_perl 1.19 - New sections in Component Developer's Guide explain how debug files work and some caveats about when they don't. - Mentioned mailing lists, masonhq.com web site, and FAQ in the documentation and README - Improved documentation on how to integrate images and non-Mason hierarchies with Mason. - Differentiated mc_cache and mc_cache_self in the commands manual (suggested by Tom Hukins) - Increased discouraging of SDBM, improved warnings when cache store fails (suggested by Patrick Kane) - Fixed HTML documentation to work with IE (suggested by Fen Lebalme) - Fixed infinite loop in ApacheHandler dhandler search (submitted by Chuck O'Donnell) - Documented Parser method parse(), which allows you to compile components outside of a Interp environment. - New mc_cache actions 'expire' and 'keys' help you peer into data cache files and expire selected keys. - Corrected Parser to properly handle \ in components (submitted by Ken Williams) - ** Took Preview out of Mason.pm; ApacheHandler used only if mod_perl environment. If you use the previewer, you now have to explicitly "use HTML::Mason::Preview" in your handler.pl. - Improved documentation about argument/GET/POST handling (suggested by Ken Williams) - Added cache option 'busy_lock', which prevents multiple processes from recomputing an expire cache value at the same time. (suggested by Dennis Watson) - Inserted work-around for Perl 5.005 $r scoping bug (submitted by Rafael Weinstein) - Fixed "new CGI" example in Components.pod (submitted by Austin Lin) - Fixed "return if content-type..." line in handler.pl and Mason.pod (submitted by Patrick Kane) - Added CREDITS file 0.4 January 06, 1999 - Added support for using Perl profiler in conjunction with debug files - Fixed bug in previewer HTML trace introduced in 0.3 - Created Perl status section for Mason - Removed most warnings when PerlWarn is on (suggested by Philip Gwyn) - Added code_cache_mode parameter to control caching of components in memory - Fixed mismatch between documentation and code with regards to cache store events in system log. The real event name is CACHE_WRITE. - Changed system logging to use canonical server name when recording URI - Field access methods inside Mason objects are now handled with custom subroutines instead of generic AUTOLOAD, improving performance - Information for debug file is no longer collected if debug mode is "none" - Code to decline images and other non-text requests was placed in default handler.pl and described in documentation (suggested by Patrick Kane) - Fixed server header output from debug files (suggested by Ewan Edwards) - Created a Mason bundle - Created a CPAN "alias" from Apache::Mason to HTML::Mason 0.3 November 25, 1998 - Added optional system logging of page requests, cache activity, component loading - Deny directory requests so that index files will work in mod_perl 1.16+ - Removed reliance on several external packages (Date::Manip, CGI::Base, URI::Escape). This should reduce the amount of memory taken up by Mason processes and make Mason easier to install. - ** Due to the removal of Date::Manip, the mc_date command will no longer work unless Date::Manip is explicitly used, and the syntax for the expire_at cache parameter and the Interp current_time parameter have changed. - Added parser taint_check flag which allows Mason to work with taint checking on (suggested by Randal Schwartz) - Added warning messages when returning 404 from ApacheHandler - Improved cache locking with the use of separate lock files - Makefile.PL checks for required and optional packages - Documentation fixes and improvements - Removed obsolete and undocumented commands from Commands.pm - Failure to write debug file is now a warning rather than fatal error - Augmented "no configuration for previewer port" error - Fixed $interp->exec to be able to return list - Changed parser to remove ctrl-Ms instead of replacing with spaces - Always call http_header hook, not just at top level - Added global IN_DEBUG_FILE flag - Renamed mc_call_stack to mc_comp_stack to match documentation 0.2 August 21, 1998 - Replaced File::lockf module, which could not port to some systems, with simple call to flock - Corrected email address in README - Fixed undeclared variable bug in preview component - The previewer did not work in basic versions of Perl 5.004 due to an eval scoping bug. A workaround was put in place. - Fixed expire_if cache option to pass correct argument to provided subroutine - Empty argument section no longer parsing incorrectly - Took out directory names from manifest which were causing errors on install - Debug file is no longer prepared when debug_mode is "none" - Use Preview.pm in Mason.pm 0.1 July 22, 1998 - Original version; created by h2xs 1.18 HTML-Mason-1.59/CONTRIBUTING.md0000644000175000017500000000712113660015140015355 0ustar autarchautarch# CONTRIBUTING Thank you for considering contributing to this distribution. This file contains instructions that will help you work with the source code. Please note that if you have any questions or difficulties, you can reach the maintainer(s) through the bug queue described later in this document (preferred), or by emailing the releaser directly. You are not required to follow any of the steps in this document to submit a patch or bug report; these are just recommendations, intended to help you (and help us help you faster). The distribution is managed with [Dist::Zilla](https://metacpan.org/release/Dist-Zilla). However, you can still compile and test the code with the `MakeFile.PL` in the repository: perl Makefile.PL make make test You may need to satisfy some dependencies. The easiest way to satisfy dependencies is to install the last release. This is available at https://metacpan.org/release/HTML-Mason You can use [`cpanminus`](https://metacpan.org/pod/App::cpanminus) to do this without downloading the tarball first: $ cpanm --reinstall --installdeps --with-recommends HTML::Mason [`Dist::Zilla`](https://metacpan.org/pod/Dist::Zilla) is a very powerful authoring tool, but requires a number of author-specific plugins. If you would like to use it for contributing, install it from CPAN, then the following command to install the needed distros: $ dzil authordeps --missing | cpanm There may also be additional requirements not needed by the dzil build which are needed for tests or other development: $ dzil listdeps --author --missing | cpanm Or, you can use the 'dzil stale' command to install all requirements at once: $ cpanm Dist::Zilla::App::Command::stale $ dzil stale --all | cpanm You can also do this via cpanm directly: $ cpanm --reinstall --installdeps --with-develop --with-recommends HTML::Mason Once installed, here are some dzil commands you might try: $ dzil build $ dzil test $ dzil test --release $ dzil xtest $ dzil listdeps --json $ dzil build --notgz You can learn more about Dist::Zilla at http://dzil.org/. The code for this distribution is [hosted on GitHub](https://github.com/houseabsolute/HTML-Mason). You can submit code changes by forking the repository, pushing your code changes to your clone, and then submitting a pull request. Please update the Changes file with a user-facing description of your changes as part of your work. See the GitHub documentation for [detailed instructions on pull requests](https://help.github.com/articles/creating-a-pull-request) If you have found a bug, but do not have an accompanying patch to fix it, you can submit an issue report [via the web](https://github.com/houseabsolute/HTML-Mason/issues). ## Continuous Integration All pull requests for this distribution will be automatically tested on Linux by [Travis](https://travis-ci.org/houseabsolute/HTML-Mason). All CI results will be visible in the pull request on GitHub. Follow the appropriate links for details when tests fail. PRs cannot be merged until tests pass. ## Contributor Names If you send a patch or pull request, your name and email address will be included in the documentation as a contributor (using the attribution on the commit or patch), unless you specifically request for it not to be. If you wish to be listed under a different name or address, you should submit a pull request to the `.mailmap` file to contain the correct mapping. ## Generated By This file was generated via Dist::Zilla::Plugin::GenerateFile::FromShareDir 0.014 from a template file originating in Dist-Zilla-PluginBundle-DROLSKY-1.08. HTML-Mason-1.59/LICENSE0000644000175000017500000004371313660015140014140 0ustar autarchautarchThis software is copyright (c) 1998 - 2020 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 1998 - 2020 by Jonathan Swartz. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 1998 - 2020 by Jonathan Swartz. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End HTML-Mason-1.59/README.md0000644000175000017500000002171013660015140014403 0ustar autarchautarch# NAME HTML::Mason - High-performance, dynamic web site authoring system # VERSION version 1.59 # SYNOPSIS PerlModule HTML::Mason::ApacheHandler SetHandler perl-script PerlHandler HTML::Mason::ApacheHandler # DESCRIPTION Mason is a tool for building, serving and managing large web sites. Its features make it an ideal backend for high load sites serving dynamic content, such as online newspapers or database driven e-commerce sites. Actually, Mason can be used to generate any sort of text, whether for a web site or not. But it was originally built for web sites and since that's why most people are interested in it, that is the focus of this documentation. Mason's various pieces revolve around the notion of "components''. A component is a mix of HTML, Perl, and special Mason commands, one component per file. So-called "top-level" components represent entire web-pages, while smaller components typically return HTML snippets for embedding in top-level components. This object-like architecture greatly simplifies site maintenance: change a shared component, and you instantly changed all dependent pages that refer to it across a site (or across many virtual sites). Mason's component syntax lets designers separate a web page into programmatic and design elements. This means the esoteric Perl bits can be hidden near the bottom of a component, preloading simple variables for use above in the HTML. In our own experience, this frees content managers (i.e., non-programmers) to work on the layout without getting mired in programming details. Techies, however, still enjoy the full power of Perl. Mason works by intercepting innocent-looking requests (say, http://www.yoursite.com/index.html) and mapping them to requests for Mason components. Mason then compiles the component, runs it, and feeds the output back to the client. Consider this simple Mason component: % my $noun = 'World'; Hello <% $noun %>! How are ya? The output of this component is: Hello World! How are ya? In this component you see a mix of standard HTML and Mason elements. The bare '%' prefixing the first line tells Mason that this is a line of Perl code. One line below, the embedded <% ... %> tag gets replaced with the return value of its contents, evaluated as a Perl expression. Beyond this trivial example, components can also embed serious chunks 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. # MAINTENANCE HELP NEEDED I (Dave Rolsky) am no longer using HTML::Mason and I would love to find some co-maintainers to help. Specifically, I'd like people to review issues and PRs, create new PRs, and ultimately take on the task of uploading new releases to CPAN. If you're interested the best way to start is to fix one or more of the issues in the [issue tracker](https://github.com/houseabsolute/HTML-Mason/issues?q=is%3Aissue+is%3Aopen+sort%3Aupdated-desc). # WAIT - HAVE YOU SEEN MASON 2? Version 1 of Mason (this distribution) -- 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 -- [Mason](https://metacpan.org/pod/Mason) -- was released in February of 2011. It offers a new syntax as well as a number of other features. See [https://metacpan.org/pod/distribution/Mason/lib/Mason/Manual/UpgradingFromMason1.pod](https://metacpan.org/pod/distribution/Mason/lib/Mason/Manual/UpgradingFromMason1.pod) for details of the differences between the two. # INSTALLATION Mason has been tested under Linux, FreeBSD, Solaris, HPUX, and Win32. As an all-Perl solution, it should work on any machine that has working versions of Perl 5.00503+, mod\_perl, and the required CPAN modules. Mason has a standard MakeMaker-driven installation. See the README file for details. # CONFIGURING MASON This section assumes that you are able to install and configure a mod\_perl server. Relevant documentation is available at http://www.apache.org (Apache) and http://perl.apache.org (mod\_perl). The mod\_perl mailing list, archive, and guide are also great resources. The simplest configuration of Mason requires a few lines in your httpd.conf: PerlModule HTML::Mason::ApacheHandler SetHandler perl-script PerlHandler HTML::Mason::ApacheHandler The PerlModule directive simply ensures that the Mason code is loaded in the parent process before forking, which can save some memory when running mod\_perl. The section routes all requests to the Mason handler, which is a simple way to try out Mason. A more refined setup is discussed in the [Controlling Access via Filename Extension](https://metacpan.org/pod/HTML%3A%3AMason%3A%3AAdmin#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 haven't broken anything. If all goes well you should see the same page as before. If not, recheck your Apache config files and also tail your server's error log. If you are getting "404 Not Found" errors even when the files clearly exist, Mason may be having trouble with your document root. One situation that will unfortunately confuse Mason is if your document root goes through a symbolic link. Try expressing your document root in terms of the true filesystem path. Next, try adding the tag <% 2+2 %> at the top of some HTML file. If you reload this page and see a "4", Mason is working! # DOCUMENTATION ROADMAP Once Mason is on its feet, the next step is to write a component or two. The [Mason Developer's Manual](https://metacpan.org/pod/HTML%3A%3AMason%3A%3ADevel) is a complete tutorial for writing, using, and debugging components. A reference companion to the Developer's Manual is the Request API documentation, [HTML::Mason::Request](https://metacpan.org/pod/HTML%3A%3AMason%3A%3ARequest). Whoever is responsible for setting up and tuning Mason should read the [Administrator's Manual](https://metacpan.org/pod/HTML%3A%3AMason%3A%3AAdmin), though developers will also benefit from reading it as well. This document covers more advanced configuration scenarios and performance optimization. The reference companion to the Administrator's manual is the [Parameters Reference](https://metacpan.org/pod/HTML%3A%3AMason%3A%3AParams), which describes all the parameters you can use to configure Mason. Most of this documentation assumes that you're running Mason on top of mod\_perl, since that is the most common configuration. If you would like to run Mason via a CGI script, refer to the [HTML::Mason::CGIHandler](https://metacpan.org/pod/HTML%3A%3AMason%3A%3ACGIHandler) documentation. If you are using Mason from a standalone program, refer to the [Using Mason from a Standalone Script](https://metacpan.org/pod/HTML%3A%3AMason%3A%3AAdmin#Using-Mason-from-a-Standalone-Script) section of the administrator's manual. There is also a book about Mason, _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. # GETTING HELP AND SOURCES Questions and feedback are welcome, and should be directed to the Mason mailing list. You must be subscribed to post. https://lists.sourceforge.net/lists/listinfo/mason-users You can also visit us at `#mason` on [irc://irc.perl.org/#mason](irc://irc.perl.org/#mason). Bugs and feature requests will be tracked at RT: http://rt.cpan.org/NoAuth/Bugs.html?Dist=HTML-Mason bug-html-mason@rt.cpan.org # SUPPORT Bugs may be submitted at [https://github.com/houseabsolute/HTML-Mason/issues](https://github.com/houseabsolute/HTML-Mason/issues). I am also usually active on IRC as 'autarch' on `irc://irc.perl.org`. # SOURCE The source code repository for HTML-Mason can be found at [https://github.com/houseabsolute/HTML-Mason](https://github.com/houseabsolute/HTML-Mason). # AUTHORS - Jonathan Swartz - Dave Rolsky - Ken Williams # CONTRIBUTORS - Ævar Arnfjörð Bjarmason - Alex Balhatchet - Alex Vandiver - Florian Schlichting - John Williams - Kent Fredric - Kevin Falcone - Patrick Kane - Ricardo Signes - Shlomi Fish # COPYRIGHT AND LICENSE This software is copyright (c) 1998 - 2020 by Jonathan Swartz. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. The full text of the license can be found in the `LICENSE` file included with this distribution. HTML-Mason-1.59/META.json0000644000175000017500000011323213660015140014546 0ustar autarchautarch{ "abstract" : "High-performance, dynamic web site authoring system", "author" : [ "Jonathan Swartz ", "Dave Rolsky ", "Ken Williams " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.014, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "HTML-Mason", "no_index" : { "directory" : [ "eg" ], "file" : [ "lib/HTML/Mason/Tests.pm" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" }, "suggests" : { "JSON::PP" : "2.27300" } }, "develop" : { "requires" : { "CHI" : "0.21", "Code::TidyAll" : "0.56", "Code::TidyAll::Plugin::SortLines::Naturally" : "0.000003", "Code::TidyAll::Plugin::Test::Vars" : "0.02", "Parallel::ForkManager" : "1.19", "Perl::Critic" : "1.126", "Perl::Tidy" : "20160302", "Test::CPAN::Meta::JSON" : "0.16", "Test::Memory::Cycle" : "0", "Test::Mojibake" : "0", "Test::More" : "0.88", "Test::NoTabs" : "0", "Test::Pod" : "1.41", "Test::Spelling" : "0.12", "Test::Vars" : "0.009", "Test::Version" : "2.05" } }, "runtime" : { "requires" : { "CGI" : "2.46", "Cache::Cache" : "1.00", "Class::Container" : "0.07", "Exception::Class" : "1.15", "File::Spec" : "0.8", "HTML::Entities" : "0", "Log::Any" : "0.08", "Params::Validate" : "0.70", "Scalar::Util" : "1.01" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Spec" : "0.8", "Test::Deep" : "0", "Test::More" : "0.96" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/houseabsolute/HTML-Mason/issues" }, "homepage" : "https://metacpan.org/release/HTML-Mason", "repository" : { "type" : "git", "url" : "git://github.com/houseabsolute/HTML-Mason.git", "web" : "https://github.com/houseabsolute/HTML-Mason" } }, "version" : "1.59", "x_Dist_Zilla" : { "perl" : { "version" : "5.030001" }, "plugins" : [ { "class" : "Dist::Zilla::Plugin::FileFinder::Filter", "name" : "SkipApacheHandler", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::PkgVersion", "name" : "PkgVersion", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Git::GatherDir", "config" : { "Dist::Zilla::Plugin::GatherDir" : { "exclude_filename" : [ "CODE_OF_CONDUCT.md", "CONTRIBUTING.md", "LICENSE", "Makefile.PL", "README.md", "cpanfile" ], "exclude_match" : [], "follow_symlinks" : 0, "include_dotfiles" : 0, "prefix" : "", "prune_directory" : [], "root" : "." }, "Dist::Zilla::Plugin::Git::GatherDir" : { "include_untracked" : 0 } }, "name" : "@DROLSKY/Git::GatherDir", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::ManifestSkip", "name" : "@DROLSKY/ManifestSkip", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "@DROLSKY/License", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::ExecDir", "name" : "@DROLSKY/ExecDir", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::ShareDir", "name" : "@DROLSKY/ShareDir", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "@DROLSKY/Manifest", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::CheckVersionIncrement", "name" : "@DROLSKY/CheckVersionIncrement", "version" : "0.121750" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "@DROLSKY/TestRelease", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "@DROLSKY/ConfirmRelease", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::UploadToCPAN", "name" : "@DROLSKY/UploadToCPAN", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Authority", "name" : "@DROLSKY/Authority", "version" : "1.009" }, { "class" : "Dist::Zilla::Plugin::CopyFilesFromBuild", "name" : "@DROLSKY/CopyFilesFromBuild", "version" : "0.170880" }, { "class" : "Dist::Zilla::Plugin::GitHub::Meta", "name" : "@DROLSKY/GitHub::Meta", "version" : "0.47" }, { "class" : "Dist::Zilla::Plugin::GitHub::Update", "config" : { "Dist::Zilla::Plugin::GitHub::Update" : { "metacpan" : 1 } }, "name" : "@DROLSKY/GitHub::Update", "version" : "0.47" }, { "class" : "Dist::Zilla::Plugin::MetaResources", "name" : "@DROLSKY/MetaResources", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Meta::Contributors", "name" : "@DROLSKY/Meta::Contributors", "version" : "0.003" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "@DROLSKY/MetaConfig", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "@DROLSKY/MetaJSON", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "@DROLSKY/MetaYAML", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::NextRelease", "name" : "@DROLSKY/NextRelease", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "test", "type" : "requires" } }, "name" : "@DROLSKY/Test::More with subtest", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "requires" } }, "name" : "@DROLSKY/Modules for use with tidyall", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "requires" } }, "name" : "@DROLSKY/Test::Version which fixes https://github.com/plicease/Test-Version/issues/7", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::PromptIfStale", "config" : { "Dist::Zilla::Plugin::PromptIfStale" : { "check_all_plugins" : 0, "check_all_prereqs" : 0, "modules" : [ "Dist::Zilla::PluginBundle::DROLSKY" ], "phase" : "build", "run_under_travis" : 0, "skip" : [] } }, "name" : "@DROLSKY/Dist::Zilla::PluginBundle::DROLSKY", "version" : "0.057" }, { "class" : "Dist::Zilla::Plugin::PromptIfStale", "config" : { "Dist::Zilla::Plugin::PromptIfStale" : { "check_all_plugins" : 1, "check_all_prereqs" : 1, "modules" : [], "phase" : "release", "run_under_travis" : 0, "skip" : [ "Dist::Zilla::Plugin::DROLSKY::Contributors", "Dist::Zilla::Plugin::DROLSKY::Git::CheckFor::CorrectBranch", "Dist::Zilla::Plugin::DROLSKY::License", "Dist::Zilla::Plugin::DROLSKY::TidyAll", "Dist::Zilla::Plugin::DROLSKY::WeaverConfig", "Pod::Weaver::PluginBundle::DROLSKY" ] } }, "name" : "@DROLSKY/PromptIfStale", "version" : "0.057" }, { "class" : "Dist::Zilla::Plugin::Test::PodSpelling", "config" : { "Dist::Zilla::Plugin::Test::PodSpelling" : { "directories" : [ "bin", "lib" ], "spell_cmd" : "", "stopwords" : [ "AUTOHANDLERS", "Adminstrator", "ApacheModPerl", "ApacheReload", "Autohandlers", "Bekman", "CGI", "ContactUs", "DROLSKY", "DROLSKY's", "DSO", "DeWitt", "DocumentRoot", "DocumentRoots", "FastCGI", "FilesMatch", "Follett", "ForceFileDownload", "GIF", "Georgiou", "HPUX", "HUP", "HandlingDirectoriesWithDhandlers", "Khera", "Kiriakos", "Kirwan", "Kumar", "LFU", "LogLevel", "MSIE", "MailingLists", "Mallah", "MasonAllowGlobals", "MasonApacheStatusTitle", "MasonArgsMethod", "MasonAutoSendHeaders", "MasonAutoflush", "MasonAutohandlerName", "MasonBufferPreallocateSize", "MasonCodeCacheMaxSize", "MasonCompClass", "MasonCompRoot", "MasonCompilerClass", "MasonComponentErrorHandler", "MasonDataCacheApi", "MasonDataCacheDefaults", "MasonDataDir", "MasonDeclineDirs", "MasonDefaultEscapeFlags", "MasonDefineArgsHash", "MasonDhandlerName", "MasonDynamicCompRoot", "MasonEnableAutoflush", "MasonErrorFormat", "MasonErrorMode", "MasonEscapeFlags", "MasonIgnoreWarningsExpr", "MasonInPackage", "MasonInterpClass", "MasonLexerClass", "MasonMaxRecurse", "MasonNamedComponentSubs", "MasonObjectFileExtension", "MasonOutMethod", "MasonPlugins", "MasonPostamble", "MasonPostprocessPerl", "MasonPostprocessText", "MasonPreamble", "MasonPreloads", "MasonPreprocess", "MasonRequestClass", "MasonResolverClass", "MasonStaticSource", "MasonStaticSourceTouchFile", "MasonSubcompClass", "MasonUseObjectFiles", "MasonUseSourceLineNumbers", "MasonUseStrict", "MasonUseWarnings", "NullCache", "O'Reilly", "PRs", "PayPal", "PerlFreshRestart", "PerlHandler", "PerlModule", "PerlSetVar", "Preallocating", "Preloading", "RPMs", "Rajesh", "RedHat", "ReloadAll", "Rolsky", "Rolsky's", "SUBCLASSABLE", "SYNOPIS", "Solaris", "SpeedyCGI", "Stas", "Subcomponents", "Subrequests", "TIEHASH", "USR", "UserDir", "Vivek", "ala", "apachectl", "apachehandler", "attr", "autohandler", "autohandlers", "bgcolor", "breakpoint'able", "certian", "checksum", "conf", "corrup", "defined'ness", "dhandler", "dhandlers", "drolsky", "dynamicImage", "faq", "fh", "fido", "filenaming", "foobarbaz", "gif", "gifs", "htaccess", "html", "interp", "isNetscape", "ized", "izing", "jpegs", "lexed", "libapreq", "libexpat", "mc", "mcomp", "mhtml", "mpl", "mtxt", "nh", "onwards", "optimizations", "overrideable", "perlsub", "postprocess", "predeclaring", "preload", "preloaded", "preloading", "preloads", "prepopulate", "preprocess", "profiler", "rdist", "reallocations", "reparsed", "reuseability", "scomp", "se", "serializable", "sql", "srm", "subcomponent", "subcomponents", "subcomps", "subexec", "subrequest", "subrequests", "taglibs", "tgz", "tmp", "todo", "un", "undeclarable", "unweakened", "updateable", "uring", "use'd", "xml" ], "wordlist" : "Pod::Wordlist" } }, "name" : "@DROLSKY/Test::PodSpelling", "version" : "2.007005" }, { "class" : "Dist::Zilla::Plugin::PodSyntaxTests", "name" : "@DROLSKY/PodSyntaxTests", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::DROLSKY::RunExtraTests", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 24 } }, "name" : "@DROLSKY/DROLSKY::RunExtraTests", "version" : "1.08" }, { "class" : "Dist::Zilla::Plugin::MojibakeTests", "name" : "@DROLSKY/MojibakeTests", "version" : "0.8" }, { "class" : "Dist::Zilla::Plugin::Test::CPAN::Meta::JSON", "name" : "@DROLSKY/Test::CPAN::Meta::JSON", "version" : "0.004" }, { "class" : "Dist::Zilla::Plugin::Test::NoTabs", "config" : { "Dist::Zilla::Plugin::Test::NoTabs" : { "filename" : "xt/author/no-tabs.t", "finder" : [ ":InstallModules", ":ExecFiles", ":TestFiles" ] } }, "name" : "@DROLSKY/Test::NoTabs", "version" : "0.15" }, { "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs", "name" : "@DROLSKY/Test::ReportPrereqs", "version" : "0.027" }, { "class" : "Dist::Zilla::Plugin::Test::Version", "name" : "@DROLSKY/Test::Version", "version" : "1.09" }, { "class" : "Dist::Zilla::Plugin::DROLSKY::Contributors", "name" : "@DROLSKY/DROLSKY::Contributors", "version" : "1.08" }, { "class" : "Dist::Zilla::Plugin::Git::Contributors", "config" : { "Dist::Zilla::Plugin::Git::Contributors" : { "git_version" : "2.20.1", "include_authors" : 0, "include_releaser" : 1, "order_by" : "name", "paths" : [] } }, "name" : "@DROLSKY/Git::Contributors", "version" : "0.035" }, { "class" : "Dist::Zilla::Plugin::SurgicalPodWeaver", "config" : { "Dist::Zilla::Plugin::PodWeaver" : { "config_plugins" : [ "@DROLSKY" ], "finder" : [ ":InstallModules", ":ExecFiles" ], "plugins" : [ { "class" : "Pod::Weaver::Plugin::EnsurePod5", "name" : "@CorePrep/EnsurePod5", "version" : "4.015" }, { "class" : "Pod::Weaver::Plugin::H1Nester", "name" : "@CorePrep/H1Nester", "version" : "4.015" }, { "class" : "Pod::Weaver::Plugin::SingleEncoding", "name" : "@DROLSKY/SingleEncoding", "version" : "4.015" }, { "class" : "Pod::Weaver::Plugin::Transformer", "name" : "@DROLSKY/List", "version" : "4.015" }, { "class" : "Pod::Weaver::Plugin::Transformer", "name" : "@DROLSKY/Verbatim", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Region", "name" : "@DROLSKY/header", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Name", "name" : "@DROLSKY/Name", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Version", "name" : "@DROLSKY/Version", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Region", "name" : "@DROLSKY/prelude", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Generic", "name" : "SYNOPSIS", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Generic", "name" : "DESCRIPTION", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Generic", "name" : "OVERVIEW", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Collect", "name" : "ATTRIBUTES", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Collect", "name" : "METHODS", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Collect", "name" : "FUNCTIONS", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Collect", "name" : "TYPES", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Leftovers", "name" : "@DROLSKY/Leftovers", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Region", "name" : "@DROLSKY/postlude", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::GenerateSection", "name" : "@DROLSKY/generate SUPPORT", "version" : "1.06" }, { "class" : "Pod::Weaver::Section::AllowOverride", "name" : "@DROLSKY/allow override SUPPORT", "version" : "0.05" }, { "class" : "Pod::Weaver::Section::GenerateSection", "name" : "@DROLSKY/generate SOURCE", "version" : "1.06" }, { "class" : "Pod::Weaver::Section::Authors", "name" : "@DROLSKY/Authors", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Contributors", "name" : "@DROLSKY/Contributors", "version" : "0.009" }, { "class" : "Pod::Weaver::Section::Legal", "name" : "@DROLSKY/Legal", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::AllowOverride", "name" : "@DROLSKY/allow override Legal", "version" : "0.05" }, { "class" : "Pod::Weaver::Section::Region", "name" : "@DROLSKY/footer", "version" : "4.015" } ] } }, "name" : "@DROLSKY/SurgicalPodWeaver", "version" : "0.0023" }, { "class" : "Dist::Zilla::Plugin::DROLSKY::WeaverConfig", "name" : "@DROLSKY/DROLSKY::WeaverConfig", "version" : "1.08" }, { "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod", "config" : { "Dist::Zilla::Role::FileWatcher" : { "version" : "0.006" } }, "name" : "@DROLSKY/README.md in build", "version" : "0.163250" }, { "class" : "Dist::Zilla::Plugin::GenerateFile::FromShareDir", "config" : { "Dist::Zilla::Plugin::GenerateFile::FromShareDir" : { "destination_filename" : "CONTRIBUTING.md", "dist" : "Dist-Zilla-PluginBundle-DROLSKY", "encoding" : "UTF-8", "has_xs" : 0, "location" : "build", "source_filename" : "CONTRIBUTING.md" }, "Dist::Zilla::Role::RepoFileInjector" : { "allow_overwrite" : 1, "repo_root" : ".", "version" : "0.009" } }, "name" : "@DROLSKY/Generate CONTRIBUTING.md", "version" : "0.014" }, { "class" : "Dist::Zilla::Plugin::GenerateFile::FromShareDir", "config" : { "Dist::Zilla::Plugin::GenerateFile::FromShareDir" : { "destination_filename" : "CODE_OF_CONDUCT.md", "dist" : "Dist-Zilla-PluginBundle-DROLSKY", "encoding" : "UTF-8", "has_xs" : 0, "location" : "build", "source_filename" : "CODE_OF_CONDUCT.md" }, "Dist::Zilla::Role::RepoFileInjector" : { "allow_overwrite" : 1, "repo_root" : ".", "version" : "0.009" } }, "name" : "@DROLSKY/Generate CODE_OF_CONDUCT.md", "version" : "0.014" }, { "class" : "Dist::Zilla::Plugin::InstallGuide", "config" : { "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000037", "version" : "0.006" } }, "name" : "@DROLSKY/InstallGuide", "version" : "1.200013" }, { "class" : "Dist::Zilla::Plugin::CPANFile", "name" : "@DROLSKY/CPANFile", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::DROLSKY::License", "name" : "@DROLSKY/DROLSKY::License", "version" : "1.08" }, { "class" : "Dist::Zilla::Plugin::CheckStrictVersion", "name" : "@DROLSKY/CheckStrictVersion", "version" : "0.001" }, { "class" : "Dist::Zilla::Plugin::CheckSelfDependency", "config" : { "Dist::Zilla::Plugin::CheckSelfDependency" : { "finder" : [ ":InstallModules" ] }, "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000037", "version" : "0.006" } }, "name" : "@DROLSKY/CheckSelfDependency", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::CheckPrereqsIndexed", "name" : "@DROLSKY/CheckPrereqsIndexed", "version" : "0.020" }, { "class" : "Dist::Zilla::Plugin::DROLSKY::Git::CheckFor::CorrectBranch", "config" : { "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.20.1", "repo_root" : "." } }, "name" : "@DROLSKY/DROLSKY::Git::CheckFor::CorrectBranch", "version" : "1.08" }, { "class" : "Dist::Zilla::Plugin::EnsureChangesHasContent", "name" : "@DROLSKY/EnsureChangesHasContent", "version" : "0.02" }, { "class" : "Dist::Zilla::Plugin::Git::Check", "config" : { "Dist::Zilla::Plugin::Git::Check" : { "untracked_files" : "die" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "CODE_OF_CONDUCT.md", "CONTRIBUTING.md", "Changes", "LICENSE", "Makefile.PL", "README.md", "cpanfile", "tidyall.ini" ], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.20.1", "repo_root" : "." } }, "name" : "@DROLSKY/Git::Check", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "config" : { "Dist::Zilla::Plugin::Git::Commit" : { "add_files_in" : [], "commit_msg" : "v%V%n%n%c" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "CODE_OF_CONDUCT.md", "CONTRIBUTING.md", "Changes", "LICENSE", "Makefile.PL", "README.md", "cpanfile", "tidyall.ini" ], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.20.1", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@DROLSKY/Commit generated files", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::Git::Tag", "config" : { "Dist::Zilla::Plugin::Git::Tag" : { "branch" : null, "changelog" : "Changes", "signed" : 0, "tag" : "v1.59", "tag_format" : "v%V", "tag_message" : "v%V" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.20.1", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@DROLSKY/Git::Tag", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::Git::Push", "config" : { "Dist::Zilla::Plugin::Git::Push" : { "push_to" : [ "origin" ], "remotes_must_exist" : 1 }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.20.1", "repo_root" : "." } }, "name" : "@DROLSKY/Git::Push", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "config" : { "Dist::Zilla::Plugin::Git::Commit" : { "add_files_in" : [], "commit_msg" : "Bump version after release" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "Changes", "dist.ini" ], "allow_dirty_match" : [ "(?^:.+)" ], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.20.1", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@DROLSKY/Commit version bump", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::Git::Push", "config" : { "Dist::Zilla::Plugin::Git::Push" : { "push_to" : [ "origin" ], "remotes_must_exist" : 1 }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.20.1", "repo_root" : "." } }, "name" : "@DROLSKY/Push version bump", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::DROLSKY::MakeMaker", "config" : { "Dist::Zilla::Plugin::MakeMaker" : { "make_path" : "make", "version" : "6.014" }, "Dist::Zilla::Plugin::MakeMaker::Awesome" : { "version" : "0.48" }, "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 24, "version" : "6.014" } }, "name" : "@DROLSKY/DROLSKY::MakeMaker", "version" : "1.08" }, { "class" : "Dist::Zilla::Plugin::MetaNoIndex", "name" : "MetaNoIndex", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "requires" } }, "name" : "DevelopRequires", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "runtime", "type" : "requires" } }, "name" : "RuntimeRequires", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "test", "type" : "requires" } }, "name" : "TestRequires", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExtraTestFiles", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":PerlExecFiles", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":AllFiles", "version" : "6.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":NoFiles", "version" : "6.014" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : 0 }, "version" : "6.014" } }, "x_authority" : "cpan:DROLSKY", "x_contributors" : [ "\u00c6var Arnfj\u00f6r\u00f0 Bjarmason ", "Alex Balhatchet ", "Alex Vandiver ", "Florian Schlichting ", "John Williams ", "Kent Fredric ", "Kevin Falcone ", "Patrick Kane ", "Ricardo Signes ", "Shlomi Fish " ], "x_generated_by_perl" : "v5.30.1", "x_serialization_backend" : "Cpanel::JSON::XS version 4.19", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" } HTML-Mason-1.59/CODE_OF_CONDUCT.md0000644000175000017500000000625313660015140015730 0ustar autarchautarch# Contributor Covenant Code of Conduct ## Our Pledge In the interest of fostering an open and welcoming environment, we as contributors and maintainers pledge to making participation in our project and our community a harassment-free experience for everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, level of experience, education, socio-economic status, nationality, personal appearance, race, religion, or sexual identity and orientation. ## Our Standards Examples of behavior that contributes to creating a positive environment include: * Using welcoming and inclusive language * Being respectful of differing viewpoints and experiences * Gracefully accepting constructive criticism * Focusing on what is best for the community * Showing empathy towards other community members Examples of unacceptable behavior by participants include: * The use of sexualized language or imagery and unwelcome sexual attention or advances * Trolling, insulting/derogatory comments, and personal or political attacks * Public or private harassment * Publishing others' private information, such as a physical or electronic address, without explicit permission * Other conduct which could reasonably be considered inappropriate in a professional setting ## Our Responsibilities Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior. Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful. ## Scope This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers. ## Enforcement Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at autarch@urth.org. All complaints will be reviewed and investigated and will result in a response that is deemed necessary and appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately. Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership. ## Attribution This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html [homepage]: https://www.contributor-covenant.org HTML-Mason-1.59/inc/0000755000175000017500000000000013660015140013674 5ustar autarchautarchHTML-Mason-1.59/inc/Pod/0000755000175000017500000000000013660015140014416 5ustar autarchautarchHTML-Mason-1.59/inc/Pod/Weaver/0000755000175000017500000000000013660015140015647 5ustar autarchautarchHTML-Mason-1.59/inc/Pod/Weaver/Section/0000755000175000017500000000000013660015140017253 5ustar autarchautarchHTML-Mason-1.59/inc/Pod/Weaver/Section/SeeAlsoMason.pm0000644000175000017500000000174413660015140022150 0ustar autarchautarchpackage inc::Pod::Weaver::Section::SeeAlsoMason; use Moose; with 'Pod::Weaver::Role::Section'; use Moose::Autobox; # Add "SEE ALSO: Mason" sub weave_section { my ( $self, $document, $input ) = @_; return if $input->{filename} =~ m{\QHTML/Mason.pm}; my $idc = $input->{pod_document}->children; for ( my $i = 0 ; $i < $idc->length ; $i++ ) { next unless my $para = $idc->[$i]; return if $para->can('command') && $para->command eq 'head1' && $para->content eq 'SEE ALSO'; } $document->children->push( Pod::Elemental::Element::Nested->new( { command => 'head1', content => 'SEE ALSO', children => [ Pod::Elemental::Element::Pod5::Ordinary->new( { content => "L" } ), ], } ), ); } __PACKAGE__->meta->make_immutable; no Moose; 1; HTML-Mason-1.59/samples/0000755000175000017500000000000013660015140014567 5ustar autarchautarchHTML-Mason-1.59/samples/show-env0000644000175000017500000000017413660015140016262 0ustar autarchautarch

Current Environment

    % foreach my $key (sort(keys(%ENV))) {
  • <% $key %>: <% $ENV{$key} %> % }
HTML-Mason-1.59/samples/README0000644000175000017500000000104413660015140015446 0ustar autarchautarchComponent Samples ================= dump-request Dumps request parameters, great for debugging. Converted from Apache documentation. show-env Dumps current environment. Note: If you are seeing the source of the above pages as plain text, it is because the server is assigning the content type "plain/text" instead of "text/html". The easiest way to remedy this is to put DefaultType text/html in your configuration file, and make sure mod_mime_magic is not active. This will allow filenames with no extensions to be handled by Mason. HTML-Mason-1.59/samples/dump-request0000644000175000017500000003432213660015140017151 0ustar autarchautarch
Request Information Connection Information
$r->method( [$meth] ) = <% $r->method() %>
$r->method_number( [$num] ) = <% $r->method_number() %>
$r->bytes_sent = <% $r->bytes_sent %>
$r->the_request = <% $r->the_request %>
$r->proxyreq = <% $r->proxyreq %>
$r->header_only = <% $r->header_only %>
$r->protocol = <% $r->protocol %>
$r->uri( [$uri] ) = <% $r->uri() %>
$r->filename( [$filename] ) = <% $r->filename() %>
$r->path_info( [$path_info] ) = <% $r->path_info() %>
$r->args = <% $r->args %>
$r->header_in( $header_name, [$value] ) = <% $r->header_in("Content-type") %>
$r->get_remote_host = <% $r->get_remote_host %>
$r->requires = <% $r->requires %>
$r->auth_type = <% $r->auth_type %>
$r->auth_name = <% $r->auth_name %>
$r->document_root = <% $r->document_root %>
$r->allow_options = <% $r->allow_options %> 		% my $c = $r->connection; $c->remote_host = <%$c->remote_host%>
$c->remote_ip = <%$c->remote_ip %>
$c->local_addr = <%$c->local_addr %>
$c->remote_addr = <%$c->remote_addr %>
$c->remote_logname = <%$c->remote_logname%>
$c->user = <%$c->user %>
$c->auth_type = <%$c->auth_type %>
$c->aborted = <%$c->aborted %>
Server Configuration
% my $s = $r->server; $s->server_admin = <% $s->server_admin %>
$s->server_hostname = <%$s->server_hostname%>
$s->port = <%$s->port%>
$s->is_virtual = <%$s->is_virtual%>
$s->names = <%$s->names%>

$r->method( [$meth] )

The $r->method method will return the request method. It will be a string such as ``GET'', ``HEAD'' or ``POST''. Passing an argument will set the method, mainly used for internal redirects.
$r->method_number( [$num] )
The $r->method_number method will return the request method number. The method numbers are defined by the M_GET, M_POST,... constants available from the Apache::Constants module. Passing an argument will set the method_number, mainly used for internal redirects and testing authorization restriction masks.
$r->bytes_sent
The number of bytes sent to the client, handy for logging, etc.
$r->the_request
The request line send by the client, handy for logging, etc.
$r->proxyreq
Returns true if the request is proxy http. Mainly used during the filename translation stage of the request, which may be handled by a PerlTransHandler.
$r->header_only
Returns true if the client is asking for headers only, e.g. if the request method was HEAD.
$r->protocol
The $r->protocol method will return a string identifying the protocol that the client speaks. Typical values will be ``HTTP/1.0'' or ``HTTP/1.1''.
$r->uri( [$uri] )
The $r->uri method will return the requested URI, optionally changing it with the first argument.
$r->filename( [$filename] )
The $r->filename method will return the result of the URI --> filename translation, optionally changing it with the first argument if you happen to be doing the translation.
$r->path_info( [$path_info] )
The $r->path_info method will return what is left in the path after the URI --> filename translation, optionally changing it with the first argument if you happen to be doing the translation.
$r->args
The $r->args method will return the contents of the URI query string. When called in a scalar context, the entire string is returned. When called in a list context, a list of parsed key => value pairs are returned, i.e. it can be used like this: 
   $query = $r->args;
   %in    = $r->args;
<%doc> $r->headers_in The $r->headers_in method will return a %hash of client request headers. This can be used to initialize a perl hash, or one could use the $r->header_in() method (described below) to retrieve a specific header value directly. $r->header_in( $header_name, [$value] )
Return the value of a client header. Can be used like this: 
   $ct = $r->header_in("Content-type");
   $r->header_in($key, $val); #set the value of header '$key'
$r->content
The $r->content method will return the entity body read from the client, but only if the request content type is application/x-www-form-urlencoded. When called in a scalar context, the entire string is returned. When called in a list context, a list of parsed key => value pairs are returned. *NOTE*: you can only ask for this once, as the entire body is read from the client.
$r->read_client_block($buf, $bytes_to_read) Read from the entity body sent by the client. Example of use: $r->read_client_block($buf, $r->header_in('Content-length')); $r->get_remote_host= <% $r->get_remote_host %>
Lookup the client's DNS hostname. If the configuration directive HostNameLookups is set to off, this returns the dotted decimal representation of the client's IP address instead. Might return undef if the hostname is not known.
$r->get_remote_logname = NOT IMPLEMENTED BY MOD_PERL
Lookup the remote user's system name. Might return undef if the remote system is not running an RFC 1413 server or if the configuration directive IdentityCheck is not turned on.
More information about the client can be obtained from the Apache::Connection object, as described below.

$c = $r->connection

The $r->connection method will return a reference to the request connection object (blessed into the Apache::Connection package). This is really a conn_rec* in disguise. The following methods can be used on the connection object:
$c->remote_host
If the configuration directive HostNameLookups is set to on: then the first time $r->get_remote_host is called the server does a DNS lookup to get the remote client's host name. The result is cached in $c->remote_host then returned. If the server was unable to resolve the remote client's host name this will be set to ``''. Subsequent calls to $r->get_remote_host return this cached value.

If the configuration directive HostNameLookups is set to off: calls to $r->get_remote_host return a string that contains the dotted decimal representation of the remote client's IP address. However this string is not cached, and $c->remote_host is undefined. So, it's best to to call $r->get_remote_host instead of directly accessing this variable.

$c->remote_ip
The dotted decimal representation of the remote client's IP address. This is set by then server when the connection record is created so is always defined.
$c->local_addr
A packed SOCKADDR_IN in the same format as returned by Socket, containing the port and address on the local host that the remote client is connected to. This is set by the server when the connection record is created so it is always defined.
$c->remote_addr
A packed SOCKADDR_IN in the same format as returned by Socket, containing the port and address on the remote host that the server is connected to. This is set by the server when the connection record is created so it is always defined.

Among other things, this can be used, together with $c->local_addr, to perform RFC1413 ident lookups on the remote client even when the configuration directive IdentityCheck is turned off.

Can be used like: 

   use Net::Ident qw (lookupFromInAddr);
   ...
   my $remoteuser = lookupFromInAddr ($c->local_addr,
  $c->remote_addr, 2);
Note that the lookupFromInAddr interface does not currently exist in the Net::Ident module, but the author is planning on adding it soon.
$c->remote_logname
If the configuration directive IdentityCheck is set to on: then the first time $r->get_remote_logname is called the server does an RFC 1413 (ident) lookup to get the remote users system name. Generally for UNI* systems this is their login. The result is cached in $c->remote_logname then returned. Subsequent calls to $r->get_remote_host return the cached value.

If the configuration directive IdentityCheck is set to off: then $r->get_remote_logname does nothing and $c->remote_logname is always undefined.

$c->user
If an authentication check was successful, the authentication handler caches the user name here.
$c->auth_type
Returns the authentication scheme that successfully authenticate $c->user, if any.
$c->aborted
Returns true if the client stopped talking to us.

SERVER CONFIGURATION INFORMATION

The following methods are used to obtain information from server configuration and access control files. $r->dir_config( $key )
Returns the value of a per-directory variable specified by the PerlSetVar directive. 
   # 
   # SetPerlVar  Key  Value
   # 

   my $val = $r->dir_config('Key');
$r->requires
Returns an array reference of hash references, containing information related to the require directive. This is normally used for access control, see Apache for an example.
$r->auth_type
Returns a reference to the current value of the per directory configuration directive AuthType. Normally this would be set to Basic to use the basic authentication scheme defined in RFC 1945, Hypertext Transfer Protocol -- HTTP/1.0. However, you could set to something else and implement your own authentication scheme.
$r->auth_name
Returns a reference to the current value of the per directory configuration directive AuthName. The AuthName directive creates protection realm within the server document space. To quote RFC 1945 ``These realms allow the protected resources on a server to be partitioned into a set of protection spaces, each with its own authentication scheme and/or authorization database.'' The client uses the root URL of the server to determine which authentication credentials to send with each HTTP request. These credentials are tagged with the name of the authentication realm that created them. Then during the authentication stage the server uses the current authentication realm, from $r->auth_name, to determine which set of credentials to authenticate.
$r->document_root
Returns a reference to the current value of the per server configuration directive DocumentRoot. To quote the Apache server documentation, ``Unless matched by a directive like Alias, the server appends the path from the requested URL to the document root to make the path to the document.'' This same value is passed to CGI scripts in the DOCUMENT_ROOT environment variable.
$r->allow_options
The $r->allow_options method can be used for checking if it is OK to run a perl script. The Apache::Options module provides the constants to check against. 
   if(!($r->allow_options & OPT_EXECCGI)) {
 $r->log_reason("Options ExecCGI is off in this directory", 
    $filename);
   }
$s = $r->server
Return a reference to the server info object (blessed into the Apache::Server package). This is really a server_rec* in disguise. The following methods can be used on the server object:
$s = Apache->server
Same as above, but only available during server startup for use in sections, PerlScript or PerlModule.
$s->server_admin
Returns the mail address of the person responsible for this server.
$s->server_hostname
Returns the hostname used by this server.
$s->port
Returns the port that this servers listens too.
$s->is_virtual
Returns true if this is a virtual server.
$s->names
Returns the wild-carded names for HostAlias servers.
$s->warn
Alias for Apache::warn.
$s->log_error
Alias for Apache::log_error.
HTML-Mason-1.59/lib/0000755000175000017500000000000013660015140013671 5ustar autarchautarchHTML-Mason-1.59/lib/HTML/0000755000175000017500000000000013660015140014435 5ustar autarchautarchHTML-Mason-1.59/lib/HTML/Mason/0000755000175000017500000000000013660015140015512 5ustar autarchautarchHTML-Mason-1.59/lib/HTML/Mason/Apache/0000755000175000017500000000000013660015140016673 5ustar autarchautarchHTML-Mason-1.59/lib/HTML/Mason/Apache/Request.pm0000644000175000017500000000134613660015140020665 0ustar autarchautarch# -*- cperl-indent-level: 4; cperl-continued-brace-offset: -4; cperl-continued-statement-offset: 4 -*- # 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. package HTML::Mason::Apache::Request; $HTML::Mason::Apache::Request::VERSION = '1.59'; use strict; use warnings; use base 'Apache::Request'; sub new { my $class = shift; my $r = Apache::Request->instance(shift); return bless { r => $r }, $class; } sub send_http_header { my $self = shift; return if $self->notes('sent_http_header'); $self->SUPER::send_http_header(@_); $self->notes( 'sent_http_header' => 1 ); } 1; HTML-Mason-1.59/lib/HTML/Mason/Utils.pm0000644000175000017500000000473113660015140017155 0ustar autarchautarch# 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. # # Miscellaneous Mason-related utilities expected to be used by # external applications. # package HTML::Mason::Utils; $HTML::Mason::Utils::VERSION = '1.59'; use HTML::Mason::Tools qw(compress_path); use strict; use warnings; require Exporter; use vars qw(@ISA @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw(data_cache_namespace cgi_request_args); sub data_cache_namespace { my ($comp_id) = @_; return compress_path($comp_id); } sub cgi_request_args { my ($q, $method) = @_; my %args; # Checking that there really is no query string when the method is # not POST is important because otherwise ->url_param returns a # parameter named 'keywords' with a value of () (empty array). # This is apparently a feature related to queries or # something (see the CGI.pm) docs. It makes my head hurt. - dave my @methods = $method ne 'POST' || ! $ENV{QUERY_STRING} ? ( 'param' ) : ( 'param', 'url_param' ); foreach my $key ( map { $q->$_() } @methods ) { next if exists $args{$key}; local $CGI::LIST_CONTEXT_WARN = 0; my @values = map { $q->$_($key) } @methods; $args{$key} = @values == 1 ? $values[0] : \@values; } return wantarray ? %args : \%args; } 1; __END__ =head1 NAME HTML::Mason::Utils - Publicly available functions useful outside of Mason =head1 DESCRIPTION The functions in this module are useful when you need to interface code you have written with Mason. =head1 FUNCTIONS =over 4 =item data_cache_namespace ($comp_id) Given a component id, this method returns its default C namespace. This can be useful if you want to access the cached data outside of Mason. With a single component root, the component id is just the component path. With multiple component roots, the component id is C/C, where C is the key corresponding to the root that the component falls under. =item cgi_request_args ($cgi, $method) This function expects to receive a C object and the request method (GET, POST, etc). Given these two things, it will return a hash in list context or a hashref in scalar context. The hash(ref) will contain all the arguments passed via the CGI request. The keys will be argument names and the values will be either scalars or array references. =back =cut HTML-Mason-1.59/lib/HTML/Mason/Component.pm0000644000175000017500000004177613660015140020031 0ustar autarchautarch# 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. package HTML::Mason::Component; $HTML::Mason::Component::VERSION = '1.59'; use strict; use warnings; use File::Spec; use HTML::Mason::Exceptions( abbr => [qw(param_error)] ); use HTML::Mason::Tools qw(absolute_comp_path can_weaken); use Params::Validate qw(:all); Params::Validate::validation_options( on_fail => sub { param_error join '', @_ } ); use HTML::Mason::Exceptions( abbr => ['error'] ); use HTML::Mason::MethodMaker ( read_only => [ qw( code comp_id compiler_id declared_args inherit_path inherit_start_path has_filter load_time ) ], read_write => [ [ dynamic_subs_request => { isa => 'HTML::Mason::Request' } ], [ mfu_count => { type => SCALAR } ], [ filter => { type => CODEREF } ], ] ); # for reference later # # __PACKAGE__->valid_params # ( # attr => {type => HASHREF, default => {}, public => 0}, # code => {type => CODEREF, public => 0, public => 0}, # load_time => {type => SCALAR, optional => 1, public => 0}, # declared_args => {type => HASHREF, default => {}, public => 0}, # dynamic_subs_init => {type => CODEREF, default => sub {}, public => 0}, # flags => {type => HASHREF, default => {}, public => 0}, # comp_id => {type => SCALAR, optional => 1, public => 0}, # methods => {type => HASHREF, default => {}, public => 0}, # mfu_count => {type => SCALAR, default => 0, public => 0}, # parser_version => {type => SCALAR, optional => 1, public => 0}, # allows older components to be instantied # compiler_id => {type => SCALAR, optional => 1, public => 0}, # subcomps => {type => HASHREF, default => {}, public => 0}, # ); # my %defaults = ( attr => {}, declared_args => {}, dynamic_subs_init => sub {}, flags => {}, methods => {}, mfu_count => 0, subcomps => {}, ); sub new { my $class = shift; my $self = bless { %defaults, @_ }, $class; # Initialize subcomponent and method properties: owner, name, and # is_method flag. while (my ($name,$c) = each(%{$self->{subcomps}})) { $c->assign_subcomponent_properties($self,$name,0); Scalar::Util::weaken($c->{owner}) if can_weaken; } while (my ($name,$c) = each(%{$self->{methods}})) { $c->assign_subcomponent_properties($self,$name,1); Scalar::Util::weaken($c->{owner}) if can_weaken; } return $self; } my $comp_count = 0; sub assign_runtime_properties { my ($self, $interp, $source) = @_; $self->interp($interp); $self->{comp_id} = defined $source->comp_id ? $source->comp_id : "[anon ". ++$comp_count . "]"; $self->{path} = $source->comp_path; $self->_determine_inheritance; foreach my $c (values(%{$self->{subcomps}}), values(%{$self->{methods}})) { $c->assign_runtime_properties($interp, $source); } # Cache of uncanonicalized call paths appearing in the # component. Used in $m->fetch_comp. # if ($interp->use_internal_component_caches) { $self->{fetch_comp_cache} = {}; } } sub flush_internal_caches { my ($self) = @_; $self->{fetch_comp_cache} = {}; delete($self->{parent_cache}); } sub _determine_inheritance { my $self = shift; my $interp = $self->interp; # Assign inheritance properties if (exists($self->{flags}->{inherit})) { if (defined($self->{flags}->{inherit})) { $self->{inherit_path} = absolute_comp_path($self->{flags}->{inherit}, $self->dir_path); } } elsif ( $interp->use_autohandlers ) { if ($self->name eq $interp->autohandler_name) { unless ($self->dir_path eq '/') { ($self->{inherit_start_path}) = $self->dir_path =~ m,^(.*/)?.*,s } } else { $self->{inherit_start_path} = $self->dir_path; } } } sub run { my $self = shift; $self->{mfu_count}++; $self->{code}->(@_); } sub dynamic_subs_init { my $self = shift; error "cannot call a method or subcomponent from a <%shared> block" if $self->{in_dynamic_subs_init}; local $self->{in_dynamic_subs_init} = 1; $self->{dynamic_subs_hash} = $self->{dynamic_subs_init}->(); error "could not process <%shared> section (does it contain a return()?)" unless ref($self->{dynamic_subs_hash}) eq 'HASH'; } sub run_dynamic_sub { my ($self, $key, @args) = @_; error "call_dynamic: assert error - could not find code for key $key in component " . $self->title unless exists $self->{dynamic_subs_hash}->{$key}; return $self->{dynamic_subs_hash}->{$key}->(@args); } # Legacy, left in for pre-0.8 obj files sub assign_subcomponent_properties {} # # By default components are not persistent. # sub persistent { 0 } # # Only true in Subcomponent subclass. # sub is_subcomp { 0 } sub is_method { 0 } # # Only true in FileBased subclass. # sub is_file_based { 0 } # # Basic defaults for component designators: title, path, name, dir_path # sub title { return $_[0]->{comp_id} } sub name { return $_[0]->{comp_id} } sub path { return undef } sub dir_path { return undef } # # Get all subcomps or particular subcomp by name # sub subcomps { my ($self,$key) = @_; if (defined($key)) { return $self->{subcomps}->{$key}; } else { return $self->{subcomps}; } } # # Get all methods or particular method by name # sub methods { my ($self,$key) = @_; if (defined($key)) { return $self->{methods}->{$key}; } else { return $self->{methods}; } } # # Get all attributes # sub attributes { $_[0]->{attr} } # # Get attribute by name # sub attr { my ($self,$name) = @_; my $value; if ($self->_locate_inherited('attr',$name,\$value)) { return $value; } else { error "no attribute '$name' for component " . $self->title; } } sub attr_if_exists { my ($self,$name) = @_; my $value; if ($self->_locate_inherited('attr',$name,\$value)) { return $value; } else { return undef; } } # # Determine if particular attribute exists # sub attr_exists { my ($self,$name) = @_; return $self->_locate_inherited('attr',$name); } # # Call method by name # sub call_method { my ($self,$name,@args) = @_; my $method; if ($self->_locate_inherited('methods',$name,\$method)) { HTML::Mason::Request->instance->comp({base_comp=>$self},$method,@args); } else { error "no method '$name' for component " . $self->title; } } # # Like call method, but return component output. # sub scall_method { my ($self,$name,@args) = @_; my $method; if ($self->_locate_inherited('methods',$name,\$method)) { HTML::Mason::Request->instance->scomp({base_comp=>$self},$method,@args); } else { error "no method '$name' for component " . $self->title; } } # # Determine if particular method exists # sub method_exists { my ($self,$name) = @_; return $self->_locate_inherited('methods',$name); } # # Locate a component slot element following inheritance path # sub _locate_inherited { my ($self,$field,$key,$ref) = @_; my $count = 0; for (my $comp = $self; $comp; $comp = $comp->parent) { if (exists($comp->{$field}->{$key})) { $$ref = $comp->{$field}->{$key} if $ref; return 1; } error "inheritance chain length > 32 (infinite inheritance loop?)" if ++$count > 32; } return 0; } # # Get particular flag by name # sub flag { my ($self,$name) = @_; my %flag_defaults = ( ); if (exists($self->{flags}->{$name})) { return $self->{flags}->{$name}; } elsif (exists($flag_defaults{$name})) { return $flag_defaults{$name}; } else { error "invalid flag: $name"; } } # # Return parent component according to inherit flag. # sub parent { my ($self) = @_; # Return cached value for parent, if any (may be undef) # return $self->{parent_cache} if exists($self->{parent_cache}); my $interp = $self->interp; my $parent; if ($self->inherit_path) { $parent = $interp->load($self->inherit_path) or error(sprintf("cannot find inherit path '%s' for component '%s'", $self->inherit_path, $self->title)); } elsif ($self->inherit_start_path) { $parent = $interp->find_comp_upwards($self->inherit_start_path, $interp->autohandler_name); } # Can only cache parent value if interp->{use_internal_component_caches} is on - # see definition in Interp::_initialize. # if ($interp->use_internal_component_caches) { $self->{parent_cache} = $parent; } return $parent; } sub interp { my $self = shift; if (@_) { validate_pos( @_, { isa => 'HTML::Mason::Interp' } ); $self->{interp} = $_[0]; Scalar::Util::weaken( $self->{interp} ) if can_weaken; } elsif ( ! defined $self->{interp} ) { die "The Interp object that this object contains has gone out of scope.\n"; } return $self->{interp}; } # # Accessors for various files associated with component # sub object_file { my $self = shift; return $self->interp->object_file($self); } # For backwards compatibility with 1.0x sub create_time { my $self = shift; return $self->load_time(@_); } # Create logger on demand - generally called from $m->log sub logger { my ($self) = @_; if (!$self->{logger}) { my $log_category = "HTML::Mason::Component" . $self->path(); $log_category =~ s/\//::/g; $self->{logger} = Log::Any->get_logger(category => $log_category); } return $self->{logger}; } 1; __END__ =head1 NAME HTML::Mason::Component - Mason Component Class =head1 SYNOPSIS my $comp1 = $m->current_comp; my $comp2 = $m->callers(1); my $comp3 = $m->fetch_comp('foo/bar'); foreach ($comp1,$comp2,$comp3) { print "My name is ".$_->title.".\n"; } =head1 DESCRIPTION Mason uses the Component class to store components loaded into memory. Components come from three distinct sources: =over 4 =item 1 File-based: loaded from a source or object file. =item 2 Subcomponents: embedded components defined with the C%defE> or C%methodE> tags. =item 3 Anonymous: created on-the-fly with the C Interp method. =back Some of the methods below return different values (or nothing at all) depending on the component type. The component API is primarily useful for introspection, e.g. "what component called me" or "does the next component take a certain argument". You can build complex Mason sites without ever dealing directly with a component object. =head2 CREATING AND ACCESSING COMPONENTS Common ways to get handles on existing component objects include the Lcurrent_comp|HTML::Mason::Request/item_current_comp>, Lcallers|HTML::Mason::Request/item_callers>, and Lfetch_comp|HTML::Mason::Request/item_fetch_comp> methods. There is no published C method, because creating a component requires an Interpreter. Use the L method to create a new component dynamically. Similarly, there is no C or C method, because calling a component requires a request. All of the interfaces for calling a component (C<< <& &> >>, C<< $m->comp >>, C<< $interp->exec >>) which normally take a component path will also take a component object. =head1 METHODS =over =item attr (name) Looks for the specified attribute in this component and its parents, returning the first value found. Dies with an error if not found. Attributes are declared in the C%attrE> section. =item attr_if_exists (name) This method works exactly like the one above but returns undef if the attribute does not exist. =item attr_exists (name) Returns true if the specified attribute exists in this component or one of its parents, undef otherwise. =item attributes Returns a hashref containing the attributes defined in this component, with the attribute names as keys. This does not return attributes inherited from parent components. =item call_method (name, args...) Looks for the specified user-defined method in this component and its parents, calling the first one found. Dies with an error if not found. Methods are declared in the C%methodE> section. =item create_time A synonym for L (deprecated). =item declared_args Returns a reference to a hash of hashes representing the arguments declared in the C%argsE> section. The keys of the main hash are the variable names including prefix (e.g. C<$foo>, C<@list>). Each secondary hash contains: =over 4 =item * 'default': the string specified for default value (e.g. 'fido') or undef if none specified. Note that in general this is not the default value itself but rather a Perl expression that gets evaluated every time the component runs. =back For example: # does $comp have an argument called $fido? if (exists($comp->declared_args->{'$fido'})) { ... } # does $fido have a default value? if (defined($comp->declared_args->{'$fido'}->{default})) { ... } =item dir_path Returns the component's notion of a current directory, relative to the component root; this is used to resolve relative component paths. For file-based components this is the full component path minus the filename. For subcomponents this is the same as the component that defines it. Undefined for anonymous components. =item flag (name) Returns the value for the specified system flag. Flags are declared in the C%flagsE> section and affect the behavior of the component. Unlike attributes, flags values do not get inherited from parent components. =item is_subcomp Returns true if this is a subcomponent of another component. For historical reasons, this returns true for both methods and subcomponents. =item is_method Returns true if this is a method. =item is_file_based Returns true if this component was loaded from a source or object file. =for html =item load_time Returns the time (in Perl time() format) when this component object was created. =item method_exists (name) Returns true if the specified user-defined method exists in this component or one of its parents, undef otherwise. =item methods This method works exactly like the L method, but it returns methods, not subcomponents. This does not return methods inherited from parent components. Methods are declared in C%methodE> sections. =item name Returns a short name of the component. For file-based components this is the filename without the path. For subcomponents this is the name specified in C%defE>. Undefined for anonymous components. =item object_file Returns the object filename for this component. =item parent Returns the parent of this component for inheritance purposes, by default the nearest C in or above the component's directory. Can be changed via the C flag. =item path Returns the entire path of this component, relative to the component root. =item scall_method (name, args...) Like L, but returns the method output as a string instead of printing it. (Think sprintf versus printf.) The method's return value, if any, is discarded. =for html =item subcomps With no arguments, returns a hashref containing the subcomponents defined in this component, with names as keys and component objects as values. With one argument, returns the subcomponent of that name or undef if no such subcomponent exists. e.g. if (my $subcomp = $comp->subcomps('.link')) { ... } Subcomponents are declared in C%defE> sections. =item title Returns a printable string denoting this component. It is intended to uniquely identify a component within a given interpreter although this is not 100% guaranteed. Mason uses this string in error messages, among other places. For file-based components this is the component path. For subcomponents this is "parent_component_path:subcomponent_name". For anonymous components this is a unique label like "[anon 17]". =back =head1 FILE-BASED METHODS The following methods apply only to file-based components (those loaded from source or object files). They return undef for other component types. =over =item source_file Returns the source filename for this component. =item source_dir Returns the directory of the source filename for this component. =back =cut HTML-Mason-1.59/lib/HTML/Mason/CGIHandler.pm0000644000175000017500000004530513660015140017757 0ustar autarchautarchpackage HTML::Mason::CGIHandler; $HTML::Mason::CGIHandler::VERSION = '1.59'; use strict; use warnings; use HTML::Mason; use HTML::Mason::Utils; use CGI 2.46; use File::Spec; use Params::Validate qw(:all); use HTML::Mason::Exceptions; use HTML::Mason::FakeApache; use Class::Container; use base qw(Class::Container); use HTML::Mason::MethodMaker ( read_write => [ qw( interp ) ] ); __PACKAGE__->valid_params ( interp => { isa => 'HTML::Mason::Interp' }, ); __PACKAGE__->contained_objects ( interp => 'HTML::Mason::Interp', cgi_request => { class => 'HTML::Mason::FakeApache', # $r delayed => 1 }, ); sub new { my $package = shift; my %p = @_; my $self = $package->SUPER::new(comp_root => $ENV{DOCUMENT_ROOT}, request_class => 'HTML::Mason::Request::CGI', error_mode => 'output', error_format => 'html', %p); $self->{has_custom_out_method} = $p{out_method} ? 1 : 0; $self->interp->compiler->add_allowed_globals('$r'); return $self; } sub handle_request { my $self = shift; $self->_handler( { comp => $ENV{PATH_INFO} }, @_ ); } sub handle_comp { my ($self, $comp) = (shift, shift); $self->_handler( { comp => $comp }, @_ ); } sub handle_cgi_object { my ($self, $cgi) = (shift, shift); $self->_handler( { comp => $cgi->path_info, cgi => $cgi }, @_); } sub _handler { my ($self, $p) = (shift, shift); my $r = $self->create_delayed_object('cgi_request', cgi => $p->{cgi}); $self->interp->set_global('$r', $r); # hack for testing if (@_) { $self->{output} = ''; $self->interp->out_method( \$self->{output} ); } elsif (! $self->{has_custom_out_method}) { my $sent_headers = 0; my $out_method = sub { # Send headers if they have not been sent by us or by user. # We use instance here because if we store $request we get a # circular reference and a big memory leak. if (!$sent_headers and HTML::Mason::Request->instance->auto_send_headers) { $r->send_http_header(); $sent_headers = 1; } # We could perhaps install a new, faster out_method here that # wouldn't have to keep checking whether headers have been # sent and what the $r->method is. That would require # additions to the Request interface, though. print STDOUT grep {defined} @_; }; $self->interp->out_method($out_method); } $self->interp->delayed_object_params('request', cgi_request => $r); my %args = $self->request_args($r); my @result; if (wantarray) { @result = eval { $self->interp->exec($p->{comp}, %args) }; } elsif ( defined wantarray ) { $result[0] = eval { $self->interp->exec($p->{comp}, %args) }; } else { eval { $self->interp->exec($p->{comp}, %args) }; } if (my $err = $@) { my $retval = isa_mason_exception($err, 'Abort') ? $err->aborted_value : isa_mason_exception($err, 'Decline') ? $err->declined_value : rethrow_exception $err; # Unlike under mod_perl, we cannot simply return a 301 or 302 # status and let Apache send headers, we need to explicitly # send this header ourself. $r->send_http_header if $retval && grep { $retval eq $_ } ( 200, 301, 302 ); return $retval; } if (@_) { # This is a secret feature, and should stay secret (or go # away) because it's just a hack for the test suite. $_[0] .= $r->http_header . $self->{output}; } return wantarray ? @result : defined wantarray ? $result[0] : undef; } # This is broken out in order to make subclassing easier. sub request_args { my ($self, $r) = @_; return $r->params; } ########################################################### package HTML::Mason::Request::CGI; # Subclass for HTML::Mason::Request object $m $HTML::Mason::Request::CGI::VERSION = '1.59'; use HTML::Mason::Exceptions; use HTML::Mason::Request; use base qw(HTML::Mason::Request); use Params::Validate qw(BOOLEAN); Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } ); __PACKAGE__->valid_params ( cgi_request => { isa => 'HTML::Mason::FakeApache' }, auto_send_headers => { parse => 'boolean', type => BOOLEAN, default => 1, descr => "Whether HTTP headers should be auto-generated" }, ); use HTML::Mason::MethodMaker ( read_only => [ 'cgi_request' ], read_write => [ 'auto_send_headers' ] ); sub cgi_object { my $self = shift; return $self->{cgi_request}->query(@_); } # # Override this method to send HTTP headers if necessary. # sub exec { my $self = shift; my $r = $self->cgi_request; my $retval; eval { $retval = $self->SUPER::exec(@_) }; if (my $err = $@) { $retval = isa_mason_exception($err, 'Abort') ? $err->aborted_value : isa_mason_exception($err, 'Decline') ? $err->declined_value : rethrow_exception $err; } # On a success code, send headers if they have not been sent and # if we are the top-level request. Since the out_method sends # headers, this will typically only apply after $m->abort. if (!$self->is_subrequest and $self->auto_send_headers and !$r->http_header_sent and (!$retval or $retval==200)) { $r->send_http_header(); } return $retval; } sub redirect { my $self = shift; my $url = shift; my $status = shift || 302; $self->clear_buffer; $self->{cgi_request}->header_out( Location => $url ); $self->{cgi_request}->header_out( Status => $status ); $self->abort; } 1; __END__ =head1 NAME HTML::Mason::CGIHandler - Use Mason in a CGI environment =head1 SYNOPSIS In httpd.conf or .htaccess: Action html-mason /cgi-bin/mason_handler.cgi AddHandler html-mason .html RemoveHandler .html Order allow,deny Deny from all A script at /cgi-bin/mason_handler.pl : #!/usr/bin/perl use HTML::Mason::CGIHandler; my $h = HTML::Mason::CGIHandler->new ( data_dir => '/home/jethro/code/mason_data', allow_globals => [qw(%session $u)], ); $h->handle_request; A .html component somewhere in the web server's document root: <%args> $mood => 'satisfied' % $r->err_header_out(Location => "http://blahblahblah.com/moodring/$mood.html"); ... =head1 DESCRIPTION This module lets you execute Mason components in a CGI environment. It lets you keep your top-level components in the web server's document root, using regular component syntax and without worrying about the particular details of invoking Mason on each request. If you want to use Mason components from I a regular CGI script (or any other Perl program, for that matter), then you don't need this module. You can simply follow the directions in the L section of the administrator's manual. This module also provides an C<$r> request object for use inside components, similar to the Apache request object under C, but limited in functionality. Please note that we aim to replicate the C functionality as closely as possible - if you find differences, do I depend on them to stay different. We may fix them in a future release. Also, if you need some missing functionality in C<$r>, let us know, we might be able to provide it. Finally, this module alters the C object C<$m> to provide direct access to the CGI query, should such access be necessary. =head2 C Methods =over 4 =item * new() Creates a new handler. Accepts any parameter that the Interpreter accepts. If no C parameter is passed to C, the component root will be C<$ENV{DOCUMENT_ROOT}>. =item * handle_request() Handles the current request, reading input from C<$ENV{QUERY_STRING}> or C and sending headers and component output to C. This method doesn't accept any parameters. The initial component will be the one specified in C<$ENV{PATH_INFO}>. =item * handle_comp() Like C, but the first (only) parameter is a component path or component object. This is useful within a traditional CGI environment, in which you're essentially using Mason as a templating language but not an application server. C will create a CGI query object, parse the query parameters, and send the HTTP header and component output to STDOUT. If you want to handle those parts yourself, see the L section of the administrator's manual. =item * handle_cgi_object() Also like C, but this method takes only a CGI object as its parameter. This can be quite useful if you want to use this module with CGI::Fast. The component path will be the value of the CGI object's C method. =item * request_args() Given an C object, this method is expected to return a hash containing the arguments to be passed to the component. It is a separate method in order to make it easily overrideable in a subclass. =item * interp() Returns the Mason Interpreter associated with this handler. The Interpreter lasts for the entire lifetime of the handler. =back =head2 $r Methods =over 4 =item * headers_in() This works much like the C method of the same name. In an array context, it will return a C<%hash> of response headers. In a scalar context, it will return a reference to the case-insensitive hash blessed into the C class. The values initially populated in this hash are extracted from the CGI environment variables as best as possible. The pattern is to merely reverse the conversion from HTTP headers to CGI variables as documented here: L. =item * header_in() This works much like the C method of the same name. When passed the name of a header, returns the value of the given incoming header. When passed a name and a value, sets the value of the header. Setting the header to C will actually I the header (instead of setting its value to C), removing it from the table of headers returned from future calls to C or C. =item * headers_out() This works much like the C method of the same name. In an array context, it will return a C<%hash> of response headers. In a scalar context, it will return a reference to the case-insensitive hash blessed into the C class. Changes made to this hash will be made to the headers that will eventually be passed to the C module's C method. =item * header_out() This works much like the C method of the same name. When passed the name of a header, returns the value of the given outgoing header. When passed a name and a value, sets the value of the header. Setting the header to C will actually I the header (instead of setting its value to C), removing it from the table of headers that will be sent to the client. The headers are eventually passed to the C module's C method. =item * err_headers_out() This works much like the C method of the same name. In an array context, it will return a C<%hash> of error response headers. In a scalar context, it will return a reference to the case-insensitive hash blessed into the C class. Changes made to this hash will be made to the error headers that will eventually be passed to the C module's C method. =item * err_header_out() This works much like the C method of the same name. When passed the name of a header, returns the value of the given outgoing error header. When passed a name and a value, sets the value of the error header. Setting the header to C will actually I the header (instead of setting its value to C), removing it from the table of headers that will be sent to the client. The headers are eventually passed to the C module's C method. One header currently gets special treatment - if you set a C header, you'll cause the C module's C method to be used instead of the C method. This means that in order to do a redirect, all you need to do is: $r->err_header_out(Location => 'http://redirect.to/here'); You may be happier using the C<< $m->redirect >> method, though, because it hides most of the complexities of sending headers and getting the status code right. =item * content_type() When passed an argument, sets the content type of the current request to the value of the argument. Use this method instead of setting a C header directly with C. Like C, setting the content type to C will remove any content type set previously. When called without arguments, returns the value set by a previous call to C. The behavior when C hasn't already been set is undefined - currently it returns C. If no content type is set during the request, the default MIME type C will be used. =item * method() Returns the request method used for the current request, e.g., "GET", "POST", etc. =item * http_header() This method returns the outgoing headers as a string, suitable for sending to the client. =item * send_http_header() Sends the outgoing headers to the client. =item * notes() This works much like the C method of the same name. When passed a C<$key> argument, it returns the value of the note for that key. When passed a C<$value> argument, it stores that value under the key. Keys are case-insensitive, and both the key and the value must be strings. When called in a scalar context with no C<$key> argument, it returns a hash reference blessed into the C class. =item * pnotes() Like C, but takes any scalar as an value, and stores the values in a case-sensitive hash. =item * subprocess_env() Works like the C method of the same name, but is simply populated with the current values of the environment. Still, it's useful, because values can be changed and then seen by later components, but the environment itself remains unchanged. Like the C method, it will reset all of its values to the current environment again if it's called without a C<$key> argument. =item * params() This method returns a hash containing the parameters sent by the client. Multiple parameters of the same name are represented by array references. If both POST and query string arguments were submitted, these will be merged together. =back =head2 Added C<$m> methods The C<$m> object provided in components has all the functionality of the regular C object C<$m>, and the following: =over 4 =item * cgi_object() Returns the current C request object. This is handy for processing cookies or perhaps even doing HTML generation (but is that I what you want to do?). If you pass an argument to this method, you can set the request object to the argument passed. Use this with care, as it may affect components called after the current one (they may check the content length of the request, for example). Note that the ApacheHandler class (for using Mason under mod_perl) also provides a C method that does the same thing as this one. This makes it easier to write components that function equally well under CGIHandler and ApacheHandler. =item * cgi_request() Returns the object that is used to emulate Apache's request object. In other words, this is the object that C<$r> is set to when you use this class. =back =head2 C Methods This class emulates the behavior of the C class, and is used to store manage the tables of values for the following attributes of <$r>: =over 4 =item headers_in =item headers_out =item err_headers_out =item notes =item subprocess_env =back C is designed to behave exactly like C, and differs in only one respect. When a given key has multiple values in an C object, one can fetch each of the values for that key using Perl's C operator: while (my ($k, $v) = each %{$r->headers_out}) { push @cookies, $v if lc $k eq 'set-cookie'; } If anyone knows how Apache::Table does this, let us know! In the meantime, use C or C to get at all of the values for a given key (C is much more efficient, anyway). Since the methods named for these attributes return an C object hash in a scalar reference, it seemed only fair to document its interface. =over 4 =item * new() Returns a new C object. Any parameters passed to C will be added to the table as initial values. =item * add() Adds a new value to the table. If the value did not previously exist under the given key, it will be created. Otherwise, it will be added as a new value to the key. =item * clear() Clears the table of all values. =item * do() Pass a code reference to this method to have it iterate over all of the key/value pairs in the table. Keys will multiple values will trigger the execution of the code reference multiple times for each value. The code reference should expect two arguments: a key and a value. Iteration terminates when the code reference returns false, to be sure to have it return a true value if you wan it to iterate over every value in the table. =item * get() Gets the value stored for a given key in the table. If a key has multiple values, all will be returned when C is called in an array context, and only the first value when it is called in a scalar context. =item * merge() Merges a new value with an existing value by concatenating the new value onto the existing. The result is a comma-separated list of all of the values merged for a given key. =item * set() Takes key and value arguments and sets the value for that key. Previous values for that key will be discarded. The value must be a string, or C will turn it into one. A value of C will have the same behavior as C. =item * unset() Takes a single key argument and deletes that key from the table, so that none of its values will be in the table any longer. =back =cut HTML-Mason-1.59/lib/HTML/Mason/Compiler/0000755000175000017500000000000013660015140017264 5ustar autarchautarchHTML-Mason-1.59/lib/HTML/Mason/Compiler/ToObject.pm0000644000175000017500000005030713660015140021340 0ustar autarchautarch# 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. package HTML::Mason::Compiler::ToObject; $HTML::Mason::Compiler::ToObject::VERSION = '1.59'; use strict; use warnings; use Params::Validate qw(BOOLEAN SCALAR validate); use HTML::Mason::Tools qw(taint_is_on); use HTML::Mason::Compiler; use base qw( HTML::Mason::Compiler ); use HTML::Mason::Exceptions( abbr => [qw(wrong_compiler_error system_error)] ); use File::Path qw(mkpath rmtree); use File::Basename qw(dirname); BEGIN { __PACKAGE__->valid_params ( comp_class => { parse => 'string', type => SCALAR, default => 'HTML::Mason::Component', descr => "The class into which component objects will be blessed" }, subcomp_class => { parse => 'string', type => SCALAR, default => 'HTML::Mason::Component::Subcomponent', descr => "The class into which subcomponent objects will be blessed" }, in_package => { parse => 'string', type => SCALAR, default => 'HTML::Mason::Commands', descr => "The package in which component execution will take place" }, preamble => { parse => 'string', type => SCALAR, default => '', descr => "A chunk of Perl code to add to the beginning of each compiled component" }, postamble => { parse => 'string', type => SCALAR, default => '', descr => "A chunk of Perl code to add to the end of each compiled component" }, use_strict => { parse => 'boolean', type => SCALAR, default => 1, descr => "Whether to turn on Perl's 'strict' pragma in components" }, use_warnings => { parse => 'boolean', type => SCALAR, default => 0, descr => "Whether to turn on Perl's 'warnings' pragma in components" }, define_args_hash => { parse => 'string', type => SCALAR, default => 'auto', regex => qr/^(?:always|auto|never)$/, descr => "Whether or not to create the %ARGS hash" }, named_component_subs => { parse => 'boolean', type => BOOLEAN, default => 0, descr => "Whether to use named subroutines for component code" }, ); } use HTML::Mason::MethodMaker ( read_only => [ qw( comp_class define_args_hash in_package named_component_subs postamble preamble subcomp_class use_strict use_warnings ) ], ); sub compile { my $self = shift; my %p = @_; local $self->{comp_class} = delete $p{comp_class} if exists $p{comp_class}; return $self->SUPER::compile( %p ); } # # compile_to_file( source => ..., file => ... ) # Save object text in an object file. # # We attempt to handle several cases in which a file already exists # and we wish to create a directory, or vice versa. However, not # every case is handled; to be complete, mkpath would have to unlink # any existing file in its way. # sub compile_to_file { my $self = shift; my %p = validate( @_, { file => { type => SCALAR }, source => { isa => 'HTML::Mason::ComponentSource' } }, ); my ($file, $source) = @p{qw(file source)}; my @newfiles = ($file); if (defined $file && !-f $file) { my ($dirname) = dirname($file); if (!-d $dirname) { unlink($dirname) if (-e _); push @newfiles, mkpath($dirname, 0, 0775); system_error "Couldn't create directory $dirname: $!" unless -d $dirname; } rmtree($file) if (-d $file); } ($file) = $file =~ /^(.*)/s if taint_is_on; # Untaint blindly open my $fh, "> $file" or system_error "Couldn't create object file $file: $!"; $self->compile( comp_source => $source->comp_source_ref, name => $source->friendly_name, comp_class => $source->comp_class, comp_path => $source->comp_path, fh => $fh ); close $fh or system_error "Couldn't close object file $file: $!"; return \@newfiles; } sub _output_chunk { my ($self, $fh, $string) = (shift, shift, shift); if ($fh) { print $fh (ref $_ ? $$_ : $_) foreach grep defined, @_; } else { $$string .= (ref $_ ? $$_ : $_) foreach @_; } } # There are some really spooky relationships between the variables & # data members in the compiled_component() routine. sub compiled_component { my ($self, %p) = @_; my $c = $self->{current_compile}; my $obj_text = ''; local $c->{compiled_def} = $self->_compile_subcomponents if %{ $c->{def} }; local $c->{compiled_method} = $self->_compile_methods if %{ $c->{method} }; # Some preamble stuff, including 'use strict', 'use vars', and <%once> block my $header = $self->_make_main_header; $self->_output_chunk($p{fh}, \$obj_text, $header); my $params = $self->_component_params; $params->{load_time} = time; $params->{subcomps} = '\%_def' if %{ $c->{def} }; $params->{methods} = '\%_method' if %{ $c->{method} }; if ( $self->_blocks('shared') ) { my %subs; while ( my ($name, $pref) = each %{ $c->{compiled_def} } ) { my $key = "subcomponent_$name"; $subs{$key} = $pref->{code}; $pref->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic('$key',\@_)\n}"; } while (my ($name, $pref) = each %{ $c->{compiled_method} } ) { my $key = "method_$name"; $subs{$key} = $pref->{code}; $pref->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic( '$key', \@_ )\n}"; } $subs{main} = $params->{code}; $params->{code} = "sub {\nHTML::Mason::Request->instance->call_dynamic( 'main', \@_ )\n}"; my $named_subs = ''; my %named_subs = $self->_named_subs_hash; while ( my ( $name, $body ) = each %named_subs ) { $named_subs .= '*' . $name . " = sub {\n" . $body . "\n};\n\n"; } $params->{dynamic_subs_init} = join '', ( "sub {\n", $self->_set_request, $self->_blocks('shared'), $named_subs, "return {\n", map( "'$_' => $subs{$_},\n", sort keys %subs ), "\n}\n}" ); } else { my %named_subs = $self->_named_subs_hash; while ( my ( $name, $body ) = each %named_subs ) { $self->_output_chunk( $p{fh}, \$obj_text, "sub $name {\n" . $body . "\n}\n" ); } } $self->_output_chunk($p{fh}, \$obj_text, $self->_subcomponents_footer); $self->_output_chunk($p{fh}, \$obj_text, $self->_methods_footer); $self->_output_chunk($p{fh}, \$obj_text, $self->_constructor( $self->comp_class, $params ), ';', ); return \$obj_text; } sub _named_subs_hash { my $self = shift; return unless $self->named_component_subs; my %subs; $subs{ $self->_sub_name } = $self->_body; while ( my ( $name, $params ) = each %{ $self->{current_compile}{compiled_def} } ) { $subs{ $self->_sub_name( 'def', $name ) } = $params->{body}; } while ( my ( $name, $params ) = each %{ $self->{current_compile}{compiled_method} } ) { $subs{ $self->_sub_name( 'method', $name ) } = $params->{body}; } return %subs; } sub _sub_name { my $self = shift; return join '_', $self->_escape_sub_name_part( $self->{comp_path}, @_ ); } sub _escape_sub_name_part { my $self = shift; return map { my $part = $_; $part =~ s/([^\w_])/'_' . sprintf( '%x', ord $1 )/ge; $part; } @_; } sub _compile_subcomponents { my $self = shift; return $self->_compile_subcomponents_or_methods('def'); } sub _compile_methods { my $self = shift; return $self->_compile_subcomponents_or_methods('method'); } sub _compile_subcomponents_or_methods { my $self = shift; my $type = shift; my %compiled; foreach ( keys %{ $self->{current_compile}{$type} } ) { local $self->{current_compile} = $self->{current_compile}{$type}{$_}; local $self->{current_compile}->{in_named_block} = {type => $type, name => $_}; $compiled{$_} = $self->_component_params; } return \%compiled; } sub _make_main_header { my $self = shift; my $pkg = $self->in_package; return join '', ( "package $pkg;\n", $self->use_strict ? "use strict;\n" : "no strict;\n", $self->use_warnings ? "use warnings;\n" : "", sprintf( "use vars qw(\%s);\n", join ' ', '$m', $self->allow_globals ), $self->_blocks('once'), ); } sub _subcomponents_footer { my $self = shift; return $self->_subcomponent_or_method_footer('def'); } sub _methods_footer { my $self = shift; return $self->_subcomponent_or_method_footer('method'); } sub _subcomponent_or_method_footer { my $self = shift; my $c = $self->{current_compile}; my $type = shift; return '' unless %{ $c->{$type} }; return join('', "my %_$type =\n(\n", map( {("'$_' => " , $self->_constructor( $self->{subcomp_class}, $c->{"compiled_$type"}{$_} ) , ",\n")} keys %{ $c->{"compiled_$type"} } ) , "\n);\n" ); } sub _constructor { my ($self, $class, $params) = @_; return ("${class}->new(\n", map( {("'$_' => ", $params->{$_}, ",\n")} sort grep { $_ ne 'body' } keys %$params ), "\n)\n", ); } sub _component_params { my $self = shift; my %params; if ( $self->named_component_subs ) { $params{code} = '\\&' . $self->_sub_name ( grep { defined } @{ $self->{current_compile}{in_named_block} } { 'type', 'name' } ); $params{body} = $self->_body; } else { $params{code} = join '', "sub {\n", $self->_body, "}"; } $params{flags} = join '', "{\n", $self->_flags, "\n}" if keys %{ $self->{current_compile}{flags} }; $params{attr} = join '', "{\n", $self->_attr, "\n}" if keys %{ $self->{current_compile}{attr} }; $params{declared_args} = join '', "{\n", $self->_declared_args, "\n}" if @{ $self->{current_compile}{args} }; $params{has_filter} = 1 if $self->_blocks('filter'); return \%params; } sub _body { my $self = shift; return join '', ( $self->preamble, $self->_set_request, $self->_set_buffer, $self->_arg_declarations, $self->_filter, "\$m->debug_hook( \$m->current_comp->path ) if ( HTML::Mason::Compiler::IN_PERL_DB() );\n\n", $self->_blocks('init'), # do not add a block around this, it introduces # a separate scope and might break cleanup # blocks (or all sort of other things!) $self->{current_compile}{body}, $self->_blocks('cleanup'), $self->postamble, # semi before return will help catch syntax # errors in component body - don't return values # explicitly ";return;\n", ); } sub _set_request { my $self = shift; return if $self->in_package eq 'HTML::Mason::Commands'; return 'local $' . $self->in_package . '::m = $HTML::Mason::Commands::m;' . "\n"; } sub _set_buffer { my $self = shift; if ($self->enable_autoflush) { return ''; } else { return 'my $_outbuf = $m->{top_stack}->[HTML::Mason::Request::STACK_BUFFER];' . "\n"; } } my %coercion_funcs = ( '@' => 'HTML::Mason::Tools::coerce_to_array', '%' => 'HTML::Mason::Tools::coerce_to_hash', ); sub _arg_declarations { my $self = shift; my $init; my @args_hash; my $pos; my @req_check; my @decl; my @assign; my $define_args_hash = $self->_define_args_hash; unless ( @{ $self->{current_compile}{args} } ) { return unless $define_args_hash; return ( "my \%ARGS;\n", "{ local \$^W; \%ARGS = \@_ unless (\@_ % 2); }\n" ); } $init = <<'EOF'; HTML::Mason::Exception::Params->throw ( error => "Odd number of parameters passed to component expecting name/value pairs" ) if @_ % 2; EOF if ( $define_args_hash ) { @args_hash = "my \%ARGS = \@_;\n"; } # opening brace will be closed later. we want this in a separate # block so that the rest of the component can't see %pos $pos = <<'EOF'; { my %pos; for ( my $x = 0; $x < @_; $x += 2 ) { $pos{ $_[$x] } = $x + 1; } EOF my @required = ( map { $_->{name} } grep { ! defined $_->{default} } @{ $self->{current_compile}{args} } ); if (@required) { # just to be sure local $" = ' '; @req_check = <<"EOF"; foreach my \$arg ( qw( @required ) ) { HTML::Mason::Exception::Params->throw ( error => "no value sent for required parameter '\$arg'" ) unless exists \$pos{\$arg}; } EOF } foreach ( @{ $self->{current_compile}{args} } ) { my $var_name = "$_->{type}$_->{name}"; push @decl, $var_name; my $arg_in_array = "\$_[ \$pos{'$_->{name}'} ]"; my $coerce; if ( $coercion_funcs{ $_->{type} } ) { $coerce = $coercion_funcs{ $_->{type} } . "( $arg_in_array, '$var_name')"; } else { $coerce = $arg_in_array; } if ( defined $_->{line} && defined $_->{file} && $self->use_source_line_numbers ) { my $file = $self->_escape_filename( $_->{file} ); push @assign, qq{#line $_->{line} "$file"\n}; } if ( defined $_->{default} ) { my $default_val = $_->{default}; # allow for comments after default declaration $default_val .= "\n" if defined $_->{default} && $_->{default} =~ /\#/; push @assign, <<"EOF"; $var_name = exists \$pos{'$_->{name}'} ? $coerce : $default_val; EOF } else { push @assign, " $var_name = $coerce;\n"; } } my $decl = 'my ( '; $decl .= join ', ', @decl; $decl .= " );\n"; # closing brace closes opening of @pos return $init, @args_hash, $decl, $pos, @req_check, @assign, "}\n"; } sub _define_args_hash { my $self = shift; return 1 if $self->define_args_hash eq 'always'; return 0 if $self->define_args_hash eq 'never'; foreach ( $self->preamble, $self->_blocks('filter'), $self->_blocks('init'), $self->{current_compile}{body}, $self->_blocks('cleanup'), $self->postamble, grep { defined } map { $_->{default} } @{ $self->{current_compile}{args} } ) { return 1 if /ARGS/; } } sub _filter { my $self = shift; my @filter; @filter = $self->_blocks('filter') or return; return ( join '', "\$m->current_comp->filter( sub { local \$_ = shift;\n", ( join ";\n", @filter ), ";\n", "return \$_;\n", "} );\n", ); } sub _flags { my $self = shift; return $self->_flags_or_attr('flags'); } sub _attr { my $self = shift; return $self->_flags_or_attr('attr'); } sub _flags_or_attr { my $self = shift; my $type = shift; return join "\n,", ( map { "$_ => $self->{current_compile}{$type}{$_}" } keys %{ $self->{current_compile}{$type} } ); } sub _declared_args { my $self = shift; my @args; foreach my $arg ( sort {"$a->{type}$a->{name}" cmp "$b->{type}$b->{name}" } @{ $self->{current_compile}{args} } ) { my $def = defined $arg->{default} ? "$arg->{default}" : 'undef'; $def =~ s,([\\']),\\$1,g; $def = "'$def'" unless $def eq 'undef'; push @args, " '$arg->{type}$arg->{name}' => { default => $def }"; } return join ",\n", @args; } 1; __END__ =head1 NAME HTML::Mason::Compiler::ToObject - A Compiler subclass that generates Mason object code =head1 SYNOPSIS my $compiler = HTML::Mason::Compiler::ToObject->new; my $object_code = $compiler->compile( comp_source => $source, name => $comp_name, comp_path => $comp_path, ); =head1 DESCRIPTION This Compiler subclass generates Mason object code (Perl code). It is the default Compiler class used by Mason. =head1 PARAMETERS TO THE new() CONSTRUCTOR All of these parameters are optional. =over =item comp_class The class into which component objects are blessed. This defaults to L. =item subcomp_class The class into which subcomponent objects are blessed. This defaults to L. =item in_package This is the package in which a component's code is executed. For historical reasons, this defaults to C. =item preamble Text given for this parameter is placed at the beginning of each component, but after the execution of any C<< <%once> >> block. See also L. The request will be available as C<$m> in preamble code. =item postamble Text given for this parameter is placed at the end of each component. See also L. The request will be available as C<$m> in postamble code. =item use_strict True or false, default is true. Indicates whether or not a given component should C. =item use_warnings True or false, default is false. Indicates whether or not a given component should C. =item named_component_subs When compiling a component, use uniquely named subroutines for the a component's body, subcomponents, and methods. Doing this allows you to effectively profile Mason components. Without this, all components simply show up as __ANON__ or something similar in the profiler. =item define_args_hash One of "always", "auto", or "never". This determines whether or not an C<%ARGS> hash is created in components. If it is set to "always", one is always defined. If set to "never", it is never defined. The default, "auto", will cause the hash to be defined only if some part of the component contains the string "ARGS". This is somewhat crude, and may result in some false positives, but this is preferable to false negatives. Not defining the args hash means that we can avoid copying component arguments, which can save memory and slightly improve execution speed. =back =head1 ACCESSOR METHODS All of the above properties have read-only accessor methods of the same name. You cannot change any property of a compiler after it has been created (but you can create multiple compilers with different properties). =head1 METHODS This class is primarily meant to be used by the Interpreter object, and as such has a very limited public API. =over =item compile(...) This method will take component source and return the compiled object code for that source. See L for details on this method. This subclass also accepts a C parameter, allowing you to override the class into which the component is compiled. =back =cut HTML-Mason-1.59/lib/HTML/Mason/Plugin.pm0000644000175000017500000001264213660015140017313 0ustar autarchautarchpackage HTML::Mason::Plugin; $HTML::Mason::Plugin::VERSION = '1.59'; use strict; use warnings; sub new { my $class = shift; bless { @_ }, $class; } sub start_request_hook { # my ($self, $context) = @_; # $context has: request, args } sub end_request_hook { # my ($self, $context) = @_; # $context has: request, args, output, wantarray, result, error } sub start_component_hook { # my ($self, $context) = @_; # $context has: request, comp, args } sub end_component_hook { # my ($self, $context) = @_; # $context has: request, comp, args, wantarray, result, error } 1; __END__ =head1 NAME HTML::Mason::Plugin - Plugin Base class for Mason =head1 SYNOPIS package MasonX::Plugin::Timer; use base qw(HTML::Mason::Plugin); use Time::HiRes; sub start_component_hook { my ($self, $context) = @_; push @{$self->{ timers }}, Time::HiRes::time; } sub end_component_hook { my ($self, $context) = @_; my $elapsed = Time::HiRes::time - pop @{$self->{ timers }}; printf STDERR "Component '%s' took %.1f seconds\n", $context->comp->title, $elapsed; } 1; =head1 DESCRIPTION Use a Mason plugin to have actions occur at the beginning or end of requests or components. Plugins are activated by passing L in the interpreter or request object. Each plugin in the list can be specified as a class name (in which case the plugin object is created once for each request) or as an actual object of the plugin class. If your plugin can be configured, place the configuration in class variables - for example, $MasonX::Plugin::Timer::Units = 'seconds'; These can be set either from httpd.conf via PerlSetVar directives, or in perl directly from a handler.pl file. =head1 PLUGIN HOOKS A plugin class defines one or more of the following hooks (methods): I, I, I, and I. Every hook receives two arguments: the plugin object itself, and a context object with various methods. =over =item start_request_hook C is called before the Mason request begins execution. Its context has the following read-only methods: request # the current request ($m) args # arguments the request was called with When called in scalar context, I returns a list reference which may be modified to change or add to the arguments passed to the first component. When called in list context, I returns a list (which may be assigned to a hash). Note that subrequests (see L will create a new plugin object and execute this code again; you can skip your code for subrequests by checking C on I. e.g. sub start_request_hook { my ($self, $context) = @_; unless ($context->request->is_subrequest()) { # perform hook action } } Currently, this hook is called before any information about the requested component is available, so you cannot call methods like C or C on the Request object. =item end_request_hook C is called before the Mason request exits. Its context has the following read-only methods: request # the current request ($m) args # arguments the request was called with output # reference to the contents of the output buffer wantarray # value of wantarray the request was called with result # arrayref of value(s) that the request is about to return error # reference to error, if any, that the request is about to throw When called in scalar context, I returns a list reference; when called in list context, it returns a list (which may be assigned to a hash). I always contains an array ref; if I is 0, the return value is the the first element of that array. The plugin may modify I to affect what the request outputs, and I and I to affect what the request returns. =item start_component_hook C is called before a component begins executing. Its context has the following read-only methods: request # the current request ($m) comp # the component object args # arrayref of arguments the component was called with The plugin may NOT modify I currently. =item end_component_hook C is called after a component has completed. Its context has the following read-only methods: request # the current request ($m) comp # the component object args # arrayref of arguments the component was called with wantarray # value of wantarray the component was called with result # arrayref of value(s) that the component is about to return error # reference to error, if any, that the component is about to throw I always contains an array ref; if I is 0, the return value is the first element of that array. The plugin may modify both I and I to affect how the request returns. It would be desirable for this hook to have access to the component's output as well as its return value, but this is currently impossible because output from multiple components combine into a single buffer. =back =head1 WARNINGS Do not keep an unweakened reference to a request or component object in your plugin object, or you will create a nasty circular reference. =cut HTML-Mason-1.59/lib/HTML/Mason/Compiler.pm0000644000175000017500000007035213660015140017631 0ustar autarchautarch# 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. package HTML::Mason::Compiler; $HTML::Mason::Compiler::VERSION = '1.59'; use strict; use warnings; use Data::Dumper; use HTML::Mason::Component::FileBased; use HTML::Mason::Component::Subcomponent; use HTML::Mason::Exceptions( abbr => [qw(param_error compiler_error syntax_error)] ); use HTML::Mason::Lexer; use HTML::Mason::Tools qw(checksum); use Params::Validate qw(:all); Params::Validate::validation_options( on_fail => sub { param_error join '', @_ } ); use Class::Container; use base qw(Class::Container); BEGIN { __PACKAGE__->valid_params ( allow_globals => { parse => 'list', type => ARRAYREF, default => [], descr => "An array of names of Perl variables that are allowed globally within components" }, default_escape_flags => { parse => 'string', type => SCALAR|ARRAYREF, default => [], descr => "Escape flags that will apply by default to all Mason tag output" }, enable_autoflush => { parse => 'boolean', type => SCALAR, default => 1, descr => "Whether to include support for autoflush when compiling components" }, lexer => { isa => 'HTML::Mason::Lexer', descr => "A Lexer object that will scan component text during compilation" }, preprocess => { parse => 'code', type => CODEREF, optional => 1, descr => "A subroutine through which all component text will be sent during compilation" }, postprocess_perl => { parse => 'code', type => CODEREF, optional => 1, descr => "A subroutine through which all Perl code will be sent during compilation" }, postprocess_text => { parse => 'code', type => CODEREF, optional => 1, descr => "A subroutine through which all plain text will be sent during compilation" }, use_source_line_numbers => { parse => 'boolean', type => SCALAR, default => 1, descr => "Whether to use source line numbers in errors and debugger" }, ); __PACKAGE__->contained_objects ( lexer => { class => 'HTML::Mason::Lexer', descr => "This class generates compiler events based on the components source" }, ); # Define an IN_PERL_DB compile-time constant indicating whether we are # in the Perl debugger. This is used in the object file to # determine whether to call $m->debug_hook. # if (defined($DB::sub)) { *IN_PERL_DB = sub () { 1 }; } else { *IN_PERL_DB = sub () { 0 }; } } use HTML::Mason::MethodMaker ( read_only => [qw( enable_autoflush lexer object_id preprocess postprocess_perl postprocess_text use_source_line_numbers ) ], ); my $old_escape_re = qr/^[hnu]+$/; sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->default_escape_flags( $self->{default_escape_flags} ) if defined $self->{default_escape_flags}; # Verify the validity of the global names $self->allow_globals( @{$self->{allow_globals}} ); # Compute object_id once, on the assumption that all of compiler's # and lexer's parameters are read-only. $self->compute_object_id; return $self; } sub compute_object_id { my $self = shift; # Can't use object keys because they stringify differently every # time the program is loaded, whether they are a reference to the # same object or not. my $spec = $self->validation_spec; my @id_keys = ( grep { ! exists $spec->{$_}{isa} && ! exists $spec->{$_}{can} } grep { $_ ne 'container' } keys %$spec ); my @vals = ('HTML::Mason::VERSION', $HTML::Mason::VERSION); foreach my $k ( sort @id_keys ) { push @vals, $k, $self->{$k}; } my $dumped_vals = Data::Dumper->new(\@vals)->Indent(0)->Sortkeys(1)->Dump; $self->{object_id} = checksum($dumped_vals); } my %top_level_only_block = map { $_ => 1 } qw( cleanup once shared ); my %valid_comp_flag = map { $_ => 1 } qw( inherit ); sub add_allowed_globals { my $self = shift; my @globals = @_; if ( my @bad = grep { ! /^[\$@%]/ } @globals ) { param_error "add_allowed_globals: bad parameters '@bad', must begin with one of \$, \@, %\n"; } $self->{allow_globals} = [ sort keys %{ { map { $_ => 1 } @globals, @{ $self->{allow_globals} } } } ]; return @{ $self->{allow_globals} }; } sub allow_globals { my $self = shift; if (@_) { $self->{allow_globals} = []; return if @_ == 1 and not defined $_[0]; # @_ is (undef) $self->add_allowed_globals(@_); } return @{ $self->{allow_globals} }; } sub default_escape_flags { my $self = shift; return $self->{default_escape_flags} unless @_; my $flags = shift; unless ( defined $flags ) { $self->{default_escape_flags} = []; return; } # make sure this is always an arrayref unless ( ref $flags ) { if ( $flags =~ /^[hu]+$/ ) { $self->{default_escape_flags} = [ split //, $flags ]; } else { $self->{default_escape_flags} = [ $flags ]; } } return $self->{default_escape_flags}; } sub compile { my $self = shift; my %p = validate( @_, { comp_source => { type => SCALAR|SCALARREF }, name => { type => SCALAR }, comp_path => { type => SCALAR }, fh => { type => HANDLE, optional => 1 }, } ); my $src = ref($p{comp_source}) ? $p{comp_source} : \$p{comp_source}; # The current compile - initially the main component, then each subcomponent/method local $self->{current_compile} = {}; # Useful for implementing features that affect both main body and methods/subcomps local $self->{main_compile} = $self->{current_compile}; # So we're re-entrant in subcomps local $self->{paused_compiles} = []; local $self->{comp_path} = $p{comp_path}; # Preprocess the source. The preprocessor routine is handed a # reference to the entire source. if ($self->preprocess) { eval { $self->preprocess->( $src ) }; compiler_error "Error during custom preprocess step: $@" if $@; } $self->lexer->lex( comp_source => $src, name => $p{name}, compiler => $self ); return $self->compiled_component( exists($p{fh}) ? (fh => $p{fh}) : () ); } sub start_component { my $self = shift; my $c = $self->{current_compile}; $c->{in_main} = 1; $c->{in_block} = undef; $self->_init_comp_data($c); } sub _init_comp_data { my $self = shift; my $data = shift; $data->{body} = ''; $data->{last_body_code_type} = ''; foreach ( qw( def method ) ) { $data->{$_} = {}; } $data->{args} = []; $data->{flags} = {}; $data->{attr} = {}; $data->{comp_with_content_stack} = []; foreach ( qw( cleanup filter init once shared ) ) { $data->{blocks}{$_} = []; } } sub end_component { my $self = shift; my $c = $self->{current_compile}; $self->lexer->throw_syntax_error("Not enough component-with-content ending tags found") if @{ $c->{comp_with_content_stack} }; } sub start_block { my $self = shift; my $c = $self->{current_compile}; my %p = @_; $self->lexer->throw_syntax_error("Cannot define a $p{block_type} section inside a method or subcomponent") if $top_level_only_block{ $p{block_type} } && ! $c->{in_main}; $self->lexer->throw_syntax_error("Cannot nest a $p{block_type} inside a $c->{in_block} block") if $c->{in_block}; $c->{in_block} = $p{block_type}; } sub raw_block { # These blocks contain Perl code - so don't include <%text> and so on. my $self = shift; my $c = $self->{current_compile}; my %p = @_; eval { $self->postprocess_perl->( \$p{block} ) if $self->postprocess_perl }; compiler_error $@ if $@; my $method = "$p{block_type}_block"; return $self->$method(%p) if $self->can($method); my $comment = ''; if ( $self->lexer->line_number && $self->use_source_line_numbers ) { my $line = $self->lexer->line_number; my $file = $self->_escape_filename( $self->lexer->name ); $comment = qq{#line $line "$file"\n}; } push @{ $self->{current_compile}{blocks}{ $p{block_type} } }, "$comment$p{block}"; } sub doc_block { # Don't do anything - just discard the comment. } sub perl_block { my $self = shift; my %p = @_; $self->_add_body_code( $p{block} ); $self->{current_compile}{last_body_code_type} = 'perl_block'; } sub text { my ($self, %p) = @_; my $tref = ref($p{text}) ? $p{text} : \$p{text}; # Allow a reference eval { $self->postprocess_text->($tref) } if $self->postprocess_text; compiler_error $@ if $@; $$tref =~ s,([\'\\]),\\$1,g; if ($self->enable_autoflush) { $self->_add_body_code("\$m->print( '", $$tref, "' );\n"); } else { $self->_add_body_code("\$\$_outbuf .= '", $$tref, "';\n"); } $self->{current_compile}{last_body_code_type} = 'text'; } sub text_block { my $self = shift; my %p = @_; $self->text(text => \$p{block}); } sub end_block { my $self = shift; my $c = $self->{current_compile}; my %p = @_; $self->lexer->throw_syntax_error("End of $p{block_type} encountered while in $c->{in_block} block") unless $c->{in_block} eq $p{block_type}; $c->{in_block} = undef; } sub variable_declaration { my $self = shift; my %p = @_; $self->lexer->throw_syntax_error("variable_declaration called inside a $p{block_type} block") unless $p{block_type} eq 'args'; my $arg = "$p{type}$p{name}"; $self->lexer->throw_syntax_error("$arg already defined") if grep { "$_->{type}$_->{name}" eq $arg } @{ $self->{current_compile}{args} }; push @{ $self->{current_compile}{args} }, { type => $p{type}, name => $p{name}, default => $p{default}, line => $self->lexer->line_number, file => $self->lexer->name, }; } sub key_value_pair { my $self = shift; my %p = @_; compiler_error "key_value_pair called inside a $p{block_type} block" unless $p{block_type} eq 'flags' || $p{block_type} eq 'attr'; my $type = $p{block_type} eq 'flags' ? 'flag' : 'attribute'; $self->lexer->throw_syntax_error("$p{key} $type already defined") if exists $self->{current_compile}{ $p{block_type} }{ $p{key} }; $self->{current_compile}{ $p{block_type} }{ $p{key} } = $p{value} } sub start_named_block { my $self = shift; my $c = $self->{current_compile}; my %p = @_; # Error if defining one def or method inside another $self->lexer->throw_syntax_error ("Cannot define a $p{block_type} block inside a method or subcomponent") unless $c->{in_main}; # Error for invalid character in name $self->lexer->throw_syntax_error("Invalid $p{block_type} name: $p{name}") if $p{name} =~ /[^.\w-]/; # Error if two defs or two methods defined with same name $self->lexer->throw_syntax_error (sprintf("Duplicate definition of %s '%s'", $p{block_type} eq 'def' ? 'subcomponent' : 'method', $p{name})) if exists $c->{$p{block_type}}{ $p{name} }; # Error if def and method defined with same name my $other_type = $p{block_type} eq 'def' ? 'method' : 'def'; $self->lexer->throw_syntax_error ("Cannot define a method and subcomponent with the same name ($p{name})") if exists $c->{$other_type}{ $p{name} }; $c->{in_main}--; $c->{ $p{block_type} }{ $p{name} } = {}; $self->_init_comp_data( $c->{ $p{block_type} }{ $p{name} } ); push @{$self->{paused_compiles}}, $c; $self->{current_compile} = $c->{ $p{block_type} }{ $p{name} }; $self->{current_compile}->{in_named_block} = {block_type => $p{block_type}, name => $p{name}}; } sub end_named_block { my $self = shift; delete $self->{current_compile}->{in_named_block}; $self->{current_compile} = pop @{$self->{paused_compiles}}; $self->{current_compile}{in_main}++; } sub substitution { my $self = shift; my %p = @_; my $text = $p{substitution}; # This is a comment tag if all lines of text contain only whitespace # or start with whitespace and a comment marker, e.g. # # <% # # # # foo # %> # my @lines = split(/\n/, $text); unless (grep { /^\s*[^\s\#]/ } @lines) { $self->{current_compile}{last_body_code_type} = 'substitution'; return; } if ( ( exists $p{escape} && defined $p{escape} ) || @{ $self->{default_escape_flags} } ) { my @flags; if ( defined $p{escape} ) { $p{escape} =~ s/\s+$//; if ( $p{escape} =~ /$old_escape_re/ ) { @flags = split //, $p{escape}; } else { @flags = split /\s*,\s*/, $p{escape}; } } # is there any way to check the flags for validity and still # allow them to be dynamically set from components? unshift @flags, @{ $self->default_escape_flags } unless grep { $_ eq 'n' } @flags; my %seen; my $flags = ( join ', ', map { $seen{$_}++ ? () : "'$_'" } grep { $_ ne 'n' } @flags ); $text = "(map {; \$m->interp->apply_escapes(\$_, $flags) } ($text))" if $flags; } my $code; # Make sure to allow lists within <% %> tags. # if ($self->enable_autoflush) { $code = "\$m->print( $text );\n"; } else { # more efficient output form when autoflush is disabled. only # output defined bits, which is what $m->print does internally # as well. use 'if defined' for maximum efficiency; grep # creates a list. $code = "for ( $text ) { \$\$_outbuf .= \$_ if defined }\n"; } eval { $self->postprocess_perl->(\$code) } if $self->postprocess_perl; compiler_error $@ if $@; $self->_add_body_code($code); $self->{current_compile}{last_body_code_type} = 'substitution'; } sub component_call { my $self = shift; my %p = @_; my ($prespace, $call, $postspace) = ($p{call} =~ /(\s*)(.*)(\s*)/s); if ( $call =~ m,^[\w/.],) { my $comma = index($call, ','); $comma = length $call if $comma == -1; (my $comp = substr($call, 0, $comma)) =~ s/\s+$//; $call = "'$comp'" . substr($call, $comma); } my $code = "\$m->comp( $prespace $call $postspace \n); "; eval { $self->postprocess_perl->(\$code) } if $self->postprocess_perl; compiler_error $@ if $@; $self->_add_body_code($code); $self->{current_compile}{last_body_code_type} = 'component_call'; } sub component_content_call { my $self = shift; my $c = $self->{current_compile}; my %p = @_; my $call = $p{call}; for ($call) { s/^\s+//; s/\s+$//; } push @{ $c->{comp_with_content_stack} }, $call; my $code = "\$m->comp( { content => sub {\n"; $code .= $self->_set_buffer(); eval { $self->postprocess_perl->(\$code) } if $self->postprocess_perl; compiler_error $@ if $@; $self->_add_body_code($code); $c->{last_body_code_type} = 'component_content_call'; } sub component_content_call_end { my $self = shift; my $c = $self->{current_compile}; my %p = @_; $self->lexer->throw_syntax_error("Found component with content ending tag but no beginning tag") unless @{ $c->{comp_with_content_stack} }; my $call = pop @{ $c->{comp_with_content_stack} }; my $call_end = $p{call_end}; for ($call_end) { s/^\s+//; s/\s+$//; } my $comp = undef; if ( $call =~ m,^[\w/.],) { my $comma = index($call, ','); $comma = length $call if $comma == -1; ($comp = substr($call, 0, $comma)) =~ s/\s+$//; $call = "'$comp'" . substr($call, $comma); } if ($call_end) { if ($call_end !~ m,^[\w/.],) { $self->lexer->throw_syntax_error("Cannot use an expression inside component with content ending tag; use a bare component name or instead"); } if (!defined($comp)) { $self->lexer->throw_syntax_error("Cannot match an expression as a component name; use instead"); } if ($call_end ne $comp) { $self->lexer->throw_syntax_error("Component name in ending tag ($call_end) does not match component name in beginning tag ($comp)"); } } my $code = "} }, $call\n );\n"; eval { $self->postprocess_perl->(\$code) } if $self->postprocess_perl; compiler_error $@ if $@; $self->_add_body_code($code); $c->{last_body_code_type} = 'component_content_call_end'; } sub perl_line { my $self = shift; my %p = @_; my $code = "$p{line}\n"; eval { $self->postprocess_perl->(\$code) } if $self->postprocess_perl; compiler_error $@ if $@; $self->_add_body_code($code); $self->{current_compile}{last_body_code_type} = 'perl_line'; } sub _add_body_code { my $self = shift; # We know a perl-line is always _one_ line, so we know that the # line numbers are going to match up as long as the first line in # a series has a line number comment before it. Adding a comment # can break certain constructs like qw() list that spans multiple # perl-lines. if ( $self->lexer->line_number && $self->{current_compile}{last_body_code_type} ne 'perl_line' && $self->use_source_line_numbers ) { my $line = $self->lexer->line_number; my $file = $self->_escape_filename( $self->lexer->name ); $self->{current_compile}{body} .= qq{#line $line "$file"\n}; } $self->{current_compile}{body} .= $_ foreach @_; } sub _escape_filename { my $self = shift; my $file = shift; $file =~ s/\"//g; return $file; } sub dump { my $self = shift; my $c = $self->{current_compile}; warn "Main component\n"; $self->_dump_data( $c ); foreach ( keys %{ $c->{def} } ) { warn " Subcomponent $_\n"; $self->_dump_data( $c->{def}{$_}, ' ' ); } foreach ( keys %{ $c->{method} } ) { warn " Methods $_\n"; $self->_dump_data( $c->{method}{$_}, ' '); } } sub _dump_data { my $self = shift; my $data = shift; my $indent = shift || ''; if ( @{ $data->{args} } ) { warn "$indent args\n"; foreach ( @{ $data->{args} } ) { warn "$indent $_->{type}$_->{name}"; warn " => $_->{default}" if defined $_->{default}; warn "\n"; } } warn "\n$indent body\n"; warn $data->{body}, "\n"; } sub _blocks { my $self = shift; return @{ $self->{current_compile}{blocks}{ shift() } }; } sub HTML::Mason::Parser::new { die "The Parser module is no longer a part of HTML::Mason. Please see ". "the Lexer and Compiler modules, its replacements.\n"; } 1; __END__ =head1 NAME HTML::Mason::Compiler - Compile Mason component source =head1 SYNOPSIS package My::Funky::Compiler; use base qw(HTML::Mason::Compiler); =head1 DESCRIPTION The compiler starts the compilation process by calling its lexer's C method and passing itself as the C parameter. The lexer then calls various methods in the compiler as it parses the component source. =head1 PARAMETERS TO THE new() CONSTRUCTOR =over 4 =item allow_globals List of variable names, complete with prefix (C<$@%>), that you intend to use as globals in components. Normally global variables are forbidden by C, but any variable mentioned in this list is granted a reprieve via a "use vars" statement. For example: allow_globals => [qw($DBH %session)] In a mod_perl environment, C<$r> (the request object) is automatically added to this list. =item default_escape_flags Escape flags to apply to all <% %> expressions by default. The current valid flags are h - escape for HTML ('<' => '<', etc.) u - escape for URL (':' => '%3A', etc.) The developer can override default escape flags on a per-expression basis; see the L section of the developer's manual. If you want to set I flags as the default, this should be given as a reference to an array of flags. =item enable_autoflush True or false, default is true. Indicates whether components are compiled with support for L. The component can be compiled to a more efficient form if it does not have to check for autoflush mode, so you should set this to 0 if you can. =item lexer The Lexer object to associate with this Compiler. By default a new object of class L will be created. =item lexer_class The class to use when creating a lexer. Defaults to L. =item preprocess Sub reference that is called to preprocess each component before the compiler does it's magic. The sub is called with a single parameter, a scalar reference to the script. The sub is expected to process the script in-place. This is one way to extend the HTML::Mason syntax with new tags, etc., although a much more flexible way is to subclass the Lexer or Compiler class. See also L and L. =item postprocess_text Sub reference that is called to postprocess the text portion of a compiled component, just before it is assembled into its final subroutine form. The sub is called with a single parameter, a scalar reference to the text portion of the component. The sub is expected to process the string in-place. See also L and L. =item postprocess_perl Sub reference that is called to postprocess the Perl portion of a compiled component, just before it is assembled into its final subroutine form. The sub is called with a single parameter, a scalar reference to the Perl portion of the component. The sub is expected to process the string in-place. See also L and L. =item use_source_line_numbers True or false, default is true. Indicates whether component line numbers that appear in error messages, stack traces, etc. are in terms of the source file instead of the object file. Mason does this by inserting '#line' directives into compiled components. While source line numbers are more immediately helpful, object file line numbers may be more appropriate for in-depth debugging sessions. =back =head1 ACCESSOR METHODS All of the above properties have read-only accessor methods of the same name. You cannot change any property of a compiler after it has been created - among other things, this would potentially invalidate any existing cached component objects or object files. Your best bet is to create different compiler objects and load them into different interpreters. =head1 METHODS There are several methods besides the compilation callbacks below that a Compiler subclass needs to implement. =over 4 =item compile(...) This method has several parameters: =over 8 =item * comp_source (required) Either a scalar or reference to a scalar containing the component source. =item * name (required) The name of the component. This should be the filename of the component if it is file-based, or some other clear identifier of the component source. =item * comp_path (required) This should be the component's path. =item * fh (optional) If this is given then the output of the compiler will be sent directly to this handle, rather than being buffered in memory. This is an optimization to avoid memory usage. =back =item object_id This method should return a unique id for the given compiler object. This is used by the interpreter when determining the object directory, for example. =back =head2 Compilation Callbacks These are methods called by the Lexer while processing a component source. You may wish to override some of these methods if you're implementing your own custom Compiler class. =over 4 =item start_component() This method is called by the Lexer when it starts processing a component. =item end_component() This method is called by the Lexer when it finishes processing a component. =item start_block(block_type => ) This method is called by the Lexer when it encounters an opening Mason block tag like C<< <%perl> >> or C<< <%args> >>. Its main purpose is to keep track of the nesting of different kinds of blocks within each other. The type of block ("init", "once", etc.) is passed via the "block_type" parameter. =item end_block(block_type => ) This method is called by the Lexer when it encounters a closing Mason block tag like C<< >> or C<< >>. Like C, its main purpose is to help maintain syntactic integrity. =item *_block(block => , [ block_type => ]) Several compiler methods like C, C, and C are called by the Lexer after C when it encounters blocks of certain types. These methods actually do the work of putting the body of a block into the compiled data structure. The methods that follow this pattern are C, C, C, C, and C. The last method is called for all C<< <%once> >>, C<< <%cleanup> >>, C<< <%filter> >>, C<< <%init> >>, C<< <%perl> >>, and C<< <%shared> >> blocks. =item text(text => ) Inserts the text contained in a C parameter into the component for verbatim output. This is called when the lexer finds plain text in a component. =item variable_declaration( type => , name => , default => ) Inserts a variable declaration from the C<< <%args> >> section into the component. The type will be either "$", "@", or "%", indicating a scalar, array, or hash. The name is the variable name without the leading sigil. The default is everything found after the first "=>" on an C<< <%args> >> block line, and may include a comment. =item key_value_pair(block_type => , key => , value => ) Inserts a key-value pair from a C<< <%flags> >> or C<< <%attr> >> section into the component. The "block_type" parameter will be either "flags" or "attr". =item start_named_block(block_type => , name => ) Analogous to L, but starts a "named" block (C<< <%method> >> or C<< <%def> >>). =item end_named_block() Called by the Lexer to end a "named" block. =item substitution(substitution => , escape => ) Called by the Lexer when it encounters a substitution tag (C<< <% ... %> >>). The value of the "escape" parameter will be everything found after the pipe (|) in the substitution tag, and may be more than one character such as "nh". =item component_call(call => ) Called by the Lexer when it encounters a component call tag without embedded content (C<< <& ... &> >>). The "call" parameter contains the entire contents of the tag. =item component_content_call(call => ) Called by the Lexer when it encounters a component call tag with embedded content (C<< <&| ... &> >>). =item component_content_call_end() Called by the Lexer when it encounters an ending tag for a component call with content (C<< >>). Note that there is no corresponding C method for component calls without content, because these calls don't have ending tags. =item perl_line(line => ) Called by the Lexer when it encounters a C<%>-line. =back =head1 SUBCLASSING We recommend that any parameters you add to Compiler be read-only, because the compiler object_id is only computed once on creation and would not reflect any changes to Lexer parameters. =cut HTML-Mason-1.59/lib/HTML/Mason/ApacheHandler.pm0000644000175000017500000010663413660015140020541 0ustar autarchautarch# -*- cperl-indent-level: 4; cperl-continued-brace-offset: -4; cperl-continued-statement-offset: 4 -*- # 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 strict; 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/ ) { require mod_perl2; } elsif ( $ENV{MOD_PERL} ) { require mod_perl; } my $mpver = (mod_perl2->VERSION || mod_perl->VERSION || 0); # This is the version that introduced PerlAddVar if ($mpver && $mpver < 1.24) { die "mod_perl VERSION >= 1.24 required"; } elsif ($mpver >= 1.99 && $mpver < 1.999022) { die "mod_perl-1.99 is not supported; upgrade to 2.00"; } } #---------------------------------------------------------------------- # # APACHE-SPECIFIC REQUEST OBJECT # 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 '', @_ ) } ); 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; 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" }, ); } 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 { my $class = shift; 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"; } # Record a flag indicating whether the user passed a custom out_method my %params = @_; $self->ah->{has_custom_out_method} = exists $params{out_method}; return $self; } 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'; if (defined($_[1])) { $self->{cgi_object} = $_[1]; } 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(''); } return $self->{cgi_object}; } # # Override this method to return NOT_FOUND when we get a # TopLevelNotFound exception. In case of POST we must trick # Apache into not reading POST content again. Wish there were # a more standardized way to do this... # sub exec { my $self = shift; my $r = $self->apache_req; my $retval; 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 { # 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. my $real_apache_print = $r->can('print'); # Remap $r->print to Mason's $m->print while executing # request, but just for this $r, in case user does an internal # redirect or apache subrequest. local $^W = 0; no strict 'refs'; my $req_class = ref $r; no warnings 'redefine'; local *{"$req_class\::print"} = sub { my $local_r = shift; return $self->print(@_) if $local_r eq $r; return $local_r->$real_apache_print(@_); }; $retval = $self->SUPER::exec(@_); } # On a success code, send headers if they have not been sent and # if we are the top-level request. Since the out_method sends # 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 ) ) { $r->send_http_header(); } # mod_perl 1 treats HTTP_OK and OK the same, but mod_perl-2 does not. return defined $retval && $retval ne HTTP_OK ? $retval : OK; } # # 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) = @_; if (isa_mason_exception($err, 'TopLevelNotFound')) { rethrow_exception $err; } else { if ( $self->error_format eq 'html' ) { $self->apache_req->content_type('text/html'); unless (APACHE2) { $self->apache_req->send_http_header; } } $self->SUPER::_handle_error($err); } } 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); } #---------------------------------------------------------------------- # # APACHEHANDLER OBJECT # package HTML::Mason::ApacheHandler; use File::Path; use File::Spec; use HTML::Mason::Exceptions( abbr => [qw(param_error system_error error)] ); 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 '', @_ ) } ); 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 (APACHE2) { require Apache2::RequestRec; require Apache2::RequestIO; require Apache2::ServerUtil; require Apache2::RequestUtil; require Apache2::Log; require APR::Table; } else { require Apache; require Apache::Request; require HTML::Mason::Apache::Request; Apache->import(); } } } 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_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" }, ); __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(); } 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 { my $pack = shift; 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') { eval { require CGI unless defined CGI->VERSION; }; # mod_perl2 does not warn about this, so somebody should 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; } } } # Register with Apache::Status at module startup. Will get replaced # 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 { ["(no interpreters created in this child yet)"] }); } my %AH_BY_CONFIG; sub make_ah { my ($package, $r) = @_; my $config = $r->dir_config; # # If the user has virtual hosts, each with a different document # root, then we will have to be called from the handler method. # This means we have an active request. In order to distinguish # between virtual hosts with identical config directives that have # no comp root defined (meaning they expect to use the default # comp root), we append the document root for the current request # to the key. # 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 { my @roots; 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]; push @roots, $root; } $p{comp_root} = \@roots; } } my $ah = $package->new(%p, $r); $AH_BY_CONFIG{$key} = $ah if $key; return $ah; } # The following routines handle getting information from $r->dir_config sub calm_form { # Transform from StudlyCaps to name_like_this 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) = @_; $string =~ s/(?:^|_)(\w)/\U$1/g; return $string; } sub _get_mason_params { my $self = 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; $calm = $self->calm_form($calm); $candidates{$calm} = $config->{$studly}; } return unless %candidates; # # 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 ); } sub _get_param { # Gets a single config item from dir_config. my ($self, $key, $candidates, $config, $r) = @_; $key = $self->calm_form($key); my $spec = $self->allowed_params( $candidates || {} )->{$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 $method = "_get_${type}_param"; return $self->$method('Mason'.$self->studly_form($key), $config, $r); } sub _get_string_param { my $self = shift; return scalar $self->_get_val(@_); } sub _get_boolean_param { my $self = shift; return scalar $self->_get_val(@_); } sub _get_code_param { my $self = shift; 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 $@; return $sub_ref; } sub _get_list_param { my $self = shift; my @val = $self->_get_val(@_); if (@val == 1 && ! defined $val[0]) { @val = (); } return \@val; } sub _get_hash_list_param { my $self = shift; 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; $hash{$key} = $val; } return \%hash; } sub _get_val { my ($self, $p, $config, $r) = @_; my @val; if (wantarray || !$config) { if ($config) { @val = $config->get($p); } else { my $c = $r ? $r : _get_apache_server; @val = $c->dir_config->get($p); } } else { @val = exists $config->{$p} ? $config->{$p} : (); } param_error "Only a single value is allowed for configuration parameter '$p'\n" if @val > 1 && ! wantarray; return wantarray ? @val : $val[0]; } sub new { my $class = shift; # Get $r off end of params if its there my $r; $r = pop() if @_ % 2; my %params = @_; my %defaults; $defaults{request_class} = 'HTML::Mason::Request::ApacheHandler' unless exists $params{request}; 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 { $defaults{comp_root} = $req->document_root; } if (exists $allowed_params->{data_dir} and not exists $params{data_dir}) { # constructs path to /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); 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; } # Set default error_format based on error_mode if (exists($params{error_mode}) and $params{error_mode} eq 'fatal') { $defaults{error_format} = 'line'; } else { $defaults{error_mode} = 'output'; $defaults{error_format} = 'html'; } # Push $r onto default allow_globals if (exists $allowed_params->{allow_globals}) { if ( $params{allow_globals} ) { push @{ $params{allow_globals} }, '$r'; } else { $defaults{allow_globals} = ['$r']; } } 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/ ) { 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."; } # If we're running as superuser, change file ownership to http user & group 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" ); } $self->_initialize; return $self; } 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'); $user =~ s/^["'](.*)["']$/$1/; $group =~ s/^["'](.*)["']$/$1/; my $uid = $user ? getpwnam($user) : $>; my $gid = $group ? getgrnam($group) : $); 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"; 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"; 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) { # A closure, carries a reference to $self my $statsub = sub { my ($r,$q) = @_; # request and CGI objects return [] if !defined($r); if ($r->path_info and $r->path_info =~ /expire_code_cache=(.*)/) { $self->interp->delete_from_code_cache($1); } return ["

" . $self->apache_status_title . "

" , $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); } my $interp = $self->interp; # # Allow global $r in components # # This is somewhat redundant with code in new, but seems to be # needed since the user may simply create their own interp. # $interp->compiler->add_allowed_globals('$r') 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) = @_; # Should I be scared about this? =) my $comp_source = <<'EOF';

ApacheHandler properties:

<%perl> foreach my $property (sort keys %$ah) { my $val = $ah->{$property}; my $default = ( defined $val && defined $valid{$property}{default} && $val eq $valid{$property}{default} ) || ( ! defined $val && exists $valid{$property}{default} && ! defined $valid{$property}{default} ); my $display = $val; if (ref $val) { $display = ''; # only object can ->can, others die my $is_object = eval { $val->can('anything'); 1 }; if ($is_object) { $display .= ref $val . ' object'; } else { if (UNIVERSAL::isa($val, 'ARRAY')) { $display .= 'ARRAY reference - [ '; $display .= join ', ', @$val; $display .= '] '; } elsif (UNIVERSAL::isa($val, 'HASH')) { $display .= 'HASH reference - { '; my @pairs; while (my ($k, $v) = each %$val) { push @pairs, "$k => $v"; } $display .= join ', ', @pairs; $display .= ' }'; } else { $display = ref $val . ' reference'; } } $display .= ''; } defined $display && $display =~ s,([\x00-\x1F]),'control-' . chr( ord('A') + ord($1) - 1 ) . '',eg; # does this work for non-ASCII? % }
<% $property | h %> <% defined $display ? $display : 'undef' %> <% $default ? '(default)' : '' %>
<%args> $ah # The ApacheHandler we'll elucidate %valid # Contains default values for member data EOF my $interp = $self->interp; 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; return $out; } sub handle_request { my ($self, $r) = @_; my $req = $self->prepare_request($r); return $req unless ref($req); return $req->exec; } sub prepare_request { my $self = shift; my $r = $self->_apache_request_object(@_); my $interp = $self->interp; my $fs_type = $self->_request_fs_type($r); return DECLINED if $fs_type eq 'dir' && $self->decline_dirs; # # 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); unless ($comp_path) { # # Append path_info if filename does not represent an existing file # (mainly for dhandlers). # 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?)"; return $self->return_not_found($r); } my ($args, undef, $cgi_object) = $self->request_args($r); # # Set up interpreter global variables. # $interp->set_global( r => $r ); # If someone is using a custom request class that doesn't accept # 'ah' and 'apache_req' that's their problem. # my $m = eval { $interp->make_request( comp => $comp_path, args => [%$args], ah => $self, apache_req => $r, ); }; 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 || "")); 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 ); $retval = OK if defined $retval && $retval eq HTTP_OK; unless ($retval) { unless (APACHE2) { 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}; $m->cgi_object($cgi_object) if $m->can('cgi_object') && $cgi_object; return $m; } my $do_filter = sub { $_[0]->filter_register }; my $no_filter = sub { $_[0] }; sub _apache_request_object { my $self = shift; # We need to be careful to never assign a new apache (subclass) # object to $r or we will leak memory, at least with mp1. my $new_r = APACHE2 ? $_[0] : HTML::Mason::Apache::Request->new( $_[0] ); 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; $r_sub = $do_filter; } 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 ); } sub _request_fs_type { my ($self, $r) = @_; # # If filename is a directory, then either decline or simply reset # the content type, depending on the value of decline_dirs. # # ** We should be able to use $r->finfo here, but finfo is broken # in some versions of mod_perl (e.g. see Shane Adams message on # mod_perl list on 9/10/00) # my $is_dir = -d $r->filename; return $is_dir ? 'dir' : -f _ ? 'file' : 'other'; } sub request_args { my ($self, $r) = @_; # # Get arguments from Apache::Request or CGI. # my ($args, $cgi_object); if ($self->args_method eq 'mod_perl') { $args = $self->_mod_perl_args($r); } else { $cgi_object = CGI->new; $args = $self->_cgi_args($r, $cgi_object); } # we return $r solely for backwards compatibility return ($args, $r, $cgi_object); } # # Get $args hashref via CGI package # sub _cgi_args { my ($self, $r, $q) = @_; # For optimization, don't bother creating a CGI object if request # is a GET with no query string return {} if $r->method eq 'GET' && !scalar($r->args); return HTML::Mason::Utils::cgi_request_args($q, $r->method); } # # Get $args hashref via Apache::Request package. # sub _mod_perl_args { my ($self, $apr) = @_; my %args; foreach my $key ( $apr->param ) { my @values = $apr->param($key); $args{$key} = @values == 1 ? $values[0] : \@values; } return \%args; } sub _set_mason_req_out_method { my ($self, $m, $r) = @_; my $final_output_method = ($r->method eq 'HEAD' ? sub {} : $r->can('print')); # Craft the request's out method to handle http headers, content # length, and HEAD requests. my $out_method; if (APACHE2) { # mod_perl-2 does not need to call $r->send_http_headers $out_method = sub { eval { $r->$final_output_method( grep { defined } @_ ); $r->rflush; }; my $err = $@; die $err if $err and $err !~ /Software caused connection abort/; }; } else { my $sent_headers = 0; $out_method = sub { # Send headers if they have not been sent by us or by user. # We use instance here because if we store $m we get a # circular reference and a big memory leak. if (!$sent_headers and HTML::Mason::Request->instance->auto_send_headers) { unless ($r->notes('mason-sent-headers')) { $r->send_http_header(); } $sent_headers = 1; } # Call $r->print (using the real Apache method, not our # overridden method). $r->$final_output_method( grep {defined} @_ ); $r->rflush; }; } $m->out_method($out_method); } # Utility function to prepare $r before returning NOT_FOUND. sub return_not_found { my ($self, $r) = @_; if ($r->method eq 'POST') { $r->method('GET'); $r->headers_in->unset('Content-length'); } return NOT_FOUND; } # # PerlHandler HTML::Mason::ApacheHandler # BEGIN { # A method handler is prototyped differently in mod_perl 1.x than in 2.x my $handler_code = sprintf <<'EOF', APACHE2 ? ': method' : '($$)'; sub handler %s { my ($package, $r) = @_; my $ah; $ah ||= $package->make_ah($r); return $ah->handle_request($r); } EOF eval $handler_code; rethrow_exception $@; } 1; __END__ =head1 NAME HTML::Mason::ApacheHandler - Mason/mod_perl interface =head1 SYNOPSIS use HTML::Mason::ApacheHandler; my $ah = HTML::Mason::ApacheHandler->new (..name/value params..); ... sub handler { my $r = shift; $ah->handle_request($r); } =head1 DESCRIPTION The ApacheHandler object links Mason to mod_perl (version 1 or 2), running components in response to HTTP requests. It is controlled primarily through parameters to the new() constructor. =head1 PARAMETERS TO THE new() CONSTRUCTOR =over =item apache_status_title Title that you want this ApacheHandler to appear as under Apache::Status. Default is "HTML::Mason status". This is useful if you create more than one ApacheHandler object and want them all visible via Apache::Status. =item args_method Method to use for unpacking GET and POST arguments. The valid options are 'CGI' and 'mod_perl'; these indicate that a C or C object (respectively) will be created for the purposes of argument handling. 'mod_perl' is the default under mod_perl-1 and requires that you have installed the C package. Under mod_perl-2, the default is 'CGI' because C is still in development. If args_method is 'mod_perl', the C<$r> global is upgraded to an Apache::Request object. This object inherits all Apache methods and adds a few of its own, dealing with parameters and file uploads. See C for more information. If the args_method is 'CGI', the Mason request object (C<$m>) will have a method called C available. This method returns the CGI object used for argument processing. While Mason will load C or C as needed at runtime, it is recommended that you preload the relevant module either in your F or F file, as this will save some memory. =item decline_dirs True or false, default is true. Indicates whether Mason should decline directory requests, leaving Apache to serve up a directory index or a C error as appropriate. See the L section of the administrator's manual for more information about handling directories with Mason. =item interp The interpreter object to associate with this compiler. By default a new object of the specified L will be created. =item interp_class The class to use when creating a interpreter. Defaults to L. =back =head1 ACCESSOR METHODS All of the above properties, except interp_class, have standard accessor methods of the same name: no arguments retrieves the value, and one argument sets it, except for args_method, which is not settable. For example: my $ah = HTML::Mason::ApacheHandler->new; my $decline_dirs = $ah->decline_dirs; $ah->decline_dirs(1); =head1 OTHER METHODS The ApacheHandler object has a few other publicly accessible methods that may be of interest to end users. =over 4 =item handle_request ($r) This method takes an Apache or Apache::Request object representing a request and translates that request into a form Mason can understand. Its return value is an Apache status code. Passing an Apache::Request object is useful if you want to set Apache::Request parameters, such as POST_MAX or DISABLE_UPLOADS. =item prepare_request ($r) This method takes an Apache object representing a request and returns a new Mason request object or an Apache status code. If it is a request object you can manipulate that object as you like, and then call the request object's C method to have it generate output. If this method returns an Apache status code, that means that it could not create a Mason request object. This method is useful if you would like to have a chance to decline a request based on properties of the Mason request object or a component object. For example: my $req = $ah->prepare_request($r); # $req must be an Apache status code if it's not an object return $req unless ref($req); return DECLINED unless $req->request_comp->source_file =~ /\.html$/; $req->exec; =item request_args ($r) Given an Apache request object, this method returns a three item list. The first item is a hash reference containing the arguments passed by the client's request. The second is an Apache request object. This is returned for backwards compatibility from when this method was responsible for turning a plain Apache object into an Apache::Request object. The third item may be a CGI.pm object or C, depending on the value of the L parameter. =back =cut HTML-Mason-1.59/lib/HTML/Mason/Plugin/0000755000175000017500000000000013660015140016750 5ustar autarchautarchHTML-Mason-1.59/lib/HTML/Mason/Plugin/Context.pm0000644000175000017500000000417513660015140020741 0ustar autarchautarchpackage HTML::Mason::Plugin::Context; $HTML::Mason::Plugin::Context::VERSION = '1.59'; use strict; use warnings; #------------------------------------------------------------ package HTML::Mason::Plugin::Context::StartRequest; $HTML::Mason::Plugin::Context::StartRequest::VERSION = '1.59'; use base qw(HTML::Mason::Plugin::Context); sub request { $_[0]->[0] } sub args { if (wantarray) { return @{$_[0]->[1]}; } else { return $_[0]->[1]; } } #------------------------------------------------------------ package HTML::Mason::Plugin::Context::EndRequest; $HTML::Mason::Plugin::Context::EndRequest::VERSION = '1.59'; use base qw(HTML::Mason::Plugin::Context); sub request { $_[0]->[0] } sub args { if (wantarray) { return @{$_[0]->[1]}; } else { return $_[0]->[1]; } } sub output { $_[0]->[2] } sub wantarray { $_[0]->[3] } sub result { $_[0]->[4] } sub error { $_[0]->[5] } #------------------------------------------------------------ package HTML::Mason::Plugin::Context::StartComponent; $HTML::Mason::Plugin::Context::StartComponent::VERSION = '1.59'; use base qw(HTML::Mason::Plugin::Context); sub request { $_[0]->[0] } sub comp { $_[0]->[1] } sub args { $_[0]->[2] } #------------------------------------------------------------ package HTML::Mason::Plugin::Context::EndComponent; $HTML::Mason::Plugin::Context::EndComponent::VERSION = '1.59'; use base qw(HTML::Mason::Plugin::Context); sub request { $_[0]->[0] } sub comp { $_[0]->[1] } sub args { $_[0]->[2] } sub wantarray { $_[0]->[3] } sub result { $_[0]->[4] } sub error { $_[0]->[5] } #------------------------------------------------------------ 1; __END__ =head1 NAME HTML::Mason::Plugin::Context - encapsulates arguments passed to plugin methods =head1 DESCRIPTION This file defines the minimalist context classes that are instantiated whenever a plugin hook is called. See HTML::Mason::Plugin for documentation about plugins. For efficiency these objects have no new() method - they are created and blessed by hand inside HTML::Mason::Request just before they are used. =cut HTML-Mason-1.59/lib/HTML/Mason/Resolver.pm0000644000175000017500000000660513660015140017660 0ustar autarchautarch# 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. package HTML::Mason::Resolver; $HTML::Mason::Resolver::VERSION = '1.59'; use strict; use warnings; use HTML::Mason::Exceptions( abbr => ['param_error', 'virtual_error'] ); use Params::Validate qw(:all); Params::Validate::validation_options( on_fail => sub { param_error join '', @_ } ); use HTML::Mason::ComponentSource; use Class::Container; use base qw(Class::Container); # Returns HTML::Mason::ComponentSource object sub get_info { shift->_virtual; } sub glob_path { shift->_virtual; } sub _virtual { my $self = shift; my $sub = (caller(1))[3]; $sub =~ s/.*::(.*?)$/$1/; virtual_error "$sub is a virtual method and must be overridden in " . ref($self); } 1; __END__ =head1 NAME HTML::Mason::Resolver - Component path resolver base class =head1 SYNOPSIS # make a subclass and use it =head1 DESCRIPTION The resolver is responsible for translating a component path like /foo/index.html into a component. By default, Mason expects components to be stored on the filesystem, and uses the HTML::Mason::Resolver::File class to get information on these components. The HTML::Mason::Resolver provides a virtual parent class from which all resolver implementations should inherit. =head1 Class::Container This class is used by most of the Mason object's to manage constructor parameters and has-a relationships with other objects. See the documentation on this class for details on how to declare what parameters are valid for your subclass's constructor. HTML::Mason::Resolver is a subclass of Class::Container so you do not need to subclass it yourself. =head1 METHODS If you are interested in creating a resolver subclass, you must implement the following methods. =over 4 =item new This method is optional. The new method included in this class is simply inherited from C. If you need something more complicated done in your new method you will need to override it in your subclass. =item get_info Takes three arguments: an absolute component path, a component root key, and a component root path. Returns a new L object. =item glob_path Takes two arguments: a path glob pattern, something like "/foo/*" or "/foo/*/bar", and a component root path. Returns a list of component paths for components which match this glob pattern. For example, the filesystem resolver simply appends this pattern to the component root path and calls the Perl C function to find matching files on the filesystem. =back =head2 Using a Resolver with HTML::Mason::ApacheHandler If you are creating a new resolver that you intend to use with the L module, then you must implement the following method as well. =over 4 =item apache_request_to_comp_path ($r, @comp_root_array) This method, given an Apache object and a list of component root pairs, should return a component path or undef if none exists. This method is used by the L class to translate web requests into component paths. You can omit this method if your resolver subclass will never be used in conjunction with L. =back =cut HTML-Mason-1.59/lib/HTML/Mason/FakeApache.pm0000644000175000017500000002734613660015140020034 0ustar autarchautarchpackage HTML::Mason::FakeApache; $HTML::Mason::FakeApache::VERSION = '1.59'; use strict; use warnings; # We need to define an Apache package or we might get strange errors # like "Can't locate package Apache for # @HTML::Mason::FakeApache::ISA". We do the BEGIN/eval thing so that # the CPAN indexer doesn't pick it up, which would be ugly. BEGIN { eval "package Apache" } @HTML::Mason::FakeApache::ISA = qw(Apache); # Analogous to Apache request object $r (but not an actual Apache subclass) # In the future we'll probably want to switch this to Apache::Fake or similar use HTML::Mason::MethodMaker(read_write => [qw(query)]); sub new { my $class = shift; my %p = @_; return bless { query => $p{cgi} || CGI->new, headers_out => HTML::Mason::FakeTable->new, err_headers_out => HTML::Mason::FakeTable->new, pnotes => {}, }, $class; } # CGI request are _always_ main, and there is never a previous or a next # internal request. sub main {} sub prev {} sub next {} sub is_main {1} sub is_initial_req {1} # What to do with this? # sub allowed {} sub method { $_[0]->query->request_method; } # There mut be a mapping for this. # sub method_number {} # Can CGI.pm tell us this? # sub bytes_sent {0} # The request line sent by the client." Poached from Apache::Emulator. sub the_request { my $self = shift; $self->{the_request} ||= join ' ', $self->method, ( $self->{query}->query_string ? $self->uri . '?' . $self->{query}->query_string : $self->uri ), $self->{query}->server_protocol; } # Is CGI ever a proxy request? # sub proxy_req {} sub header_only { $_[0]->method eq 'HEAD' } sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' } sub hostname { $_[0]->{query}->server_name } # CGI says "use this when using virtual hosts". It falls back to # CGI->server_port. sub get_server_port { $_[0]->{query}->virtual_port } # Fake it by just giving the current time. sub request_time { time } sub uri { my $self = shift; $self->{uri} ||= $self->{query}->script_name . $self->path_info || ''; } # Is this available in CGI? # sub filename {} # "The $r->location method will return the path of the # section from which the current "Perl*Handler" # is being called." This is irrelevant, I think. # sub location {} sub path_info { $_[0]->{query}->path_info } sub args { my $self = shift; if (@_) { # Assign args here. } return $self->{query}->Vars unless wantarray; # Do more here to return key => arg values. } sub headers_in { my $self = shift; # Create the headers table if necessary. Decided how to build it based on # information here: # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1 # # Try to get as much info as possible from CGI.pm, which has # workarounds for things like the IIS PATH_INFO bug. # $self->{headers_in} ||= HTML::Mason::FakeTable->new ( 'Authorization' => $self->{query}->auth_type, # No credentials though. 'Content-Length' => $ENV{CONTENT_LENGTH}, 'Content-Type' => ( $self->{query}->can('content_type') ? $self->{query}->content_type : $ENV{CONTENT_TYPE} ), # Convert HTTP environment variables back into their header names. map { my $k = ucfirst lc; $k =~ s/_(.)/-\u$1/g; ( $k => $self->{query}->http($_) ) } grep { s/^HTTP_// } keys %ENV ); # Give 'em the hash list of the hash table. return wantarray ? %{$self->{headers_in}} : $self->{headers_in}; } sub header_in { my ($self, $header) = (shift, shift); my $h = $self->headers_in; return @_ ? $h->set($header, shift) : $h->get($header); } # The $r->content method will return the entity body # read from the client, but only if the request content # type is "application/x-www-form-urlencoded". When # called in a scalar context, the entire string is # returned. When called in a list context, a list of # parsed key => value pairs are returned. *NOTE*: you # can only ask for this once, as the entire body is read # from the client. # Not sure what to do with this one. # sub content {} # I think this may be irrelevant under CGI. # sub read {} # Use LWP? sub get_remote_host {} sub get_remote_logname {} sub http_header { my $self = shift; my $h = $self->headers_out; my $e = $self->err_headers_out; my $method = exists $h->{Location} || exists $e->{Location} ? 'redirect' : 'header'; return $self->query->$method(tied(%$h)->cgi_headers, tied(%$e)->cgi_headers); } sub send_http_header { my $self = shift; return if $self->http_header_sent; print STDOUT $self->http_header; $self->{http_header_sent} = 1; } sub http_header_sent { shift->{http_header_sent} } # How do we know this under CGI? # sub get_basic_auth_pw {} # sub note_basic_auth_failure {} # I think that this just has to be empty. sub handler {} sub notes { my ($self, $key) = (shift, shift); $self->{notes} ||= HTML::Mason::FakeTable->new; return wantarray ? %{$self->{notes}} : $self->{notes} unless defined $key; return $self->{notes}{$key} = "$_[0]" if @_; return $self->{notes}{$key}; } sub pnotes { my ($self, $key) = (shift, shift); return wantarray ? %{$self->{pnotes}} : $self->{pnotes} unless defined $key; return $self->{pnotes}{$key} = $_[0] if @_; return $self->{pnotes}{$key}; } sub subprocess_env { my ($self, $key) = (shift, shift); unless (defined $key) { $self->{subprocess_env} = HTML::Mason::FakeTable->new(%ENV); return wantarray ? %{$self->{subprocess_env}} : $self->{subprocess_env}; } $self->{subprocess_env} ||= HTML::Mason::FakeTable->new(%ENV); return $self->{subprocess_env}{$key} = "$_[0]" if @_; return $self->{subprocess_env}{$key}; } sub content_type { shift->header_out('Content-Type', @_); } sub content_encoding { shift->header_out('Content-Encoding', @_); } sub content_languages { my ($self, $langs) = @_; return unless $langs; my $h = shift->headers_out; for my $l (@$langs) { $h->add('Content-Language', $l); } } sub status { shift->header_out('Status', @_); } sub status_line { # What to do here? Should it be managed differently than status? my $self = shift; if (@_) { my $status = shift =~ /^(\d+)/; return $self->header_out('Status', $status); } return $self->header_out('Status'); } sub headers_out { my $self = shift; return wantarray ? %{$self->{headers_out}} : $self->{headers_out}; } sub header_out { my ($self, $header) = (shift, shift); my $h = $self->headers_out; return @_ ? $h->set($header, shift) : $h->get($header); } sub err_headers_out { my $self = shift; return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out}; } sub err_header_out { my ($self, $err_header) = (shift, shift); my $h = $self->err_headers_out; return @_ ? $h->set($err_header, shift) : $h->get($err_header); } sub no_cache { my $self = shift; $self->header_out(Pragma => 'no-cache'); $self->header_out('Cache-Control' => 'no-cache'); } sub print { shift; print @_; } sub send_fd { my ($self, $fd) = @_; local $_; print STDOUT while defined ($_ = <$fd>); } # Should this perhaps throw an exception? # sub internal_redirect {} # sub internal_redirect_handler {} # Do something with ErrorDocument? # sub custom_response {} # I think we've made this essentially the same thing. BEGIN { local $^W; *send_cgi_header = \&send_http_header; } # Does CGI support logging? # sub log_reason {} # sub log_error {} sub warn { shift; print STDERR @_, "\n"; } sub params { my $self = shift; return HTML::Mason::Utils::cgi_request_args($self->query, $self->query->request_method); } 1; ########################################################### package HTML::Mason::FakeTable; $HTML::Mason::FakeTable::VERSION = '1.59'; # Analogous to Apache::Table. use strict; use warnings; sub new { my $class = shift; my $self = {}; tie %{$self}, 'HTML::Mason::FakeTableHash'; %$self = @_ if @_; return bless $self, ref $class || $class; } sub set { my ($self, $header, $value) = @_; defined $value ? $self->{$header} = $value : delete $self->{$header}; } sub unset { my $self = shift; delete $self->{shift()}; } sub add { tied(%{shift()})->add(@_); } sub clear { %{shift()} = (); } sub get { tied(%{shift()})->get(@_); } sub merge { my ($self, $key, $value) = @_; if (defined $self->{$key}) { $self->{$key} .= ',' . $value; } else { $self->{$key} = "$value"; } } sub do { my ($self, $code) = @_; while (my ($k, $val) = each %$self) { for my $v (ref $val ? @$val : $val) { return unless $code->($k => $v); } } } ########################################################### package HTML::Mason::FakeTableHash; $HTML::Mason::FakeTableHash::VERSION = '1.59'; # Used by HTML::Mason::FakeTable. use strict; use warnings; sub TIEHASH { my $class = shift; return bless {}, ref $class || $class; } sub _canonical_key { my $key = lc shift; # CGI really wants a - before each header return substr( $key, 0, 1 ) eq '-' ? $key : "-$key"; } sub STORE { my ($self, $key, $value) = @_; $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ]; } sub add { my ($self, $key) = (shift, shift); return unless defined $_[0]; my $value = ref $_[0] ? "$_[0]" : $_[0]; my $ckey = _canonical_key $key; if (exists $self->{$ckey}) { if (ref $self->{$ckey}[1]) { push @{$self->{$ckey}[1]}, $value; } else { $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ]; } } else { $self->{$ckey} = [ $key => $value ]; } } sub DELETE { my ($self, $key) = @_; my $ret = delete $self->{_canonical_key $key}; return $ret->[1]; } sub FETCH { my ($self, $key) = @_; # Grab the values first so that we don't autovivicate the key. my $val = $self->{_canonical_key $key} or return; if (my $ref = ref $val->[1]) { return unless $val->[1][0]; # Return the first value only. return $val->[1][0]; } return $val->[1]; } sub get { my ($self, $key) = @_; my $ckey = _canonical_key $key; return unless exists $self->{$ckey}; return $self->{$ckey}[1] unless ref $self->{$ckey}[1]; return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0]; } sub CLEAR { %{shift()} = (); } sub EXISTS { my ($self, $key)= @_; return exists $self->{_canonical_key $key}; } sub FIRSTKEY { my $self = shift; # Reset perl's iterator. keys %$self; # Get the first key via perl's iterator. my $first_key = each %$self; return undef unless defined $first_key; return $self->{$first_key}[0]; } sub NEXTKEY { my ($self, $nextkey) = @_; # Get the next key via perl's iterator. my $next_key = each %$self; return undef unless defined $next_key; return $self->{$next_key}[0]; } sub cgi_headers { my $self = shift; map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self; } sub _map_header_key_to_cgi_key { return $_[0] eq '-set-cookie' ? '-cookies' : $_[0]; } 1; __END__ =head1 NAME HTML::Mason::FakeApache - An Apache object emulator for use with Mason =head1 SYNOPSIS See L. =head1 DESCRIPTION This class's API is documented in L. =cut HTML-Mason-1.59/lib/HTML/Mason/Devel.pod0000644000175000017500000022723013660015140017263 0ustar autarchautarch=head1 NAME HTML::Mason::Devel - Mason Developer's Manual =head1 DESCRIPTION This manual is written for content developers who know HTML and at least a little Perl. The goal is to write, run, and debug Mason components. If you are the webmaster (or otherwise responsible for the Mason installation), you should also read L. There you will find information about site configuration, performance tuning, component caching, and so on. If you are a developer just interested in knowing more about Mason's capabilities and implementation, then L is for you too. We strongly suggest that you have a working Mason to play with as you work through these examples. Other component examples can be found in the C directory. While Mason can be used for tasks besides implementing a dynamic web site, that is what I people want to do with Mason, and is thus the focus of this manual. If you are planning to use Mason outside of the web, this manual will still be useful, of course. Also make sure to read the L section of the administrator's manual. =head1 HOW TO USE THIS MANUAL If you are just learning Mason and want to get started quickly, we recommend the following sections: o L o L o L o L o L o L (mainly C<< <%init> >>) o L o L =head1 WHAT ARE COMPONENTS? The component - a mix of Perl and HTML - is Mason's basic building block and computational unit. Under Mason, web pages are formed by combining the output from multiple components. An article page for a news publication, for example, might call separate components for the company masthead, ad banner, left table of contents, and article body. Consider this layout sketch: +---------+------------------+ |Masthead | Banner Ad | +---------+------------------+ | | | |+-------+|Text of Article ..| || || | ||Related||Text of Article ..| ||Stories|| | || ||Text of Article ..| |+-------+| | | +------------------+ | | Footer | +---------+------------------+ The top level component decides the overall page layout, perhaps with HTML tables. Individual cells are then filled by the output of subordinate components, one for the Masthead, one for the Footer, etc. In practice pages are built up from as few as one, to as many as twenty or more components. This component approach reaps many benefits in a web environment. The first benefit is I: by embedding standard design elements in components, you ensure a consistent look and make it possible to update the entire site with just a few edits. The second benefit is I: in a multi-person environment, one person can edit the masthead while another edits the table of contents. A last benefit is I: a component produced for one site might be useful on another. You can develop a library of generally useful components to employ on your sites and to share with others. Most components emit chunks of HTML. "Top level" components, invoked from a URL, represent an entire web page. Other, subordinate components emit smaller bits of HTML destined for inclusion in top level components. Components receive form and query data from HTTP requests. When called from another component, they can accept arbitrary parameter lists just like a subroutine, and optionally return values. This enables a type of component that does not print any HTML, but simply serves as a function, computing and returning a result. Mason actually compiles components down to Perl subroutines, so you can debug and profile component-based web pages with standard Perl tools that understand the subroutine concept, e.g. you can use the Perl debugger to step through components, and B to profile their performance. =head1 IN-LINE PERL SECTIONS Here is a simple component example: <%perl> my $noun = 'World'; my @time = localtime; Hello <% $noun %>, % if ( $time[2] < 12 ) { good morning. % } else { good afternoon. % } After 12 pm, the output of this component is: Hello World, good afternoon. This short example demonstrates the three primary "in-line" Perl sections. In-line sections are generally embedded within HTML and execute in the order they appear. Other sections (C<< <%init> >>, C<< <%args> >>, etc.) are tied to component events like initialization, cleanup, and argument definition. The parsing rules for these Perl sections are as follows: =over =item 1. Blocks of the form <% xxx %> are replaced with the result of evaluating xxx as a single Perl expression. These are often used for variable replacement. such as 'Hello, <% $name %>!'. =item 2. Lines beginning with a '%' character are treated as Perl. =item 3. Multiline blocks of Perl code can be inserted with the C<< <%perl> >> .. C<< >> tag. The enclosed text is executed as Perl and the return value, if any, is discarded. The C<< <%perl> >> tag, like all block tags in Mason, is case-insensitive. It may appear anywhere in the text, and may span any number of lines. =back =head2 Examples and Recommended Usage B<% lines> Most useful for conditional and loop structures - if, while, foreach, , etc. - as well as side-effect commands like assignments. To improve readability, always put a space after the '%'. Examples: o Conditional code % my $ua = $r->header_in('User-Agent'); % if ($ua =~ /msie/i) { Welcome, Internet Explorer users ... % } elsif ($ua =~ /mozilla/i) { Welcome, Netscape users ... % } o HTML list formed from array
    % foreach $item (@list) {
  • <% $item %>
    • % }
o HTML list formed from hash
    % while (my ($key,$value) = each(%ENV)) {
  • <% $key %>: <% $value %>
    • % }
o HTML table formed from list of hashes % foreach my $h (@loh) { % }
<% $h->{foo} %> <% $h->{bar} %> <% $h->{baz} %>
B<< <% xxx %> >> Most useful for printing out variables, as well as more complex expressions. To improve readability, always separate the tag and expression with spaces. Examples: Dear <% $name %>: We will come to your house at <% $address %> in the fair city of <% $city %> to deliver your $<% $amount %> dollar prize! The answer is <% ($y+8) % 2 %>. You are <% $age < 18 ? 'not' : '' %> permitted to enter this site. B<< <%perl> xxx >> Useful for Perl blocks of more than a few lines. =head1 MASON OBJECTS This section describes the various objects in the Mason universe. If you're just starting out, all you need to worry about initially are the request objects. =head2 Request Objects Two global per-request objects are available to all components: $r and $m. $r, the mod_perl request object, provides a Perl API to the current Apache request. It is fully described in Apache.pod. Here is a sampling of methods useful to component developers: $r->uri # the HTTP request URI $r->header_in(..) # get the named HTTP header line $r->content_type # set or retrieve content-type $r->header_out(..) # set or retrieve an outgoing header $r->content # don't use this one! (see Tips and Traps) $m, the Mason request object, provides an analogous API for Mason. Almost all Mason features not activated by syntactic tags are accessed via $m methods. You'll be introduced to these methods throughout this document as they are needed. For a description of all methods see B>. Because these are always set inside components, you should not ever define other variables with the same name, or else your code may fail in strange and mysterious ways. =head2 Component Objects Mason provides an object API for components, allowing you to query a component's various associated files, arguments, etc. For a description of all methods see B>. Typically you get a handle on a component object from request methods like C<< $m->current_comp >> and C<< $m->fetch_comp >>. Note that for many basic applications all you'll want to do with components is call them, for which no object method is needed. See next section. =head2 System Objects Many system objects share the work of serving requests in Mason: L, L, L, L, and L are examples. The administrator creates these objects and provides parameters that shape Mason's behavior. As a pure component developer you shouldn't need to worry about or access these objects, but occasionally we'll mention a relevant parameter. =head1 CALLING COMPONENTS Mason pages often are built not from a single component, but from multiple components that call each other in a hierarchical fashion. =head2 Components that output HTML To call one component from another, use the <& &> tag: <& comp_path, [name=>value, ...] &> =over =item comp_path: The component path. With a leading '/', the path is relative to the component root (L). Otherwise, it is relative to the location of the calling component. =item name => value pairs: Parameters are passed as one or more C<< name => value >> pairs, e.g. S 'M. Jordan' >>>. =back comp_path may be a literal string (quotes optional) or a Perl expression that evaluates to a string. To eliminate the need for quotes in most cases, Mason employs some magic parsing: If the first character is one of C<[\w/_.]>, comp_path is assumed to be a literal string running up to the first comma or &>. Otherwise, comp_path is evaluated as an expression. Here are some examples: # relative component paths <& topimage &> <& tools/searchbox &> # absolute component path <& /shared/masthead, color=>'salmon' &> # this component path MUST have quotes because it contains a comma <& "sugar,eggs", mix=>1 &> # variable component path <& $comp &> # variable component and arguments <& $comp, %args &> # you can use arbitrary expression for component path, but it cannot # begin with a letter or number; delimit with () to remedy this <& (int(rand(2)) ? 'thiscomp' : 'thatcomp'), id=>123 &> Several request methods also exist for calling components. C<< $m->comp >> performs the equivalent action to <& &>: $m->comp('/shared/masthead', color=>'salmon'); C<< $m->scomp >> is like the sprintf version of C<< $m->comp >>: it returns the component output, allowing the caller to examine and modify it before printing: my $masthead = $m->scomp('/shared/masthead', color=>'salmon'); $masthead =~ ...; $m->print($masthead); =head2 Component Calls with Content Components can be used to filter part of the page's content using an extended component syntax. <&| /path/to/comp &> this is the content <&| comp, arg1 => 'hi' &> filters can take arguments <&| comp &> content can include <% "tags" %> of all kinds <&| comp1 &> nesting is also <&| comp2 &> OK <&| SELF:method1 &> subcomponents can be filters The filtering component can be called in all the same ways a normal component is called, with arguments and so forth. The only difference between a filtering component and a normal component is that a filtering component is expected to fetch the content by calling $m->content and do something with it. The ending tag may optionally contain the name of the component, and Mason will verify that it matches the name in the starting tag. This may be helpful when the tags are far apart or nested. To avoid ambiguous situations, this is only allowed when the component name is an unquoted literal (starting with C<[\w/_.]>). For anything more complicated, such as C<< <|& $var &> >> or C<< <&| 'name' &> >>, the simple C<< >> form must be used. <&| "outer" &> <&| /inner/comp, arg=>'this' &> <&| .mycomp &> Yada yada yada Here is an example of a component used for localization. Its content is a series of strings in different languages, and it selects the correct one based on a global C<$lang> variable, which could be setup in a site-level autohandler. <&| /i18n/itext &> Hello, <% $name %> This is a string in English Schoene Gruesse, <% $name %>, diese Worte sind auf Deutsch ellohay <% substr($name,2).substr($name,1,1).'ay' %>, isthay isay igpay atinlay Here is the F component: <% $text %> <%init> # this assumes $lang is a global variable which has been set up earlier. local $_ = $m->content; my ($text) = m{<$lang>(.*?)}; You can explicitly check whether a component has passed content by checking the boolean C<< $m->has_content >>. This allows you to write a component that will do different things depending on whether it was passed content. However, before overloading a component in this way, consider whether splitting the behavior into two distinct components would work as well. If a normal component which does not call C<< $m->content >> is called with content, the content will not be output. If you wrap a filtering component call around the entire component, the result will be functionally similar to a C<< <%filter> >> section. See also L. =head2 Advanced Components Calls with Content Internally C<< $m->content >> is implemented with a closure containing the part of the component which is the content. In English, that means that any mason tags and perl code in the content are evaluated when C<< $m->content >> is called, and C<< $m->content >> returns the text which would have been output by mason. Because the contents are evaluated at the time that C<< $m->content >> is called, one can write components which act as control structures or which output their contents multiple times with different values for the variables (can you say taglibs?). The tricky part of using filter components as control structures is setting up variables which can be accessed from both the filter component and the content, which is in the component which calls the filter component. The content has access to all variables in the surrounding component, but the filtering component does not. There are two ways to do this: use global variables, or pass a reference to a lexical variable to the filter component. Here is a simple example using the second method: % my $var;
    <&| list_items , list => \@items, var => \$var &>
  1. <% $var %>
list_items component: <%args> @list $var % foreach (@list) { % $$var = $_; # $var is a reference <% $m->content %> % } Using global variables can be somewhat simpler. Below is the same example, with C<$var> defined as a global variable. The site administrator must make sure that C<$var> is included in Mason's allow_globals parameter. Local-izing C<$var> within the filter component will allow the list_items component to be nested.
    <&| list_items, list => \@items &>
  1. <% $var %>
list_items component: <%args> @list % foreach (@list) { % local $var = $_; <% $m->content %> % } Besides remembering to include C<$var> in allow_globals, the developers should take care not to use that variable is other places where it might conflict with usage by the filter component. Local-izing $var will also provide some protection against using it in other places. An even simpler method is to use the C<$_> variable. It is already global, and is automatically local-ized by the foreach statement:
    <&| list_items, list => \@items &>
  1. <% $_ %>
list_items component: <%args> @list % foreach (@list) { <% $m->content %> % } =head2 Components that Return Values So far you have seen components used solely to output HTML. However, components may also be used to return values. While we will demonstrate how this is done, we strongly encourage you to put code like this in modules instead. There are several reasons why this is a good idea: =over 4 =item * You can re-use this code outside of Mason. =item * It is easy to preload module code when running under mod_perl, which can lower memory usage. =item * Using Mason components as subroutines is slower than just using modules to do the same thing. =item * It's easier to regression test module code. =back With that being said, there are times when you may want to write a component which returns a value. As an example, you might have a component C that analyzes the user agent to determine whether it is a Netscape browser: <%init> my $ua = $r->header_in('User-Agent'); return ($ua =~ /Mozilla/i && $ua !~ /MSIE/i) ? 1 : 0; Because components are implemented underneath with Perl subroutines, they can return values and even understand scalar/list context. e.g. The result of wantarray() inside a component will reflect whether the component was called in scalar or list context. The <& &> notation only calls a component for its side-effect, and discards its return value, if any. To get at the return value of a component, use the C<< $m->comp >> command: % if ($m->comp('is_netscape')) { Welcome, Netscape user! % } Mason adds a C to the bottom of each component to provide an empty default return value. To return your own value from a component, you I use an explicit C statement. You cannot rely on the usual Perl trick of letting return values "fall through". While it is possible for a component to generate output B return values, there is very little reason for a component to do both. For example, it would not be very friendly for C to output "hi Mom" while it was computing its value, thereby surprising the C statement! Conversely, any value returned by an output generating component would typically be discarded by the <& &> tag that invoked it. =head2 Subrequests You may sometimes want to have a component call go through all the steps that the initial component call goes through, such as checking for autohandlers and dhandlers. To do this, you need to execute a subrequest. A subrequest is simply a Mason Request object and has all of the methods normally associated with one. To create a subrequest you simply use the C<< $m->make_subrequest >> method. This method can take any parameters belonging to L, such as L or L. Once you have a new request object you simply call its C method to execute it, which takes exactly the same parameters as the C method. Since subrequests inherit their parent request's parameters, output from a component called via a subrequest goes to the same destination as output from components called during the parent request. Of course, you can change this. Here are some examples: <%perl> my $req = $m->make_subrequest( comp => '/some/comp', args => [ id => 172 ] ); $req->exec; If you want to capture the subrequest's output in a scalar, you can simply pass an L parameter to C<< $m->make_subrequest >>: <%perl> my $buffer; my $req = $m->make_subrequest ( comp => '/some/comp', args => [ id => 172 ], out_method => \$buffer ); $req->exec; Now C<$buffer> contains all the output from that call to F. For convenience, Mason also provides an C<< $m->subexec >> method. This method takes the same arguments as C<< $m->comp >> and internally calls C<< $m->make_subrequest >> and then C on the created request, all in one fell swoop. This is useful in cases where you have no need to override any of the parent request object's attributes. By default, output from a subrequest appears inline in the calling component, at the point where it is executed. If you wish to do something else, you will need to explicitly override the subrequest's L parameter. Mason Request objects are only designed to handle a single call to C. If you wish to make multiple subrequests, you must create a new subrequest object for each one. =head1 TOP-LEVEL COMPONENTS The first component invoked for a page (the "top-level component") resides within the DocumentRoot and is chosen based on the URL. For example: http://www.foo.com/mktg/prods.html?id=372 Mason converts this URL to a filename, e.g. F. Mason loads and executes that file as a component. In effect, Mason calls $m->comp('/mktg/prods.html', id=>372) This component might in turn call other components and execute some Perl code, or it might contain nothing more than static HTML. =head2 dhandlers What happens when a user requests a component that doesn't exist? In this case Mason scans backward through the URI, checking each directory for a component named I ("default handler"). If found, the dhandler is invoked and is expected to use C<< $m->dhandler_arg >> as the parameter to some access function, perhaps a database lookup or location in another filesystem. In a sense, dhandlers are similar in spirit to Perl's AUTOLOAD feature; they are the "component of last resort" when a URL points to a non-existent component. Consider the following URL, in which F exists but not the subdirectory F nor the component F: http://myserver/newsfeeds/LocalNews/Story1 In this case Mason constructs the following search path: /newsfeeds/LocalNews/Story1 => no such thing /newsfeeds/LocalNews/dhandler => no such thing /newsfeeds/dhandler => found! (search ends) /dhandler The found dhandler would read "LocalNews/Story1" from C<< $m->dhandler_arg >> and use it as a retrieval key into a database of stories. Here's how a simple /newsfeeds/dhandler might look: <& header &> <% $headline %>

<% $body %> <& footer &> <%init> my $arg = $m->dhandler_arg; # get rest of path my ($section, $story) = split("/", $arg); # split out pieces my $sth = $DBH->prepare (qq{SELECT headline,body FROM news WHERE section = ? AND story = ?); $sth->execute($section, $story); my ($headline, $body) = $sth->fetchrow_array; return 404 if !$headline; # return "not found" if no such story By default dhandlers do not get a chance to handle requests to a directory itself (e.g. F). These are automatically deferred to Apache, which generates an index page or a FORBIDDEN error. Often this is desirable, but if necessary the administrator can let in directory requests as well; see the L section of the administrator's manual. A component or dhandler that does not want to handle a particular request may defer control to the next dhandler by calling C<< $m->decline >>. When using dhandlers under mod_perl, you may find that sometimes Apache will not set a content type for a response. This usually happens when a dhandler handles a request for a non-existent file or directory. You can add a C<< >> or C<< >> block containing a C directive to your Apache config file, or you can just set the content type dynamically by calling C<< $r->content_type >>. The administrator can customize the file name used for dhandlers with the L parameter. =head2 autohandlers Autohandlers allow you to grab control and perform some action just before Mason calls the top-level component. This might mean adding a standard header and footer, applying an output filter, or setting up global variables. Autohandlers are directory based. When Mason determines the top-level component, it checks that directory and all parent directories for a component called F. If found, the autohandler is called first. After performing its actions, the autohandler typically calls C<< $m->call_next >> to transfer control to the original intended component. C<< $m->call_next >> works just like C<< $m->comp >> except that the component path and arguments are implicit. You can pass additional arguments to C<< $m->call_next >>; these are merged with the original arguments, taking precedence in case of conflict. This allows you, for example, to override arguments passed in the URL. Here is an autohandler that adds a common header and footer to each page underneath its directory: McHuffy Incorporated % $m->call_next;

Copyright 1999 McHuffy Inc. Same idea, using components for the header/footer: <& /shared/header &> % $m->call_next; <& /shared/footer &> The next autohandler applies a filter to its pages, adding an absolute hostname to relative image URLs: % $m->call_next; <%filter> s{(]+src=\")/} {$1http://images.mysite.com/}ig; Most of the time autohandler can simply call C<< $m->call_next >> without needing to know what the next component is. However, should you need it, the component object is available from C<< $m->fetch_next >>. This is useful for calling the component manually, e.g. if you want to suppress some original arguments or if you want to use C<< $m->scomp >> to store and process the output. If more than one autohandler applies to a page, each autohandler gets a chance to run. The top-most autohandler runs first; each C<< $m->call_next >> transfers control to the next autohandler and finally to the originally called component. This allows you, for example, to combine general site-wide templates and more specific section-based templates. Autohandlers can be made even more powerful in conjunction with Mason's object-oriented style features: methods, attributes, and inheritance. In the interest of space these are discussed in a separate section, L. The administrator can customize the file name used for autohandlers with the L parameter. =head2 dhandlers vs. autohandlers dhandlers and autohandlers both provide a way to exert control over a large set of URLs. However, each specializes in a very different application. The key difference is that dhandlers are invoked only when no appropriate component exists, while autohandlers are invoked only in conjunction with a matching component. As a rule of thumb: use an autohandler when you have a set of components to handle your pages and you want to augment them with a template/filter. Use a dhandler when you want to create a set of "virtual URLs" that don't correspond to any actual components, or to provide default behavior for a directory. dhandlers and autohandlers can even be used in the same directory. For example, you might have a mix of real URLs and virtual URLs to which you would like to apply a common template/filter. =head1 PASSING PARAMETERS This section describes Mason's facilities for passing parameters to components (either from HTTP requests or component calls) and for accessing parameter values inside components. =head2 In Component Calls Any Perl data type can be passed in a component call: <& /sales/header, s => 'dog', l => [2, 3, 4], h => {a => 7, b => 8} &> This command passes a scalar ($s), a list (@l), and a hash (%h). The list and hash must be passed as references, but they will be automatically dereferenced in the called component. =head2 In HTTP requests Consider a CGI-style URL with a query string: http://www.foo.com/mktg/prods.html?str=dog&lst=2&lst=3&lst=4 or an HTTP request with some POST content. Mason automatically parses the GET/POST values and makes them available to the component as parameters. =head2 Accessing Parameters Component parameters, whether they come from GET/POST or another component, can be accessed in two ways. 1. Declared named arguments: Components can define an C<< <%args> >> section listing argument names, types, and default values. For example: <%args> $a @b # a comment %c # another comment $d => 5 $e => $d*2 @f => ('foo', 'baz') %g => (joe => 1, bob => 2) Here, I<$a>, I<@b>, and I<%c> are required arguments; the component generates an error if the caller leaves them unspecified. I<$d>, I<$e>, I<@f> and I<%g> are optional arguments; they are assigned the specified default values if unspecified. All the arguments are available as lexically scoped ("my") variables in the rest of the component. Arguments are separated by one or more newlines. Comments may be used at the end of a line or on their own line. Default expressions are evaluated in top-to-bottom order, and one expression may reference an earlier one (as $e references $d above). Only valid Perl variable names may be used in C<< <%args> >> sections. Parameters with non-valid variable names cannot be pre-declared and must be fetched manually out of the %ARGS hash (see below). One common example of undeclarable parameters are the "button.x/button.y" parameters sent for a form submit. 2. %ARGS hash: This variable, always available, contains all of the parameters passed to the component (whether or not they were declared). It is especially handy for dealing with large numbers of parameters, dynamically named parameters, or parameters with non-valid variable names. %ARGS can be used with or without an C<< <%args> >> section, and its contents are unrelated to what you have declared in C<< <%args> >>. Here's how to pass all of a component's parameters to another component: <& template, %ARGS &> =head2 Parameter Passing Examples The following examples illustrate the different ways to pass and receive parameters. 1. Passing a scalar I with value 5. In a URL: /my/URL?id=5 In a component call: <& /my/comp, id => 5 &> In the called component, if there is a declared argument named... $id, then $id will equal 5 @id, then @id will equal (5) %id, then an error occurs In addition, $ARGS{id} will equal 5. 2. Passing a list I with values red, blue, and green. In a URL: /my/URL?colors=red&colors=blue&colors=green In an component call: <& /my/comp, colors => ['red', 'blue', 'green'] &> In the called component, if there is a declared argument named... $colors, then $colors will equal ['red', 'blue', 'green'] @colors, then @colors will equal ('red', 'blue', 'green') %colors, then an error occurs In addition, $ARGS{colors} will equal ['red', 'blue', 'green']. 3. Passing a hash I with pairs Alice => 92 and Bob => 87. In a URL: /my/URL?grades=Alice&grades=92&grades=Bob&grades=87 In an component call: <& /my/comp, grades => {Alice => 92, Bob => 87} &> In the called component, if there is a declared argument named... @grades, then @grades will equal ('Alice', 92, 'Bob', 87) %grades, then %grades will equal (Alice => 92, Bob => 87) In addition, $grade and $ARGS{grades} will equal ['Alice',92,'Bob',87] in the URL case, or {Alice => 92, Bob => 87} in the component call case. (The discrepancy exists because, in a query string, there is no detectable difference between a list or hash.) =head2 Using @_ instead If you don't like named parameters, you can pass a traditional list of ordered parameters: <& /mktg/prods.html', 'dog', [2, 3, 4], {a => 7, b => 8} &> and access them as usual through Perl's @_ array: my ($scalar, $listref, $hashref) = @_; In this case no C<< <%args> >> section is necessary. We generally recommend named parameters for the benefits of readability, syntax checking, and default value automation. However using C<@_> may be convenient for very small components, especially subcomponents created with C<< <%def> >>. Before Mason 1.21, @_ contained I of the caller's arguments. In Mason 1.21 and beyond, this unnecessary copying was eliminated and @_ now contains I to the caller's arguments, just as with regular Perl subroutines. For example, if a component updates $_[0], the corresponding argument is updated (or an error occurs if it is not updateable). Most users won't notice this change because C<< <%args> >> variables and the C<%ARGS> hash always contain copies of arguments. See perlsub for more information on @_ aliasing. =head1 INITIALIZATION AND CLEANUP The following sections contain blocks of Perl to execute at specific times. =head2 <%init> This section contains initialization code that executes as soon as the component is called. For example: checking that a user is logged in; selecting rows from a database into a list; parsing the contents of a file into a data structure. Technically an C<< <%init> >> block is equivalent to a C<< <%perl> >> block at the beginning of the component. However, there is an aesthetic advantage of placing this block at the end of the component rather than the beginning. We've found that the most readable components (especially for non-programmers) contain HTML in one continuous block at the top, with simple substitutions for dynamic elements but no distracting blocks of Perl code. At the bottom an C<< <%init> >> block sets up the substitution variables. This organization allows non-programmers to work with the HTML without getting distracted or discouraged by Perl code. For example: <% $headline %>

<% $headline %>

By <% $author %>, <% $date %>

<% $body %> <%init> # Fetch article from database my $dbh = DBI::connect ...; my $sth = $dbh->prepare("select * from articles where id = ?"); $sth->execute($article_id); my ($headline, $date, $author, $body) = $sth->fetchrow_array; # Massage the fields $headline = uc($headline); my ($year, $month, $day) = split('-', $date); $date = "$month/$day"; <%args> $article_id =head2 <%cleanup> This section contains cleanup code that executes just before the component exits. For example: closing a database connection or closing a file handle. A C<< <%cleanup> >> block is equivalent to a C<< <%perl> >> block at the end of the component. This means it will NOT execute if the component explicitly returns, or if an abort or error occurs in that component or one of its children. Because of this limitation, and because Perl is usually so good about cleaning up at the end of a lexical scope (e.g. component), C<< <%cleanup> >> sections are rarely needed. If you need code that is guaranteed to run when the component or request exits, consider using a mod_perl cleanup handler, or creating a custom class with a DESTROY method. =head2 <%once> This code executes once when the component is loaded. Variables declared in this section can be seen in all of a component's code and persist for the lifetime of the component. This section is useful for declaring persistent component-scoped lexical variables (especially objects that are expensive to create), declaring subroutines (both named and anonymous), and initializing state. This code does not run inside a request context. You cannot call components or access C<$m> or C<$r> from this section. Also, do not attempt to C from a C<< <%once> >> section; the current compiler cannot properly handle it. Normally this code will execute individually from every HTTP child that uses the component. However, if the component is preloaded, this code will only execute once in the parent. Unless you have total control over what components will be preloaded, it is safest to avoid initializing variables that can't survive a fork(), e.g. DBI handles. Use code like this to initialize such variables in the C<< <%init> >> section: <%once> my $dbh; # declare but don't assign ... <%init> $dbh ||= DBI::connect ... ... In addition, using C<$m> or C<$r> in this section will not work in a preloaded component, because neither of those variable exist when a component is preloaded. =head2 <%shared> As with C<< <%once> >>, lexical (C) variables declared in this section can be seen in all the rest of a component's code: the main body, subcomponents, and methods. However, unlike C<< <%once> >>, the code runs once per request (whenever the component is used) and its variables last only until the end of the request. A C<< <%shared> >> section is useful for initializing variables needed in, say, the main body and one more subcomponents or methods. See L for an example of usage. It's important to realize that you do not have access to the C<%ARGS> hash or variables created via an C<< <%args> >> block inside a shared section. However, you can access arguments via L<$m-Erequest_args|HTML::Mason::Request/item_request_args>. Additionally, you cannot call a components' own methods or subcomponents from inside a C<< <%shared> >>, though you can call other components. Avoid using C<< <%shared> >> for side-effect code that needs to run at a predictable time during page generation. You may assume only that C<< <%shared> >> runs just before the first code that needs it and runs at most once per request. In the current implementation, the scope sharing is done with closures, so variables will only be shared if they are visible at compile-time in the other parts of the component. In addition, you can't rely on the specific destruction time of the shared variables, because they may not be destroyed until the first time the C<< <%shared> >> section executes in a future request. C<< <%init> >> offers a more predictable execution and destruction time. Currently any component with a C<< <%shared> >> section incurs an extra performance penalty, because Mason must recreate its anonymous subroutines the first time each new request uses the component. The exact penalty varies between systems and for most applications will be unnoticeable. However, one should avoid using C<< <%shared> >> when patently unnecessary, e.g. when an C<< <%init> >> would work just as well. Do not attempt to C from a C<< <%shared> >> section; the current compiler cannot properly handle it. =head1 EMBEDDED COMPONENTS =head2 <%def I> Each instance of this section creates a I embedded inside the current component. Inside you may place anything that a regular component contains, with the exception of C<< <%def> >>, C<< <%method> >>, C<< <%once> >>, and C<< <%shared> >> tags. The I consists of characters in the set C<[\w._-]>. To call a subcomponent simply use its name in <& &> or C<< $m->comp >>. A subcomponent can only be seen from the surrounding component. If you define a subcomponent with the same name as a file-based component in the current directory, the subcomponent takes precedence. You would need to use an absolute path to call the file-based component. To avoid this situation and for general clarity, we recommend that you pick a unique way to name all of your subcomponents that is unlikely to interfere with file-based components. A commonly accepted practice is to start subcomponent names with ".". While inside a subcomponent, you may use absolute or relative paths to call file-based components and also call any of your "sibling" subcomponents. The lexical scope of a subcomponent is separate from the main component. However a subcomponent can declare its own C<< <%args> >> section and have relevant values passed in. You can also use a C<< <%shared> >> section to declare variables visible from both scopes. In the following example, we create a ".link" subcomponent to produce a standardized hyperlink: <%def .link> <% $label %> <%args> $site $label=>ucfirst($site) Visit these sites:
  • <& .link, site=>'yahoo' &>
  • <& .link, site=>'cmp', label=>'CMP Media' &>
  • <& .link, site=>'excite' &>
=head2 <%method I> Each instance of this section creates a I embedded inside the current component. Methods resemble subcomponents in terms of naming, contents, and scope. However, while subcomponents can only be seen from the parent component, methods are meant to be called from other components. There are two ways to call a method. First, via a path of the form "comp:method": <& /foo/bar:method1 &> $m->comp('/foo/bar:method1'); Second, via the call_method component method: my $comp = $m->fetch_comp('/foo/bar'); ... $comp->call_method('method1'); Methods are commonly used in conjunction with autohandlers to make templates more flexible. See L for more information. You cannot create a subcomponent and method with the same name. This is mostly to prevent obfuscation and accidental errors. =head1 FLAGS AND ATTRIBUTES The C<< <%flags> >> and C<< <%attr> >> sections consist of key/value pairs, one per line, joined by '=>'. In each pair, the key must be any valid Perl "bareword identifier" (made of letters, numbers, and the underscore character), and the value may be any scalar value, including references. An optional comment may follow each line. =head2 <%flags> Use this section to set official Mason flags that affect the current component's behavior. Currently there is only one flag, C, which specifies the component's I in the form of a relative or absolute component path. A component inherits methods and attributes from its parent; see L for examples. <%flags> inherit=>'/site_handler' =head2 <%attr> Use this section to assign static key/value attributes that can be queried from other components. <%attr> color => 'blue' fonts => [qw(arial geneva helvetica)] To query an attribute of a component, use the C method: my $color = $comp->attr('color') where $comp is a component object. Mason evaluates attribute values once when loading the component. This makes them faster but less flexible than methods. =head1 FILTERING This section describes several ways to apply filtering functions over the results of the current component. By separating out and hiding a filter that, say, changes HTML in a complex way, we allow non-programmers to work in a cleaner HTML environment. =head2 <%filter> section The C<< <%filter> >> section allows you to arbitrarily filter the output of the current component. Upon entry to this code, C<$_> contains the component output, and you are expected to modify it in place. The code has access to component arguments and can invoke subroutines, call other components, etc. This simple filter converts the component output to UPPERCASE: <%filter> tr/a-z/A-Z/ The following navigation bar uses a filter to "unlink" and highlight the item corresponding to the current page: Home | Products | Background | Financials | Tech Support | Contact Us <%filter> my $uri = $r->uri; s{(.*?)} {$1}i; This allows a designer to code such a navigation bar intuitively without C statements surrounding each link! Note that the regular expression need not be very robust as long as you have control over what will appear in the body. A filter block does not have access to variables declared in a component's C<< <%init> >> section, though variables declared in the C<< <%args> >>, C<< <%once> >> or C<< <%shared> >> blocks are usable in a filter. It should be noted that a filter cannot rely on receiving all of a component's output at once, and so may be called multiple times with different chunks of output. This can happen if autoflush is on, or if a filter-containing component, or the components it calls, call the C<< $m->flush_buffer() >> method. You should never call Perl's C function inside a filter section, or you will not see any output at all. You can use L if you want to filter specific parts of a component rather than the entire component. =head1 COMMENT MARKERS There are several ways to place comments in components, i.e. arbitrary text that is ignored by the parser. =head2 <%doc> Text in this section is treated as a comment and ignored. Most useful for a component's main documentation. One can easily write a program to sift through a set of components and pull out their C<< <%doc> >> blocks to form a reference page. =head2 <% # comment... %> A C<< <% %> >> tag is considered a comment if all of its lines are either whitespace, or begin with a '#' optionally preceded by whitespace. For example, <% # This is a single-line comment %> <% # This is a # multi-line comment %> =head2 %# comment Because a line beginning with C<%> is treated as Perl, C<%#> automatically works as a comment. However we prefer the C<< <% # comment %> >> form over C<< %# >>, because it stands out a little more as a comment and because it is more flexible with regards to preceding whitespace. =head2 % if (0) { } Anything between these two lines % if (0) { ... % } will be skipped by Mason, including component calls. While we don't recommend this for comments per se, it is a useful notation for "commenting out" code that you don't want to run. =head2 HTML/XML/... comments HTML and other markup languages will have their own comment markers, for example C<< >>. Note two important differences with these comments versus the above comments: =over =item * They will be sent to the client and appear in the source of the page. =item * They do not block component calls and other code from running, so don't try to use them to comment out code! =back =head1 OTHER SYNTAX =head2 <%text> Text in this section is printed as-is with all Mason syntax ignored. This is useful, for example, when documenting Mason itself from a component: <%text> % This is an example of a Perl line. <% This is an example of an expression block. %> This works for almost everything, but doesn't let you output C<< >> itself! When all else fails, use C<< $m->print >>: % $m->print('The tags are <%text> and .'); =head2 Escaping expressions Mason has facilities for I the output from C<< <% %> >> tags, on either a site-wide or a per-expression basis. Any C<< <% %> >> expression may be terminated by a '|' and one or more escape flags (plus arbitrary whitespace), separated by commas: <% $file_data |h %> The current valid flags are: =over =item * h Escape HTML ('<' => '<', etc.) using C. Before Perl 5.8.0 this module assumes that text is in the ISO-8859-1 character set; see L for how to override this escaping. After 5.8.0, the encoding assumes that text is in Unicode. =item * u Escape a URL query string (':' => '%3A', etc.) - all but [a-zA-Z0-9_.-] =item * n This is a special flag indicating that the default escape flags should I be used for this substitution. =back The administrator may specify a set of default escape flags via the L parameter. For example, if the administrator sets L to C<['h']>, then all <% %> expressions will automatically be HTML-escaped. In this case you would use the C flag to turn off HTML-escaping for a specific expression: <% $html_block |n %> Multiple escapes can be specified as a comma-separated list: <% $uri | u, n %> The old pre-defined escapes, 'h', 'u', and 'n', can be used I commas, so that this is legal: <% $uri | un %> However, this only works for these three escapes, and no others. If you are using user-defined escapes as well, you I use a comma: <% $uri | u, add_session %> =head3 User-defined Escapes Besides the default escapes mentioned above, it is possible for the user to define their own escapes or to override the built-in 'h' and 'u' escapes. This is done via the Interp object's L parameter or L method. Escape names may be any number of characters as long as it matches the regex C. The one exception is that you cannot override the 'n' flag. Each escape flag is associated with a subroutine reference. The subroutine should expect to receive a scalar reference, which should be manipulated in place. Any return value from this subroutine is ignored. Escapes can be defined at any time but using an escape that is not defined will cause an error when executing that component. A common use for this feature is to override the built-in HTML escaping, which will not work with non-ISO-8559-1 encodings. If you are using such an encoding and want to switch the 'h' flag to do escape just the minimal set of characters (C>, C>, C<&>, C<">), put this in your Apache configuration: PerlSetVar MasonEscapeFlags "h => \&HTML::Mason::Escapes::basic_html_escape" Or, in a top-level autohandler: $m->interp->set_escape( h => \&HTML::Mason::Escapes::basic_html_escape ); Or you could write your own escape function for a particular encoding: $ah->interp->set_escape( h => \&my_html_escape ); And of course this can be used for all sorts of other things, like a naughty words filter for the easily offended: $interp->set_escape( 'no-naughty' => \&remove_naughty_words ); =head3 Manually applying escapes You can manually apply one or more escapes to text using the L method|HTML::Mason::Interp/item_apply_escapes>. e.g. $m->interp->apply_escapes( 'some html content', 'h' ); =head2 Backslash at end of line A backslash (\) at the end of a line suppresses the newline. In HTML components, this is mostly useful for fixed width areas like C<< 
 >>
tags, since browsers ignore white space for the most part. An example:

    
    foo
    % if (1) {
    bar
    % }
    baz
    


outputs

    foo
    bar
    baz

because of the newlines on lines 2 and 4. (Lines 3 and 5 do not
generate a newline because the entire line is taken by Perl.)
To suppress the newlines:

    
    foo\
    % if (1) {
    bar\
    % }
    baz
    


which prints

    foobarbaz

=head1 DATA CACHING

Mason's data caching interface allows components to cache the results
of computation for improved performance.  Anything may be cached, from
a block of HTML to a complex data structure.

Each component gets its own private, persistent data cache. Except
under special circumstances, one component does not access another
component's cache. Each cached value may be set to expire at a certain
time.

Data caching is implemented on top of one of two external caching APIs:
C, which is stable but has not changed in years, or C,
which has picked up where C has left off and is actively
maintained. You control which one Mason uses with the L
parameter.  C is the default for backward compatibility
reasons, but we recommend C for anyone doing serious caching.  The APIs
are very similar for Mason users, so that most of the information below
applies to both; any differences are noted.

=head2 Basic Usage

The C<< $m->cache >> method returns a cache object representing the cache for
this component. Here's the typical usage of C<< $m->cache >>:

    my $result = $m->cache->get('key');
    if (!defined($result)) {
        ... compute $result ...
        $m->cache->set('key', $result);
    }

C<< $m->cache->get >> attempts to retrieve this component's cache
value. If the value is available it is placed in C<$result>. If the
value is not available, C<$result> is computed and stored in the
cache by C<< $m->cache->set >>.

=head2 Multiple Keys/Values

A cache can store multiple key/value pairs. A value can be
anything serializable by C, from a simple scalar to an
arbitrary complex list or hash reference:

    $m->cache->set(name => $string);
    $m->cache->set(friends => \@list);
    $m->cache->set(map => \%hash);

You can fetch all the keys in a cache with

    my @idents = $m->cache->get_keys;

It should be noted that Mason reserves all keys beginning with
C<__mason> for its own use.

=head2 Expiration

You can pass an optional third argument to C<< $m->cache->set >>
indicating when the item should expire:

    $m->cache->set('name1', $string1, '5 min');  # Expire in 5 minutes
    $m->cache->set('name2', $string2, '3h');     # Expire in 3 hours

To change the expiration time for a piece of data, call C again
with the new expiration. To expire an item immediately, use
C<< $m->cache->remove >>.

You can also specify an expiration condition when you fetch the item,
using the I option:

    my $result = $m->cache->get('key',
        expire_if=>sub { $_[0]->get_created_at < (stat($file))[9] });

I takes an anonymous subroutine, which is called with the
L as its only parameter. If the
subroutine returns a true value, the item is expired. In the example
above, we expire the item whenever a certain file changes.

Finally, you can expire a cache item from an external script; see
L below.

=head2 Avoiding Concurrent Recomputation

The code shown in "Basic Usage" above,

   my $result = $m->cache->get('key');
   if (!defined($result)) {
       ... compute $result ...
       $m->cache->set('key', $result);
   }

can suffer from a kind of race condition for caches that
are accessed frequently and take a long time to recompute.

Suppose that a particular cache value is accessed five times a
second and takes three seconds to recompute.  When the cache expires,
the first process comes in, sees that it is expired, and starts to
recompute the value.  The second process comes in and does the same thing.
This sequence continues until the first process finishes and stores
the new value.  On average, the value will be recomputed and written
to the cache 15 times!

One solution is the I flag:

   my $result = $m->cache->get('key', busy_lock=>'30 sec');

In this case, when the value cannot be retrieved, C sets
the expiration time of the value 30 seconds in the future before
returning C.  This tells the first process to compute the new
value while causing subsequent processes to use the old value for 30
seconds. 

Should the 30 seconds expire before the first process is done, a second
process will start computing the new value while setting the expiration
time yet another 30 seconds in the future, and so on.

The disadvantage of this solution is that multiple writes to the cache
will be performed for each C.

Another solution, available only if you are using C, is
C which will create a variable time window during
which expiration may occur. See the C documentation for details.

=head2 Caching All Output

Occasionally you will need to cache the complete output of a
component.  For this purpose, Mason offers the C<< $m->cache_self >>
method.  This method causes Mason to check to see if this component
has already been run and its output cached.  If this is the case, this
output is simply sent as output.  Otherwise, the component run
normally and its output and return value cached.

It is typically used right at the top of an C<< <%init> >> section:

    <%init>
    return if $m->cache_self(key => 'fookey', expires_in => '3 hours',
                             ...  ...);
     ...  ...
    

A full list of parameters and examples are available in the
L section of the Request
manual.

=head2 Cache Object

C<< $m->cache->get_object >> returns a C or
C associated with a particular key. You can use this
to retrieve useful meta-data:

    my $co = $m->cache->get_object('name1');
    $co->get_created_at();    # when was object stored in cache
    $co->get_expires_at();    # when does object expire

=head2 Choosing a Cache Subclass - with Cache::Cache

The C API is implemented by a variety of backend subclasses. For
example, C implements the interface with a set of
directories and files, C implements the interface in
process memory, and C implements the interface in
shared memory.

By default C<< $m->cache >> uses C, but you can override
this with the I keyword. The value must be the name of a
C subclass; the prefix "Cache::" need not be included.
For example:

    my $result = $m->cache(cache_class => 'MemoryCache')->get('key');
    $m->cache(cache_class => 'MemoryCache')->set(key => $result);

You can even specify different subclasses for different keys in the
same component. Just make sure the correct value is passed to all
calls to C<< $m->cache >>; Mason does not remember which subclass you
have used for a given component or key.

The administrator can set the default cache subclass used by all
components with the L parameter.

=head2 Choosing a Cache Subclass - with CHI

The C API is implemented by a variety of drivers, for example
C, C, and
C.

C is the default, but you can override this with
the I keyword. The value must be the name of a C
subclass; the prefix "CHI::Driver::" need not be included.  For
example:

    my $cache = $m->cache(driver => 'Memcached', servers => [ ... ]);
    my $result = $cache->get('key');
    $cache->set(key => $result);

You can even specify different subclasses for different keys in the
same component. Just make sure the correct value is passed to all
calls to C<< $m->cache >>; Mason does not remember which subclass you
have used for a given component or key.

The administrator can set the default cache subclass used by all
components with the L parameter.

=head2 Accessing a Cache Externally

To access a component's cache from outside the component (e.g. in an
external Perl script), you'll need have the following information:

=over

=item *

the namespace associated with the component. For C, the function
C,
given a component id (usually just the component path), returns the
namespace. For C, the component id/path itself is the namespace.

=item *

the cache_root, for file-based caches only. Defaults to the
"cache" subdirectory under the Mason data directory.

=back

Given this information you can get a handle on the component's cache.
For example, the following code removes a cache item for component
F, assuming the data directory is F
and you are using the default file backend:

    use HTML::Mason::Utils qw(data_cache_namespace);

    # With Cache::Cache
    my $cache = new Cache::FileCache
        ( { namespace => data_cache_namespace("/foo/bar"),
            cache_root => "/usr/local/www/mason/cache" } );

    # With CHI
    my $cache = CHI->new
        ( driver => 'File',
          namespace => "/foo/bar",
          cache_root => "/usr/local/www/mason/cache" );

    # Remove one key
    $cache->remove('key1');

    # Remove all keys
    $cache->clear;

=head2 Mason 1.0x Cache API

For users upgrading from 1.0x and earlier, any existing $m-Ecache
code will be incompatible with the new API. However, if you wish to
continue using the 1.0x cache API for a while, you (or your
administrator) can set L to '1.0'. All of the
$m-Ecache options with the exception of C should be
supported.

The C function is no longer available; this will
need to be converted to use C directly, as described in
the L.

=head1 WEB-SPECIFIC FEATURES

=head2 Sending HTTP Headers

Mason automatically sends HTTP headers via C<< $r->send_http_header >>
but it will not send headers if they've already been sent manually.

To determine the exact header behavior on your system, you need to
know whether your server's default is to have L on or off.
Your administrator should have this information.  If your administrator
doesn't know then it is probably off, the default.

With autoflush off the header situation is extremely simple: Mason
waits until the very end of the request to send headers. Any component
can modify or augment the headers.

With autoflush on the header situation is more complex.  Mason will
send headers just before sending the first output.  This means that if
you want to affect the headers with autoflush on, you must do so
before any component sends any output.  Generally this takes place in
an C<< <%init> >> section.

For example, the following top-level component calls another component
to see whether the user has a cookie; if not, it inserts a new cookie
into the header.

    <%init>
    my $cookie = $m->comp('/shared/get_user_cookie');
    if (!$cookie) {
        $cookie = new CGI::Cookie (...);
        $r->header_out('Set-cookie' => $cookie);
    }
    ...
    

With autoflush off this code will always work.  Turn autoflush on and
this code will only work as long as F doesn't
output anything (given its functional nature, it shouldn't).

The administrator can turn off automatic header sending via the
L parameter. You can also turn it off on
individual pages with

    $m->auto_send_headers(0);

=head2 Returning HTTP Status

The value returned from the top-most component becomes the status code
of the request. If no value is explicitly returned, it defaults to OK
(0).

Simply returning an error status (such as 404) from the top-most
component has two problems in practice. First, the decision to return
an error status often resides further down in the component
stack. Second, you may have generated some content by the time this
decision is made. (Both of these are more likely to be true when using
autohandlers.)

Thus the safer way to generate an error status is

   $m->clear_buffer;
   $m->abort($status);

C<< $m->abort >> bypasses the component stack and ensures that
C<$status> is returned from the top-most component. It works by
throwing an exception. If you wrapped this code (directly or
indirectly) in an eval, you must take care to rethrow the exception,
or the status will not make it out:

   eval { $m->comp('...') };
   if (my $err = $@) {
      if ($m->aborted) {
          die $err;
      } else {
          # deal with non-abort exceptions
      }
   }

=head3 Filters and $m->abort

A filter section will still be called after a component aborts with
C<< $m->abort >>.  You can always check C<< $m->aborted >> in your
C<< <%filter> >> block if you don't want to run the filter after an abort.

  <%filter>
  unless ( $m->aborted ) {
      $_ .= ' filter stuff';
  }
  

=head2 External Redirects

Because it is so commonly needed, Mason 1.1x and on provides an
external redirect method:

    $m->redirect($url);    # Redirects with 302 status

This method uses the clear_buffer/abort technique mentioned above,
so the same warnings apply regarding evals.

Also, if you generate any output I calling C<< $m->redirect >>,
then this output will be sent, and will break the redirect.  For
example:

  % eval { $m->comp('redirect', ...) };

  % die $@ if $@;

The blank line between the two Perl lines is new output generated
after the redirect.  Either remove it or call C<< $m->clear_buffer >>
immediately before calling C.

=head2 Internal Redirects

There are two ways to perform redirects that are invisible to the
client.

First, you can use a Mason subrequest (see L). This only
works if you are redirecting to another Mason page.

Second, you can use Apache's internal_redirect method, which works
whether or not the new URL will be handled by Mason.  Use it this way:

    $r->internal_redirect($url);
    $m->auto_send_headers(0);
    $m->clear_buffer;
    $m->abort;

The last three lines prevent the original request from accidentally
generating extra headers or content.

=head1 USING THE PERL DEBUGGER

You can use the perl debugger in conjunction with a live
mod_perl/Mason server with the help of Apache::DB, available from
CPAN. Refer to the Apache::DB documentation for details.

The only tricky thing about debugging Mason pages is that components
are implemented by anonymous subroutines, which are not easily
breakpoint'able. To remedy this, Mason calls the dummy subroutine
C at the beginning of each component. You can breakpoint
this subroutine like so:

    b HTML::Mason::Request::debug_hook

debug_hook is called with two parameters: the current Request object
and the full component path. Thus you can breakpoint specific
components using a conditional on $_[1]:

    b HTML::Mason::Request::debug_hook $_[1] =~ /component name/

You can avoid all that typing by adding the following to your
~/.perldb file:

    # Perl debugger aliases for Mason
    $DB::alias{mb} = 's/^mb\b/b HTML::Mason::Request::debug_hook/';

which reduces the previous examples to just: 

    mb
    mb $_[1] =~ /component name/

Mason normally inserts '#line' directives into compiled components so
that line numbers are reported relative to the source file. Depending
on your task, this can be a help or a hindrance when using the
debugger.  The administrator can turn off '#line' directives with
the L parameter.

=head1 LOGGING

Mason uses C to log various events, such as the start and
end of each request and each component call. You can also log to
C from a component with the
C<$m-Elog> method. e.g.

    $m->log->error("Something bad happened!");
    $m->log->debugf("Arguments for '%s' were '%s'", $func, \%args)
        if $m->log->is_debug;

See C for how to direct these logs to
an output of your choice.

=head1 OBJECT-ORIENTED TECHNIQUES

Earlier you learned how to assign a common template to an entire
hierarchy of pages using I. The basic template looks like:

    header HTML
    % $m->call_next;
    footer HTML

However, sometimes you'll want a more flexible template that adjusts
to the requested page.  You might want to allow each page or
subsection to specify a title, background color, or logo image while
leaving the rest of the template intact. You might want some pages or
subsections to use a different template, or to ignore templates
entirely.

These issues can be addressed with the object-oriented style
primitives introduced in Mason 0.85.

Note: we use the term object-oriented loosely. Mason borrows concepts
like inheritance, methods, and attributes from object methodology but
implements them in a shallow way to solve a particular set of
problems. Future redesigns may incorporate a deeper object
architecture if the current prototype proves successful.

=head2 Determining inheritance

Every component may have a single I. The default parent is a
component named C in the closest parent directory.  This
rule applies to autohandlers too: an autohandler may not have itself
as a parent but may have an autohandler further up the tree as its
parent.

You can use the C flag to override a component's parent:

    <%flags>
    inherit => '/foo/bar'
    

If you specify undef as the parent, then the component inherits from
no one.  This is how to suppress templates.

Currently there is no way to specify a parent dynamically at run-time,
or to specify multiple parents.

=head2 Content wrapping

At page execution time, Mason builds a chain of components from the
called component, its parent, its parent's parent, and so
on. Execution begins with the top-most component; calling
C<< $m->call_next >> passes control to the next component in the chain.  This
is the familiar autohandler "wrapping" behavior, generalized for any
number of arbitrarily named templates.

=head2 Accessing methods and attributes

A template can access methods and/or attributes of the requested
page. First, use C<< $m->request_comp >> to get a handle on the
appropriate component:

    my $self = $m->request_comp;

$self now refers to the component corresponding to the requested page
(the component at the end of the chain).

To access a method for the page, use C:

    $self->call_method('header');

This looks for a method named 'header' in the page component.  If no
such method exists, the chain of parents is searched upwards, until
ultimately a "method not found" error occurs. Use 'method_exists' to
avoid this error for questionable method calls:

    if ($self->method_exists('header')) { ...

The component returned by the C<< $m->request_comp >> method never
changes during request execution.  In contrast, the component returned
by C<< $m->base_comp >> may change several times during request
execution.

When execution starts, the base component is the same as the requested
component.  Whenever a component call is executed, the base component
may become the component that was called.  The base component will
change for all component calls B in the following cases:

=over

=item *

A component is called via its component object rather than its path,
for example:

  <& $m->fetch_comp('/some/comp'), foo => 1 &>

=item *

A subcomponent (defined with C<< <%def> >>) is called.

=item *

A method is called via the use of C, C, or
C.  These are covered in more detail below.

=back

In all other cases, the base component is the called component or the
called component's owner component if that called component is a
method.

As hinted at above, Mason provides a shortcut syntax for method calls.

If a component call path starts with C, then Mason will start
looking for the method (the portion of the call after C), in
the base component.

    <& SELF:header &>
    $m->comp('SELF:header')

If the call path starts with C, then Mason will start looking
in the current component's parent for the named method.

    <& PARENT:header &>
    $m->comp('PARENT:header')

In the context of a component path, PARENT is shorthand for
C<< $m->current_comp->parent >>.

If the call path begins with C, then Mason looks for the
method in the requested component.  REQUEST is shorthand for C<<
$m->request_comp >>.

The rules for attributes are similar. To access an attribute for the
page, use C:

    my $color = $self->attr('color')

This looks for an attribute named 'color' in the $self component. If
no such attribute exists, the chain of parents is searched upwards,
until ultimately an "attribute not found" error occurs. Use
C or C to avoid this error for
questionable attributes:

    if ($self->attr_exists('color')) { ...

    my $color = $self->attr_if_exists('color'); # if it doesn't exist $color is undef

=head2 Sharing data

A component's main body and its methods occupy separate lexical
scopes. Variables declared, say, in the C<< <%init> >> section of the main
component cannot be seen from methods.

To share variables, declare them either in the C<< <%once> >> or C<< <%shared> >>
section. Both sections have an all-inclusive scope. The C<< <%once> >>
section runs once when the component loads; its variables are
persistent for the lifetime of the component. The C<< <%shared> >> section
runs once per request (when needed), just before any code in the
component runs; its variables last only til the end of the request.

In the following example, various sections of code require information
about the logged-in user. We use a C<< <%shared> >> section to fetch these
in a single request.

    <%attr>
    title=>sub { "Account for $full_name" }
    

    <%method lefttoc>
    <% $full_name %>
    (Log out)

    ...
    

    Welcome, <% $fname %>. Here are your options:

    <%shared>
    my $dbh = DBI::connect ...;
    my $user = $r->connection->user;
    my $sth = $dbh->prepare("select lname,fname, from users where user_id = ?");
    $sth->execute($user);
    my ($lname, $fname) = $sth->fetchrow_array;
    my $full_name = "$first $last";
    

C<< <%shared> >> presents a good alternative to C<< <%init> >> when data is needed
across multiple scopes. Outside these situations, C<< <%init> >> is preferred
for its slightly greater speed and predictable execution model.

=head2 Example

Let's say we have three components:

    /autohandler
    /products/autohandler
    /products/index.html

and that a request comes in for /products/index.html.

F contains a general template for the site, referring to a
number of standard methods and attributes for each page:

    
    <& SELF:title &>
    
    
    <& SELF:header &>

    

    % $m->call_next;
    


    <& SELF:footer &>
    

    <%init>
    my $self = $m->base_comp;
    ...
    

    <%attr>
    body_style => 'standard'
    

    <%method title>
    McGuffey Inc.
    

    <%method header>
    
<& SELF:title &>

    

    <%method footer>
    

Notice how we provide defaults for each method and attribute, even if blank.

F overrides some attributes and methods for the
F section of the site.

    <%attr>
    body_style => 'plain'
    
    <%method title>
    McGuffey Inc.: Products
    

    % $m->call_next;

Note that this component, though it only defines attributes and
methods, must call C<< $m->call_next >> if it wants the rest of the
chain to run.

F might override a few attributes, but mainly provides
a primary section for the body.

=head1 COMMON TRAPS

=over

=item Do not call $r->content or "new CGI"

Mason calls C<< $r->content >> itself to read request input, emptying
the input buffer and leaving a trap for the unwary: subsequent calls
to C<< $r->content >> hang the server. This is a mod_perl "feature" that
may be fixed in an upcoming release.

For the same reason you should not create a CGI object like

  my $query = new CGI;

when handling a POST; the CGI module will try to reread request input
and hang. Instead, create an empty object:

  my $query = new CGI ("");

such an object can still be used for all of CGI's useful HTML output
functions. Or, if you really want to use CGI's input functions,
initialize the object from %ARGS:

  my $query = new CGI (\%ARGS);

=back

=head1 MASON AND SOURCE FILTERS

Modules which work as source filters, such as C, will only
work when you are using object files.  This is because of how source
filters are implemented, and cannot be changed by the Mason authors.

=cut
HTML-Mason-1.59/lib/HTML/Mason/FAQ.pod0000644000175000017500000016001513660015140016630 0ustar  autarchautarch=pod

=head1 NAME

HTML::Mason::FAQ - Frequently asked questions

=head1 AUTOHANDLERS, METHODS, ATTRIBUTES, INHERITANCE

=head2 Can I set a page's inheritance dynamically at request time (e.g. based on URL arguments)?

No. Inheritance is a fixed property of a component, determined once when the component is loaded. Dynamic inheritance is on the todo list.

=head2 How can I tell Mason to use autohandlers or dhandlers when calling one component from another component (i.e. internal redirect)?

Usually this situation arises when a top-level component makes a run-time decision to use a second component as the "real" page, and calls it via <& &> or $m->comp.

Autohandlers and dhandlers are only triggered for the top-level component of a request. In 1.1, you can use an Apache internal redirect or a Mason subrequest ($m->subexec) to solve the problem.

=head2 I added a simple autohandler to a directory and now my pages don't appear.

Make sure to include a call to $m->call_next somewhere in the autohandler.

=head2 Where does a dhandler inherit from? Can I change it to inherit based on the URL path?

A dhandler's inheritance is determined by its location in the hierarchy, not by the URL that invoked it.

Consider a site with the following components:

       /autohandler
       /dhandler
       /products/autohandler

and suppose a request comes in for /products/index.html. /dhandler will handle the request but will still inherit from /autohandler.

This is not always the desired behavior, but there is no easy way to change it. If you want /products/* requests to use /products/autohandler, you'll need to create /products/dhandler as well.

=head2 Can I change the value of an attribute dynamically, based on the request?

No, attributes are static. The closest thing to a dynamic attribute is a method. If you've been using an attribute widely and don't want to change it to a method everywhere, consider using an attribute/method combination. Suppose your attribute is called 'bgcolor'. Create a default method called 'bgcolor' in the autohandler:

       <%method bgcolor>
       <%init>
       return $m->base_comp->attr('bgcolor');
       <%init>
       

Then replace every other

       $m->base_comp->attr('bgcolor');

with

       $m->base_comp->call_method('bgcolor')

or

       <& SELF:bgcolor &>

Now you can leave the attribute definitions alone, but define a method if and when you need a dynamically computed value.

=head2 When using multiple component roots and autohandlers, does every autohandler in every root get called, and in what or


Mason will try each autohandler path in turn, e.g.

   /foo/bar/baz/autohandler
   /foo/bar/autohandler
   /foo/autohandler
   /autohandler

For each path, it will search all of the component roots, and only run the *first* autohandler found. Some of the autohandlers might come from one root and some from another.  However, there is no way that multiple autohandlers would be run for the same path (/foo/autohandler, for example.) There is also no way for /foo/autohandler in root 1 to explicitly call /foo/autohandler in root 2.

People sometimes ask for this behavior to be changed. We feel it's a bad idea because multiple component roots, right now, are very clean in both behavior and implementation. Trying to run multiple autohandlers for the same path would require a complex set of precedence rules that would almost certainly lead to unpredictable behavior. (Think about multiple versions of multiple autohandlers at different directory levels, and trying to predict which order they'd run in.)

=head1 CACHING

=head2 When I change a component I don't always see the results in the output. How do I invalidate Mason code caches?

Mason employs two kinds of code caching. First, Mason caches loaded components in memory. Second, Mason keeps an object file (a compiled version of the component) for every loaded component under data_root/obj.

Before executing a memory-cached component, Mason compares the stored timestamp with the timestamp of the source file. If the source file has a later timestamp, Mason will load the component from the filesystem.

Similarly, before using an object file, Mason compares the modified timestamp of the source and object files. If the source file has a later timestamp, then it is reparsed and the object file is overwritten.

The system is designed so that you will immediately see the effects of source file changes. There are several ways for this system to breakdown; most are easy to avoid once you know about them.

* If you copy or move in a component source file from elsewhere, it will retain the original file's timestamp, which may be earlier than the object file.

* If you use tar, rsync, rdist or similar programs to transfer components, the timestamps of the created files may not be updated to the current time. Check the program's documentation for timestamp-related options.

* If you use a shared file system like NFS, the timestamps of locally created files may not jibe with timestamps of NFS files due to differences in machine clocks.

* If you ftp files onto a running server, Mason may read the file while it is incomplete. If the ftp then completes within the same second, Mason will not notice the change, and won't ever read the complete file.

When in doubt, touching the source files (with the Unix touch command, or by re-saving in an editor) should force Mason to reload the component. If that does not work, try removing the object files and/or restarting the server to clear the memory cache. However, these remedies should be necessary only to diagnose the caching problem, not for normal Mason operation. On a normal Mason system cache expiration should just work "as expected".

=head2 Mason code caching breaks down often in my situation. Couldn't you do something smarter than just comparing the timestamps?

When coming up with invalidation schemes, we must consider efficiency as well as failure predictability. The current scheme does fail in certain situations, but those situations are very predictable. If you incorrectly use tar or copy or another technique mentioned above, you'll see the cache invalidation failure very quickly.

Some alternatives that have been suggested:

* Compare the sizes of the files as well as timestamps, or use the more liberal "source timestamp != object timestamp". This would indeed increase the chance of catching a change. But it would still fail occasionally (e.g. when changing a single character, or when copying an old-timestamp file that just happens to match the current timestamp), resulting in intermittent, head-scratching errors. In our opinion, it is better to fail miserably up front and be forced to fix your system than to have a mostly-working system that fails once a week. This is especially true when you are relying on Mason's cache invalidation on a production system.

* Comparing MD5 or other signatures of the content. This would be very accurate, but would require reading and processing the source file instead of just performing a stat. This extra expense reduces the effectiveness of the cache.

The bottom line: If you are relying on Mason's cache invalidation on a production system, you should take the time and build in the appropriate infrastructure to ensure that source file timestamps are always up-to-date after they are copied/untarred into place.

=head2 When I change code in a library file I don't see the results. How can I get Mason to reread the library files?

mod_perl processes, in general, do not automatically reread your library files. You either have to stop and start the server whenever you change a library file, or install something like Apache::Reload which will automate their reloading. However, see ApacheReload for important usage information.

=head2 Once I've made an error in a component, the error keeps appearing in the logs, no matter how many times I fix it and reload!

Are you using Apache::Reload in its default (!ReloadAll) mode? If so, see ApacheReload for details.

=head2 Do data cache files expire automatically when a component or its dependencies change?

Unfortunately they do not. This is on the to-do list.

With Mason 1.1x and beyond, you can use the following idiom to say ``expire when my component source file changes'':

      $m->cache(...,
        expire_if=>sub {
              (stat($m->current_comp->source_file))[9] > $_[0]->get_created_at
        } )

With Mason <= 1.05, the idiom looks like:

      $m->cache(...,
         expire_if=>sub { 
              (stat($m->current_comp->source_file))[9] > $_[0]
         } )


=head1 COMPONENTS

=head2 What is a component?

A component is a file that contains some combination of text (typically HTML), perl code and HTML::Mason directives.

Some components are accessed directly by web browsers. These are called top-level components. A top-level component might consist purely of static HTML.

Other components are support components, which are called by top-level components or other support components. These components are analogous to perl subroutines -- they allow you to create small packages of code that you can reuse throughout your project.

=head2 How do components communicate with each other?

Components can return values to their callers, just like subroutines.

Some components may have very simple return values. As an example, consider a component called isNetscape which returns a true value when the client's browser is Netscape and undef when it is not. The isNetscape component could then be used easily in an if() or other control statement.

Of course, components can also return strings of text, arrays, hashes or other arbitrarily complex perl data structures.

=head2 How do I use modules in components?

Technically you can just say "use module-name" at the beginning of a component. The disadvantages of this method are that:

* the module will be used separately by every httpd child process, costing both time and memory.

* it is difficult to keep track of all the modules being used on a site.

A more efficient method is to put the use line in the handler.pl or use the PerlModule directive. If you want components to be able to refer to symbols exported by the module, you need to use the module inside the HTML::Mason::Commands package. See the "External modules" section of the Administrator's Guide:

=head2 Can I define subroutines in components?

Defining a named subroutine in a <%perl> or <%init> section does not work reliably because such a definition would end up residing inside another subroutine, and Perl doesn't like that.

You can technically define named subroutines inside the <%once> section of any component, but we highly discourage this, because all components are executed in the same namespace. This makes it easy to create two subroutines with the same name in two different components.

Consider the following options:

* If the routine is going to display HTML, use a separate component or a <%def> subcomponent.

* If the subroutine is only of use in your component, use an anonymous subroutine defined in <%once>. Even though you could define the anonymous subroutine in any section, a <%once> is recommended, both for performance and to avoid nested-anonymous-subroutine leaks in Perl <=5.6. Example:

      <%once>
      my $foo = sub {
        ...
      };
      

      ...

      % $foo->()

* If the subroutine is of interest to more than just your component, have you considered putting it in a module?

Note that calling a component, while reasonably fast, is about an order of magnitude slower than calling an equivalent subroutine. So if you're going to call the routine many times in a loop, you may wish to use the anonymous subroutine for performance reasons. Benchmark for yourself.

=head2 Does Mason set the current working directory (".") for me?

Mason does not touch the working directory, as this would entail an unnecessary performance hit for the majority of users that don't need it.

In an Apache environment, the working directory will be set in a more-or-less random way, depending on such seemingly irrelevant factors as whether you started the server in single-process mode or not. In a non-Apache environment the working directory will be whatever it was before Mason started executing.

Often people expect the working directory to be the directory of the current component. You can, instead, get that directory manually with

       $m->current_comp->source_dir

=head2 How do I exit from all components including the ones that called me?

Use $m->abort, documented in the Request manual:

=head2 Why does my output have extra newlines/whitespace and how can I get rid of it?

Any newlines that are not either inside a tag or on a %-line will become part of the output. Since browsers ignore extra whitespace this is not generally a problem, but there are situations where it matters, e.g. within 
 tags.

First, for components that only return a value and shouldn't output *any* content, you should always use <%init>:

      <%args>
       $foo
      

      This content will be ignored.

      <%init>
       my $bar = $dbh->selectrow_array("SELECT bar FROM t WHERE foo=?", $foo);
       return $bar;
      

In components that do display content, there are various strategies. To eliminate selected newlines, use the backslash. For example,

       
       foo\
       % if (1) {
       bar\
       % }
       baz
       


outputs "foobarbaz" with no newlines.

To prevent a component from outputting any newlines, use a filter:

       <%filter>
       s/\n//g;
       

To emit binary data without the risk of inserting extra whitespace, surround your code with $m->clear_buffer and $m->abort, to suppress any preceding and following content:

      <%init>
       $m->clear_buffer;
       my $fh = IO::File->new('< binary_file') or die $!;
       my $buffer;
       while (read $fh, $buffer, 8192) {
         $m->print($buffer);
       }
       $m->abort;
      

At some point Mason will probably offer a "reasonable" whitespace removal feature, controlled by parameter.

=head2 I'm trying to generate an image or other binary file, but it seems to be getting corrup


This is almost always caused by unwanted whitespace at the beginning or end of your binary data. Put a $m->clear_buffer before, and an $m->abort after, your code. See the last part of the answer above.

In Apache 1.0 a real working example looks like this:

   my $fh;
   my $fileName = '/tmp/mypic.jpg';
   open ( $fh, $fileName ) or die $!;

   $m->clear_buffer();
   $r->content_type( 'image/jpeg' ); # set mime-type 
   $r->send_http_header;
   $r->send_fd ( $fh );
   close ( $fh );

In Apache 2.0 use:

   use Apache2::Const qw(HTTP_OK)

   my $fileName = 'someimage.jpg';
   $m->clear_buffer();
   $r->content_type( 'image/jpeg' );
   $r->sendfile( $fileName )
   $r->abort( Apache2::Const::HTTP_OK );

=head2 How do I put comments in components?

* Put general comments in the <%doc> section.

* In the <%init> and <%cleanup> sections, and in a <%perl> block, use standard Perl comments ('#').

* In Mason 1.3 and beyond, use <%# %> for single or multi-line comments anywhere outside of Perl sections. Before 1.3, this syntax isn't guaranteed to work; one alternative is to begin a line with %#.

* If you are producing HTML, you can use standard HTML comments delimited by . The difference is that these comments will appear in the final output.

=head2 What's a good way to temporarily comment out code in a component?

For HTML, you might be tempted to surround the section with . But be careful! Any code inside the section will still execute. Here's a example of commenting out a call to an ad server:

      

The ad will still be fetched and counted, but not displayed!

A better way to block out a section is if (0):

      % if (0) {
        ...
      % }

Code blocked out in this way will neither be executed nor displayed, and multiple if (0) blocks can be nested inside each other (unlike HTML comments).

Another way to block out code is with a <%doc> tag or a <%# %> comment, although these not cannot be nested.

=head2 How can I capture the output of a component (and modify it, etc.) instead of having it automatically output?

Use $m->scomp, documented in the Request manual:

=head2 Can I use globals in components?

All HTML::Mason components run in the same package (HTML::Mason::Commands), so if you set a global variable in one you'll be able to read it in all the others. The only problem is that Mason by default parses components with strict mode on, so you'll get a warning about the global (and Mason considers all such warnings fatal). To avoid errors, simply declare your globals via the MasonAllowGlobals parameter.

      PerlSetVar MasonAllowGlobals $dbh
      PerlAddVar MasonAllowGlobals $user

If you have a handler.pl file, you can also declare global variables in the handler() subroutine as long as you explicitly put them in the HTML::Mason::Commands package.

      package HTML::Mason::Commands;
      use vars qw(...);

or use the Parser allow_globals parameter.

Alternatively you can turn off strict entirely by passing:

      use_strict => 0

when you create the Parser object. Then you can use all the globals you want. Doing this is terribly silly, however, and is bound to get you in trouble down the road.

=head2 How do I share variables between components?

First, you can pass variables from one component to another.

Second, you can use globals. All components run in the same package (HTML::Mason::Commands as of this writing), so globals in this package are visible to all components. See the previous question.

There is no way to share a variable between just a few components; this is a limitation of Perl's scoping rules. You can make a variable /visible/ to only certain components using 'our' declarations:

        <%once>
        our ($shared_var);
        

See the Perl documentation on 'our' to make sure you understand what this is doing.

The <%shared> section is /not/ for sharing variables among different file components. It is for sharing variables among the subcomponents and methods of a single file component.

=head2 Why does the order of output get mixed up when I use print or $r->print?

This should no longer happen with Mason 1.10+. For those users still using older versions of Mason, read the following:

Since your server is most likely in batch mode, all Mason output gets buffered til the end of the request. print and $r->print circumvent the buffer and thus come out before other Mason output.

Solution: don't use print or $r->print. Use $m->out if you must output inside a Perl section. See the section on output mode in the Administrator's Guide.

and the section on $m->out in the Request manual.

=head2 Why doesn't my <%cleanup> code run every time the component runs?


A <%cleanup> block is equivalent to a C<< <%perl> >> block at the end of the component. This means it will NOT execute if the component explicitly returns, or if an abort or error occurs in that component or one of its children.

If you need code that is guaranteed to run when the component or
request exits, consider using a mod_perl cleanup handler, or creating
a custom class with a DESTROY method.

=head2 Is <%args> exactly like %ARGS, and do I need to worry about it?

Mason allows you to predeclare arguments to components by specifying variables to hold those arguments in an <%args> section. Because these are perl variables that you are predeclaring, they must have legal perl identifier names -- they can't, for example, contain periods.

If you want to pass arguments that are not identified with legal perl names, you must manually pull those arguments out of the %ARGS hash that mod_perl sets up for you. Why would you want to name your arguments un-legally, you ask? Well, just for starters, the form input element  will pass arguments clickable.x and clickable.y to the action url automatically. If you want to access these, you'd have to use $ARGS{clickable.x} and $ARGS{clickable.y} rather than trying to declare them in <%args>.

=head2 Why does Mason display the wrong line numbers in errors?

Due to limitations in the 1.0x parser, Mason can only display line numbers relative to object files.

In 1.1 and on, error line numbers correctly reflect the component source.

=head2 How can I get a list of components matching a path pattern?

Use the resolver's glob_path method:

      my @paths = $m->interp->resolver->glob_path('/some/comp/path/*');

This will work even with multiple component roots; you'll get a combined list of all matching component paths in all component roots.

=head2 Can I access $m (the request object) from outside a component, e.g. inside a subroutine?

In 1.1x and on, use

      my $m = HTML::Mason::Request->instance;

Before 1.1x, use

      my $m = HTML::Mason::Commands::m;

=head2 How can I make the |h escape flag work with my Russian/Japanese/other-non-western encoding?

The |h flag is implemented with [=HTML::Entities::encode_html]. This function, by default, escapes control chars and high-bit chars as well as <, >, &, and ". This works well for ISO-8559-1 encoding but not with other encodings.

To make |h escape just <, >, &, and ", which is often what people want, put the following in your Apache configuration:

       PerlSetVar  MasonEscapeFlags  "h => \&HTML::Mason::Escapes::basic_html_escape"

Or, in a top-level autohandler:

       $m->interp->set_escape( h => \&HTML::Mason::Escapes::basic_html_escape );

=head2 When using multiple component roots, is there a way to explicitly call a component in a specific root?


Multiple component roots were designed to work just like Perl's @INC.  A given component path matches exactly one file, the first file found in an ordered search through the roots. There is no way to explicitly ask for a file in a specific root.

People sometimes ask for the ability to do this. We feel it's a bad idea because it would endanger the cleanliness of multiple component roots in both behavior and implementation. As it stands now, the rules are very easy to understand and the implementation is very clean and isolated; only the resolver really needs know about multiple component roots.

If you want to be able to explicitly refer to components in a given root, put an extra subdirectory between the root and the components.  e.g. put your components in

    /usr/local/htdocs/global/global/...

then add the root as

    ['global', '/usr/local/htdocs/global']

Now you can prefix a path with /global to refer to any component in that root.

Alternatively, [http://search.cpan.org/dist/MasonX-Request-ExtendedCompRoot MasonX::Request::ExtendedCompRoot] is a subclass of Mason that does allow you to call components in a specific component root.

=head2 Is there a syntax checker like perl -c for components?


It is impossible to write a truly generic standalone script to syntax check components, because components rely on certain globals and modules to be present in their environment. Mason may report compile errors from such a script even though they would not occur in your normal web environment.

The best you can do is write a standalone script that mimics your web environment as much as possible - in particular, declaring the same globals and loading the same modules. Instead of actually executing components, your script need only load them with $interp->load(). This method will throw a fatal error if a component fails to load.

=head1 HTTP AND HTML

=head2 How do I access GET or POST arguments?

GET and POST arguments are automatically parsed and placed into named component arguments just as if you had called the component with <& &> or $m->comp. So you can get at GET/POST data by pre-declaring argument names and/or using the %ARGS hash which is always available. 

=head2 How can I access the raw content of a POST in a Mason component?

It depends on your environment as to what you can do.

Apache/mod_perl has an easier way of doing it than CGI/FCGi, which uses
FakeApache. As you can see from the comment, since FakeApache implements read, I couldn't get it to be completely dynamic:

        my $inputText;
        # FakeApache implements read, so we can't automatically tell 
        # if we're in mod_perl or FCGI
        if (0 && $r->can('read')){ 
                $r->read( $inputText, $r->headers_in->{'Content-length'} );
                } 
        else {
                my %params = $r->params;
                my $posted_content = $params{POSTDATA} || $params{keywords};
                $posted_content ||= join '', %params if ($r->method eq 'POST');
                $posted_content = join '', @$posted_content if (ref $posted_content eq 'ARRAY');
                $inputText = $posted_content
        }

-- Gareth Kirwan

Probably $r->params does not work. there is no such method
in 'man Apache'

-- Rajesh Kumar Mallah.

=head2 What happens if I include query args in a POST?

As of Mason 1.01, query string and POST arguments are always combined.

=head2 Should I use CGI.pm to read GET/POST arguments?

No! HTML::Mason automatically parses GET/POST arguments and places them in declared component arguments and %ARGS (see previous question). If you create a CGI object in the usual way for a POST request, it will hang the process trying to read $r->content a second time.

=head2 Can I use CGI.pm to output HTML constructs?

Yes. To get a new CGI object, use

      my $query = new CGI('');

You have to give the empty string argument or CGI will try to read GET/POST arguments.

To print HTML constructs returned by CGI functions, just enclose them in <%%>, e.g.

      <% $query->radio_group(...) %>

=head2 How do I modify the outgoing HTTP headers?

Use the usual Apache.pm functions, such as $r->header_out. See the "Sending HTTP Headers" section in the Component Developer's Guide.

=head2 How do I do an external redirect?

In Mason 1.0x, use code like this:

        $m->clear_buffer;
        # The next two lines are necessary to stop Apache from re-reading
        # POSTed data.
        $r->method('GET');
        $r->headers_in->unset('Content-length');
        $r->content_type('text/html');
        $r->header_out('Location' => $location);
        $m->abort(301);

In Mason 1.1x, use the [=$m->redirect] method.

See the next question if your redirect isn't producing the right status code.

=head2 When trying to use $m->redirect I get 'Can't locate object method "redirect" via package "HTML::Mason::!ApacheHandler"'.

$m->redirect is supported only in Mason 1.1x and on. Check your Mason version by putting

       Version = <% $HTML::Mason::VERSION %>

in a component.

=head2 Why isn't my status code reaching users' browsers?

If you are using a handler.pl, your handler() routine should always return the error code that handle_request($r) produces. Otherwise, things like $m->abort() will not work correctly. So a very, very simple handler() routine would look like this:

      sub handler {
        my $r = shift;
        $ah->handle_request($r);
      }

If you are using $m->abort or $m->redirect and there is an eval() wrapped directly or indirectly around the call, you must take care to propagate abort exceptions after the eval(). This looks like:

       eval { $m->comp('...') };
       if ($@) {
          if ($m->aborted) {
              die $@;
          } else {
              # deal with non-abort exceptions
          }
       }

=head2 How can I handle file uploads under Mason?

The basic HTML for an upload form looks like:

       

       Upload new file:
       
       

The way you handle the submission depends on which args method you chose for the !ApacheHandler class.

Under the 'CGI' method (default for 1.0x), you can use the [=$m->cgi_object] method to retrieve a CGI.pm object which can be used to retrieve the uploaded file. Here is an example using the 'CGI' method:

  <%init>
  my $query = $m->cgi_object;

  # get a filehandle for the uploaded file
  my $fh = $query->upload('userfile');

  # print out the contents of the uploaded file
  while (<$fh>) {
        print;
  }
  close($fh);
  

Please see the [CGI.pm http://search.cpan.org/~lds/CGI.pm-3.05/CGI.pm#CREATING_A_FILE_UPLOAD_FIELD documentation] for more details.

Under the 'mod_perl' method (default for 1.1x), the request object available as [=$r] in your components will be an object in the Apache::Request class (as opposed to the Apache class). This object is capable of returning Apache::Upload objects for parameters which were file uploads. Please see the [Apache::Request http://search.cpan.org/~joesuf/libapreq-1.3/Request/Request.pm#Apache%3A%3AUpload_METHODS documentation] for more details.  Here is an example using the 'mod_perl' method:

  <%init>

   # NOTE: If you are using libapreq2 + mod_perl2 + Apache 2,
   # you will need to uncomment the following line:
   # use Apache::Upload;

   # you can store the file's contents in a scalar
   my $file_contents;

   # create an Apache::Upload object
   my $upload = $r->upload;

   # get a filehandle for the uploaded file
   my $upload_fh = $upload->fh;

   while(<$upload_fh>) {
       # loop through the file and copy each line to $file_contents
       $file_contents .= $_;
   }
   close($upload_fh);
  



For more information on how to manually set the args method, see the !ApacheHandler documentation.

If you are using CGI.pm, there are some configuration issues to be aware of. CGI.pm needs a tmp directory, and you probably want to be able to specify what that directory is.

Try doing this in your httpd.conf or handler.pl:

      
      use CGI qw(-private_tempfiles);
      

You must do this _before_ you load either the HTML::Mason or HTML::Mason::!ApacheHandler modules.

That may change which directories CGI tries to use.

You could also try

      $CGI::TempFile::TMPDIRECTORY = '/tmp';

during startup, either in your httpd.conf or handler.pl

The root of the problem is probably that the temp directory is being chosen when the module loads uring server startup while its still root. It sees it can write to /usr/tmp and is happy. Then when actually running as nobody it dies.

I bet Lincoln would welcome a patch (hint, hint). One solution would be to check if you're running under mod_perl and you're root. If so, then check Apache->server->uid and see if that id can write to the temp directory too.

=head2 How can I redirect the current request to be a file download?

A detailed explanation is provided in ForceFileDownload.

=head2 How can I manipulate cookies?

You can use the helpful modules Apache::Cookie and CGI::Cookie. It's also fairly easy to roll your own cookie-manipulation functions, using the methods provided by the $r global.

One thing to avoid: the combination of CGI::Cookie, Apache::Request, and POST requests has caused people problems. It seems that Apache::Cookie and Apache::Request make a better pair.

=head2 How can I populate form values automatically?

Several CPAN modules provide form-filling capabilities. HTML::!FillInForm is one good choice and works well with Mason. Here's a sample code snippet:

     <%filter>
     $_ = HTML::FillInForm->new->fill(scalarref => \$_, fdat => \%ARGS );
     

This will work for any component that contains a complete form in its output.

If you are using Apache::Request to process incoming arguments under mod_perl (the default as of 1.10), then you can also do this:

     <%filter>
     use HTML::FillInForm;
     $_ = HTML::FillInForm->new->fill(scalarref => \$_, fobject => $r );
     

These two examples are slightly different from each other, in that each makes a different set of parameters available to HTML::!FillInForm. In the first example, the arguments used are those that were explicitly passed to the component. In the second example, the arguments are those that were passed in the initial HTTP request. Of course, variations on this are possible by mixing and matching %ARGS, $m->request_args, $m->caller_args, and so on.

=head1 INSTALLATION

=head2 What else do I need to use Mason?

If you are planning on using Mason in a web environment with the Apache webserver, you'll need a working copy of Apache and mod_perl installed. Make sure that your mod_perl installation works correctly before trying to get Mason working. Also, if you are running RedHat Linux, beware the mod_perl RPMs that ship with RedHat. They were unreliable for a very long time, and their current state is still murky.


=head2 What platforms does Mason run on?

Because Mason consists of only Perl code, it should work anywhere Perl runs (including most Unix and Win32 variants). If it doesn't work on your operating system, let us know.

=head2 Can I run Mason outside a web server?

Yes, in fact Mason can be useful for generating a set of web pages offline, as a general templating tool, or even as a code generator for another language. See the "Standalone Mode" section of the Interpreter manual.

=head2 Can I run Mason via CGI?

Yes. See "Using Mason from a CGI script" in the Interpreter manual.

The examples in the docs requires that you have Mason 1.10+ installed.

Note that running Mason under CGI (or other non-persistent environments) will entail a substantial performance hit, since the perl interpreter will have to load, load up Mason and its supporting modules for every CGI execution. Using mod_perl or similar persistent environments (SpeedyCGI, FastCGI, etc.) avoids this performance bottleneck.

=head2 Can I use Mason with Apache/mod_perl 2.0?

Yes, as of Mason 1.27 (released 10/28/2004), there is support for Apache/mod_perl 2.0 in the core Mason code. You may find other hints at ApacheModPerl2.

=head2 Where can I find a web host supporting Mason?

Please check the [Hosting] page for a list of hosting providers supporting HTML::Mason.  You may also be interested in the list of [http://perl.apache.org/help/isps.html ISPs supporting mod_perl], however, there are reports that this document has not been maintained in several years.

=head2 What does the error "Can't locate object method 'TIEHASH' via package 'Apache::Table'" mean?

It means that Mason is trying to use some of mod_perl's "table" interface methods, like $r->dir_config->get('key') or the like. It's failing because your mod_perl server wasn't compiled with support for Apache's Table API.

To fix the problem, you'll have to recompile your server, adding the PERL_TABLE_API=1 flag (or EVERYTHING=1).

If you can't recompile your server, you can edit the Mason source code. Find a line in ApacheHandler.pm that looks like this (it's line 365 in Mason 1.04):

      my @val = $mod_perl::VERSION < 1.24 ? $c->dir_config($p) : 
         $c->dir_config->get($p);

and change it to:

      my @val = Apache::perl_hook('TableApi') ? $c->dir_config->get($p) : 
         $c->dir_config($p);

Recent versions of Mason use that, or a variant of it.

=head2 What does the error "Can't locate Apache/Request.pm in @INC" m

You are using the default !ApacheHandler args_method ('mod_perl'), which requires that you have installed the Apache::Request package (libapreq).

You can either install libapreq, or change args_method to 'CGI'. The latter is a bit slower and uses more memory.

=head2 Why am I getting segmentation faults (or silently failing on startup)?

There are a few known mod_perl issues that cause segmentation faults or a silent failure on the part of Apache to start itself up. Though not specific to Mason, they are worth keeping in mind:

* Are you using a dynamically-linked mod_perl? DSO mod_perl builds were unstable for a long time, although they might finally be getting better. Rebuild Apache with mod_perl linked statically and see if the problem goes away. Also see http://perl.apache.org/docs/1.0/guide/install.html#When_DSO_can_be_Used.

* Earlier versions of XML::Parser and Apache could conflict, because both  would statically compile in expat for XML parsing. This was fixed as of Apache version 1.3.20 and XML::Parser 2.30, both of which can be compiled against the same shared libexpat. You can also build Apache with '--disable-rule=EXPAT'. Matthew Kennedy points out that 'If "strings `which httpd` | grep -i xml" returns anything, you have this problem.'

* Are you using Perl 5.6.0? Though not widespread, Perl 5.6.0 can generate sporadic segmentation faults at runtime for some Perl code. Specifically, evals of moderate complexity appear problematic. And, since Mason uses lots of evals of moderate complexity, you can't avoid them. If the two suggestions above don't solve your segfault problem and you are running Perl 5.6.0, try upgrading to Perl 5.6.1.


MISCELLANEOUS

=head2 Where did the name come from?

It was inspired by a recent reading of Ken Follett's "The Pillars Of The Earth." The book centered around the life of a mason, a builder of great churches and buildings.

PERFORMANCE

=head2 Is Mason fast?

It is typically more than fast enough. 50-100 requests per second for a simple component is typical for a reasonably modern Linux system. Some simple benchmarking indicates that a Mason component is typically about two to three times slower than an equivalent, hand-coded mod_perl module.

Although benchmarks on [http://chamas.com/bench/ Apache Hello World! benchmarks] site shows that Mason code is five (simple Hello World page, [=hello.mas]) to ten (heavyweight template, [=h2000.mas]) times slower than mod_perl solution.

Beware of "Hello World!" and other simple benchmarks. While these benchmarks do a good job of measuring the setup and initialization time for a package, they are typically not good measures of how a package will perform in a complex, real-world application. As with any program, the only way to know if it meets your requirements is to test it yourself.

In general, however, if your application is fast enough in pure mod_perl, it will most likely be fast enough under HTML::Mason as well.

=head2 How can I make my Mason application run faster?

The first thing you can do to optimize Mason performance is to optimize your mod_perl installation. Consider implementing some of the tuning tips recommended in mod_perl_tuning, which ships with every copy of mod_perl.

If your application still needs to run faster, consider using Mason's caching methods ($m->cache and $m->cache_self) to avoid regenerating dynamic content unnecessarily.

=head2 Does Mason leak memory?

Mason 1.10 and 1.11 do have a memory leak. This is fixed with 1.12. Earlier versions of Mason may leak some memory when using the "mod_perl" args_method, due to what is arguably a bug in Apache::Request.

If you do find other memory leaks that are traceable to Mason, please check the known bugs list to make sure it hasn't already been reported. If it hasn't, simplify your handler.pl (if you have one) and the offending component as much as possible, and post your findings to the mason-users mailing list.

Of course it is always possible for your own component code to leak, e.g. by creating and not cleaning up global variables. And mod_perl processes do tend to grow as they run because of "copy-on-write" shared-memory management. The mod_perl documentation and performance faq make good bedtime reading.

If you are using RedHat's mod_perl RPM, or another DSO mod_perl installation, you will leak memory and should switch to a statically compiled mod_perl.

SERVER CONFIGURATION

=head2 Why are my config file changes not taking effect?

1. After changing an httpd.conf or handler.pl or other server configuration file, make sure to do a FULL stop and start of the server. By default, the server will not reread Perl scripts or configuration when using "apachectl restart" or when sending a HUP or USR1 signal to the server.

For more details see "Server Stopping and Restarting" in the mod_perl guide.

2. Note that you cannot use Mason httpd parameters (MasonCompRoot, MasonErrorMode, etc.) and a handler.pl script that creates an ApacheHandler object at the same time. Depending on how you declare your PerlHandler, one or the other will always take precedence and the other will be ignored. For more details see "Site Configuration Methods" in the Admin manual.

=head2 What filename extensions should I use for Mason components?


Unlike many templating systems, Mason comes with no obvious filenaming standards. While this flexibility was initially considered an advantage, in retrospect it has led to the proliferation of a million different component extensions (.m, .mc, .mhtml, .mcomp, ...) and has made it more difficult for users to share components and configuration.

The Mason team now recommends a filenaming scheme with extensions like .html, .txt, .pl for top-level components, and .mhtml, .mtxt, .mpl for internal (non-top-level) components.

Whatever naming scheme you choose should ideally accomplish three things:

* Distinguish top-level from internal components. This is obviously crucial for security.

* Distinguish output components from those that compute and return values. This improves clarity, and forces the component writer to decide between outputting and returning, as it is bad style to do both. 

* Indicate the type of output of a component: text, html, xml, etc. This improves clarity, and helps browsers that ignore content-type headers (such as IE) process non-HTML pages correctly. 

=head2 Can I serve images through a HTML::Mason server?

If you put images in the same directories as components, you need to make sure that the images don't get handled through HTML::Mason. The reason is that HTML::Mason will try to parse the images and may inadvertently find HTML::Mason syntax (e.g. "<%"). Most images will probably pass through successfully but a few will cause HTML::Mason errors.

The simplest remedy is to have HTML::Mason decline image and other non-HTML requests, thus letting Apache serve them in the normal way.

Another solution is to put all images in a separate directory; it is then easier to tell Apache to serve them in the normal way. See the next question.

For performance reasons you should consider serving images from a completely separate (non-HTML::Mason) server. This will save a lot of memory as most requests will go to a thin image server instead of a large mod_perl server. See Stas Bekman's mod_perl guide and Vivek Khera's performance FAQ for a more detailed explanation. Both are available at http://perl.apache.org/

=head2 How can I prevent a particular subdirectory from being handled by HTML::Mason?

Suppose you have a directory under your document root, "/plain", and you would like to serve these files normally instead of using the HTML::Mason handler. Use a Location directive like:

      
        SetHandler default-handler
      

Or suppose you have a "/cgi-bin" that you want to process via CGI:

      
        SetHandler cgi-script
      

When you have multiple Location directives, the latest ones in the configuration have the highest precedence. So to combine the previous directive with a typical Mason directive:

      
        SetHandler perl-script
        PerlHandler HTML::Mason
      

      
        SetHandler cgi-script
      

More generally, you can use various Apache configuration methods to control which handlers are called for a given request. Ken Williams uses a FilesMatch directive to invoke Mason only on requests for ".html" files:

       
         SetHandler perl-script
         PerlHandler HTML::Mason
       

Or you could reverse this logic, and write FilesMatch directives just for gifs and jpegs, or whatever.

If you are using a handler.pl, you can put the abort decision in your handler() routine. For example, a line like the following will produce the same end result as the  directive, above.

      return -1 if $r->uri() =~ m|^/plain|;

However, performance will not be as good as the all-Apache configuration.

=head2 Why am I getting 404 errors for pages that clearly exist?

The filename that Apache has resolved to may not fall underneath the component root you specified when you created the interpreter in handler.pl. HTML::Mason requires the file to fall under the component root so that it can call it as a top-level component. (For various reasons, such as object file creation, HTML::Mason cannot treat files outside the component root as a component.)

If you believe the file is in fact inside the component root and HTML::Mason is in error, it may be because you're referring to the Apache document root or the HTML::Mason component root through a symbolic link. The symbolic link may confuse HTML::Mason into thinking that two directories are different when they are in fact the same. This is a known "bug", but there is no obvious fix at this time. For now, you must refrain from using symbolic links in either of these configuration items.

The same thing could also happen in any context with more than one way to specify a canonical filename. For example, on Windows, if your document root starts with "C:" and your component root starts with "c:", you might have this problem even though both paths should resolve to the same file.

With Mason 0.895 and above, if you set Apache's LogLevel to warn, you will get appropriate warnings for these Mason-related 404s.

=head2 Some of my pages are being served with a content type other than text/html.  How do I get HTML::Mason to properly set the content type?

HTML::Mason doesn't actually touch the content type -- it relies on Apache to set it correctly. You can affect how Apache sets your content type in the configuration files (e.g. srm.conf). The most common change you'll want to make is to add the line

      DefaultType text/html

This indicates that files with no extension and files with an unknown extension should be treated as text/html. By default, Apache would treat them as text/plain.

=head2 Microsoft Internet Explorer displays my page just fine, but Netscape or other browsers just display the raw HTML code.

The most common cause of this is an incorrect content-type. All browsers are supposed to honor content-type, but MSIE tries to be smart and assumes content-type of text/html based on filename extension or page content.

The solution is to set your default content-type to text/html. See previous question.

=head2 My configuration prevents HTML::Mason from processing anything but html and text extensions, but I want to generate a dynamic image using HTML::Mason.  How can I get HTML::Mason to set the correct MIME type?

Use mod_perl's $r->content_type function to set the appropriate MIME type. This will allow you to output, for example, a GIF file, even if your component is called dynamicImage.html. However there's no guarantee that every browser (e.g. Internet Explorer) will respect your MIME type rather than your file extension. Make sure to test on multiple browsers.

=head2 How do I bring in external modules?


Use the PerlModule directive in your httpd.conf, or if you have a startup.pl file, put the 'use module' in there. If you want components to be able to refer to symbols exported by the module, however, you'll need to use the module inside the HTML::Mason::Commands package. See the "External modules" section of the Administrator's Guide.

=head2 How do I adjust Perl's INC path so it can find my modules?


You can do this:

    
    use lib ...
    

or this:

    PerlSetEnv PERL5LIB /path/one:/path/two:... 

=head2 How do I use Mason in conjunction with UserDir to support Mason in user's home directories?

The idea is to create one ApacheHandler for each user, dynamically. You will need to use a handler.pl or other wrapper code (see "Writing a Wrapper" in the Adminstrator's Manual).

Outside your handler subroutine:

       # $user_regexp: a regexp that matches the root directory of Mason.
       #               Make sure there is one arg in parens that represents
       #               the actual username--the handler uses this.
       my $user_regexp = qr'/Users/([^/]*)/(?:public_html|Sites)';
       my %user_handlers;
   
       # Create base ApacheHandler object at startup.
       my $base_ah = new HTML::Mason::ApacheHandler( comp_root => $comp_root,
                                                  data_dir  => $data_dir );

Inside your handler subroutine:

       sub handler
       {
           my $r=$_[0];
           ...
           #
           # Have a different handler for each home directory
           #
           my $curr_ah;
           my $filename = $r->filename();
           if($filename =~ m!$user_regexp!) {
               my $user_name = $1;
               $curr_ah = $user_handlers{$user_name};
               if(!$curr_ah) {
                   $filename =~ m!($user_regexp)!;
                   my $user_dir = $1;
                   $curr_ah = new HTML::Mason::ApacheHandler(comp_root=>[[$user_name => $user_dir]],
                                                             data_dir=>$data_dir);
                   $user_handlers{$1} = $curr_ah;
               }
           } else {
               $curr_ah = $base_ah;
           }
           my $status = $curr_ah->handle_request($r);
       
           return $status;
       }

=head2 How do I connect to a database from Mason?

The short answer is that most any perl code that works outside Mason, for connecting to a database, should work inside a component. I sometimes do draft development and quick debugging with something like:

      <%once>
      use DBI;
      

      <%init>
      my $dbh = DBI->connect ( blah, blah );
      ...
      

The long answer is, of course, longer. A good deal of thought should be put into how a web application talks to databases that it depends on, as these interconnections can easily be both performance bottlenecks and very un-robust.

Most people use some sort of connection pooling -- opening and then re-using a limited number of database connections. The Apache::DBI module provides connection pooling that is reliable and nearly painless. If Apache::DBI has been use'd, DBI->connect() will transparently reuse an already open connections, if it can.

The "right" place to ask Apache::DBI for database handles is often in a top level autohandler.

For example:

      <%init>
      my $dbh = DBI->connect('dbi:mysq:somedb', 'user', 'pw');
      ... # other processing
      $m->call_next( %ARGS, dbh => $dbh );
      

Alternately, $dbh could be a global variable which you set via MasonAllowGlobals.

You can use Apache::DBI in your httpd.conf file quite easily simply by adding:

      PerlModule Apache::DBI

If you want to do more with Apache::DBI, like call connect_on_init, you can use a  section

      
      use Apache::DBI;
      Apache::DBI->connect_on_init('dbi:mysql:somedb', 'user', 'pw');
      Apache::DBI->setPingTimeOut('dbi:mysql:somedb', 0);
      

Others may simply use a handler.pl file. Georgiou Kiriakos writes:

      You can connect in the handler.pl - I find it convenient to setup a
      global $dbh in it.  You just need to make sure you connect inside
      the handler subroutine (using Apache::DBI of course).  This way a)
      each httpd gets it's own connection and b) each httpd reconnects if
      the database is recycled.

Regardless of whether you set up global $dbh variables in handler.pl, the static sections of handler.pl should set up Apache::DBI stuff:

      # List of modules that you want to use from components (see Admin
      # manual for details)
      {
         package HTML::Mason::Commands;
         use Apache::DBI;
         # use'ing Apache::DBI here lets us connect from inside components
         # if we need to.
         # --
         # declare global variables, like $dbh, here as well.
       }

      # Configure database connection stuff
      my $datasource = "DBI:blah:blah";
      my $username = "user";
      my $password = "pass";
      my $attr = { RaiseError=>1 ,AutoCommit=>1 }; 
      Apache::DBI->connect_on_init($datasource, $username, $password, $attr);
      Apache::DBI->setPingTimeOut($datasource, 0);

=head2 How come a certain piece of Perl code runs fine under "regular" perl, but fails under Mason?

Mason is usually a red herring in this situation. Mason IS "regular" perl, with a very simple system to translate Mason component syntax to Perl code.  You can look at the object files Mason creates for your components (in the obj/ subdirectory of the Mason data directory) to see the actual Perl code Mason generates.

If something suddenly stops working when you place it in a Mason environment, the problem is far more likely to rest with the following environmental changes than with Mason itself:

* With mod_perl, the server is running under a different user/group and thus has different permissions for the resource you're trying to access

* With mod_perl, code can stay resident in the perl interpreter for a long time.

* Your headers may be sent differently under mod_perl than under your previous CGI situation (or whatever it was)

Mason does not have anything to do with sending mail, or accessing a database, or maintaining user accounts, or server authentication, so if your problems are in areas like these, your time will be better spent looking at other environmental changes like the ones mentioned above.

=head2 I'm using HTML::Mason::!ApacheHandler and I have decline_dirs disabled and am using a dhandler to handle directory requests. But when a request comes in without the final slash after the directory name, relative links are broken. What gives?


Mason has always incorrectly handled such directory requests; this issue will be resolved in the 1.3 release. The reason it will only be fixed in the next major version is that some folks may have come to rely on this functionality. So it's considered breaking backwards compatibility. But if you need it to do the right thing now, fear not! There are a number of workarounds to ensure that Apache adds a slash and redirects the browser to the appropriate URL. See HandlingDirectoriesWithDhandlers for all the juicy details.



UPGRADING TO 1.1x

=head2 After upgrading, I see this error whenever I load a page: "The following parameter was passed in the call to HTML::Mason::Component::FileBased->new() but was not listed in the validation options: create_time"

Delete all of your object files.

=head2 When I try to start my server I see an error like: "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.

You are explicitly creating an Interp object in your handler.pl and then passing that to ApacheHandler->new. 

Instead, simply pass all of your Interp parameters to ApacheHandler->new directly. The parameters will end up going where they belong.

=head2 When I start Apache (or try to use Mason) I get an error like this: "The Parser module is no longer a part of HTML::Mason.  Please see the Lexer and Compiler modules, its replacements."

The Parser module is no longer used.

=head2 I get an error like: "The following parameters were passed in the call to HTML::Mason::Container::new but were not listed in the validation options: error_format error_mode request_class resolver_class" when using ApacheHandler

Do you have PerlFreshRestart turned on? Turn it off.

See http://perl.apache.org/docs/1.0/guide/troubleshooting.html - "Evil things might happen when using PerlFreshRestart".

=head2 I get an error like this: 'Can't locate object method "make_ah"

package "Apache"' ===
We're not kidding. PerlFreshRestart is evil. Turn it off. See question above.

=head2 I get: "Unknown config item 'comp_root'" or "Unknown config item 'comp_root'" or something similar with ApacheHandler.

Turn PerlFreshRestart off. Really.

=head2 I get this with a custom handler.pl: 'Can't call method "handle_request" on an undefined value at ...'

Just in case you weren't convinced that PerlFreshRestart is a bad idea, this should help convince you.

=head2 After upgrading, I get this error for all my components: '<%' without matching '%>' ...

The "perl_' prefix for Mason tags, like <%perl_args>, is no longer supported. Remove this prefix.

=head1 WHERE TO FIND INFORMATION

=head2 Where do I obtain HTML::Mason?

HTML::Mason is available from CPAN (the Comprehensive Perl Archive Network). Details about CPAN are available at http://www.perl.com/. See the [FAQ:Installation] section of this document for tips on obtaining and installing Mason.

=head2 Where can I ask questions about HTML::Mason?

See ContactUs and MailingLists.
HTML-Mason-1.59/lib/HTML/Mason/Interp.pm0000644000175000017500000013366513660015140017327 0ustar  autarchautarch# -*- cperl-indent-level: 4; cperl-continued-brace-offset: -4; cperl-continued-statement-offset: 4 -*-

# 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.

package HTML::Mason::Interp;
$HTML::Mason::Interp::VERSION = '1.59';
use strict;
use warnings;

use File::Basename;
use File::Path;
use File::Spec;
use File::Temp;
use HTML::Mason;
use HTML::Mason::Escapes;
use HTML::Mason::Request;
use HTML::Mason::Resolver::File;
use HTML::Mason::Tools qw(read_file taint_is_on load_pkg);

use HTML::Mason::Exceptions( abbr => [qw(param_error system_error wrong_compiler_error compilation_error error)] );

use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { param_error join '', @_  } );

use Class::Container;
use base qw(Class::Container);

BEGIN
{
    # Fields that can be set in new method, with defaults
    __PACKAGE__->valid_params
        (
         autohandler_name =>
         { parse => 'string',  default => 'autohandler', type => SCALAR,
           descr => "The filename to use for Mason's 'autohandler' capability" },

         buffer_preallocate_size =>
         { parse => 'string', default => 0, type => SCALAR,
           descr => "Number of bytes to preallocate in request buffer" },
         
         code_cache_max_size =>
         { parse => 'string',  default => 'unlimited', type => SCALAR,
           descr => "The maximum number of components in the code cache" },

         comp_root =>
         { parse => 'list',
           type => SCALAR|ARRAYREF,
           default => File::Spec->rel2abs( Cwd::cwd ),
           descr => "A string or array of arrays indicating the search path for component calls" },

         compiler =>
         { isa => 'HTML::Mason::Compiler',
           descr => "A Compiler object for compiling components" },

         data_dir =>
         { parse => 'string', optional => 1, type => SCALAR,
           descr => "A directory for storing cache files and other state information" },

         dynamic_comp_root =>
         { parse => 'boolean', default => 0, type => BOOLEAN,
           descr => "Indicates whether the comp_root may be changed between requests" },

         escape_flags =>
         { parse => 'hash_list', optional => 1, type => HASHREF,
           descr => "A list of escape flags to set (as if calling the set_escape() method" },

         object_file_extension =>
         { parse => 'string',  type => SCALAR, default => '.obj',
           descr => "Extension to add to the end of object files" },

         # OBJECT cause qr// returns an object
         ignore_warnings_expr =>
         { parse => 'string',  type => SCALAR|OBJECT, default => qr/Subroutine .* redefined/i,
           descr => "A regular expression describing Perl warning messages to ignore" },

         preloads =>
         { parse => 'list', optional => 1, type => ARRAYREF,
           descr => "A list of components to load immediately when creating the Interpreter" },

         resolver =>
         { isa => 'HTML::Mason::Resolver',
           descr => "A Resolver object for fetching components from storage" },

         static_source =>
         { parse => 'boolean', default => 0, type => BOOLEAN,
           descr => "When true, we only compile source files once" },

         static_source_touch_file =>
         { parse => 'string', optional => 1, type => SCALAR, 
           descr => "A file that, when touched, causes Mason to clear its component caches" },

         use_object_files =>
         { parse => 'boolean', default => 1, type => BOOLEAN,
           descr => "Whether to cache component objects on disk" },
        );

    __PACKAGE__->contained_objects
        (
         resolver => { class => 'HTML::Mason::Resolver::File',
                       descr => "This class is expected to return component information based on a component path" },
         compiler => { class => 'HTML::Mason::Compiler::ToObject',
                       descr => "This class is used to translate component source into code" },
         request  => { class => 'HTML::Mason::Request',
                       delayed => 1,
                       descr => "Objects returned by make_request are members of this class" },
        );
}

use HTML::Mason::MethodMaker
    ( read_only => [ qw( autohandler_name
                         buffer_preallocate_size
                         code_cache
                         code_cache_min_size
                         code_cache_max_size
                         compiler
                         data_dir
                         dynamic_comp_root
                         object_file_extension
                         preallocated_output_buffer
                         preloads
                         resolver
                         source_cache
                         static_source
                         static_source_touch_file
                         use_internal_component_caches
                         use_object_files
                        ) ],

      read_write => [ map { [ $_ => __PACKAGE__->validation_spec->{$_} ] }
                      qw( ignore_warnings_expr
                         )
                    ],

      read_write_contained => { request =>
                                [ [ autoflush => { type => BOOLEAN } ],
                                  [ data_cache_api => { type => SCALAR } ],
                                  [ data_cache_defaults => { type => HASHREF } ],
                                  [ dhandler_name => { type => SCALAR } ],
                                  [ error_format => { type => SCALAR } ],
                                  [ error_mode => { type => SCALAR } ],
                                  [ max_recurse => { type => SCALAR } ],
                                  [ out_method => { type => SCALARREF | CODEREF } ],
                                  [ plugins => { type => ARRAYREF } ],
                                ]
                              },
      );

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new(@_);

    $self->_initialize;
    return $self;
}

sub _initialize
{
    my ($self) = shift;
    $self->{code_cache} = {};
    $self->{source_cache} = {};
    $self->{files_written} = [];
    $self->{static_source_touch_file_lastmod} = 0;

    $self->_assign_comp_root($self->{comp_root});
    $self->_check_data_dir();
    $self->_create_data_subdirs();
    $self->_initialize_escapes();

    #
    # Create preallocated buffer for requests.
    #
    $self->{preallocated_output_buffer} = ' ' x $self->buffer_preallocate_size;

    $self->_set_code_cache_attributes();

    #
    # If static_source=1, unlimited_code_cache=1, and
    # dynamic_comp_root=0, we can safely cache component objects keyed
    # on path throughout the framework (e.g. within other component
    # objects). These internal caches can be cleared in
    # $interp->flush_code_cache (the only legimiate place for a
    # component to be eliminated from the cache), eliminating any
    # chance for leaked objects.
    #
    # static_source has to be on or else we might keep around
    # old versions of components that have changed.
    #
    # unlimited_code_cache has to be on or else we might leak
    # components when we discard.
    #
    # dynamic_comp_root has to be 0 because the cache would not be
    # valid for different combinations of component root across
    # different requests.
    #
    $self->{use_internal_component_caches} =
        ($self->{static_source} &&
         $self->{unlimited_code_cache} &&
         !$self->{dynamic_comp_root});

    $self->_preload_components();
}

sub _check_data_dir
{
    my $self = shift;

    return unless $self->{data_dir};

    $self->{data_dir} = File::Spec->canonpath( $self->{data_dir} );
    param_error "data_dir '$self->{data_dir}' must be an absolute directory"
        unless File::Spec->file_name_is_absolute( $self->{data_dir} );
}

sub _create_data_subdirs
{
    my $self = shift;

    if ($self->data_dir) {
        $self->_make_object_dir;
        $self->_make_cache_dir;
    } else {
        $self->{use_object_files} = 0;
    }
}

sub _initialize_escapes
{
    my $self = shift;

    #
    # Add the escape flags (including defaults)
    #
    foreach ( [ h => \&HTML::Mason::Escapes::html_entities_escape ],
              [ u => \&HTML::Mason::Escapes::url_escape ],
            )
    {
        $self->set_escape(@$_);
    }

    if ( my $e = delete $self->{escape_flags} )
    {
        while ( my ($flag, $code) = each %$e )
        {
            $self->set_escape( $flag => $code );
        }
    }
}

sub _set_code_cache_attributes
{
    my $self = shift;

    $self->{unlimited_code_cache} = ($self->{code_cache_max_size} eq 'unlimited');
    unless ($self->{unlimited_code_cache}) {
        $self->{code_cache_min_size} = $self->{code_cache_max_size} * 0.75;
    }
}

sub _preload_components
{
    my $self = shift;

    return unless $self->preloads;

    foreach my $pattern (@{$self->preloads}) {
        error "preload pattern '$pattern' must be an absolute path"
            unless File::Spec->file_name_is_absolute($pattern);
        my %path_hash;
        foreach my $pair ($self->comp_root_array) {
            my $root = $pair->[1];
            foreach my $path ($self->resolver->glob_path($pattern, $root)) {
                $path_hash{$path}++;
            }
        }
        my @paths = keys(%path_hash);
        warn "Didn't find any components for preload pattern '$pattern'"
            unless @paths;
        foreach (@paths)
        {
            $self->load($_)
                or error "Cannot load component $_, found via pattern $pattern";
        }
    }
}

#
# Functions for retrieving and creating data subdirectories.
#
sub object_dir { my $self = shift; return $self->data_dir ? File::Spec->catdir( $self->data_dir, 'obj' ) : ''; }
sub object_create_marker_file { my $self = shift; return $self->object_dir ? File::Spec->catfile($self->object_dir, '.__obj_create_marker') : ''; }
sub cache_dir  { my $self = shift; return $self->data_dir ? File::Spec->catdir( $self->data_dir, 'cache' ) : ''; }

sub _make_data_subdir
{
    my ($self, $dir) = @_;

    unless (-d $dir) {
        my @newdirs = eval { mkpath( $dir, 0, 0775 ) };
        if ($@) {
            my $user  = getpwuid($<);
            my $group = getgrgid($();
            my $data_dir = $self->data_dir;
            error "Cannot create directory '$dir' ($@) for user '$user', group '$group'. " .
                "Perhaps you need to create or set permissions on your data_dir ('$data_dir'). ";
        }
        $self->push_files_written(@newdirs);
    }
}

sub _make_object_dir
{
    my ($self) = @_;

    my $object_dir = $self->object_dir;
    $self->_make_data_subdir($object_dir);
    my $object_create_marker_file = $self->object_create_marker_file;
    unless (-f $object_create_marker_file) {
        open my $fh, ">$object_create_marker_file"
            or system_error "Could not create '$object_create_marker_file': $!";
        $self->push_files_written($object_create_marker_file);
    }
}

sub _make_cache_dir
{
    my ($self) = @_;

    my $cache_dir = $self->cache_dir;
    $self->_make_data_subdir($cache_dir);
}

#
# exec is the initial entry point for executing a component
# in a new request.
#
sub exec {
    my $self = shift;
    my $comp = shift;
    $self->make_request(comp=>$comp, args=>\@_)->exec;
}

sub make_request {
    my $self = shift;

    return $self->create_delayed_object( 'request', interp => $self, @_ );
}

sub comp_exists {
    my ($self, $path) = @_;
    return $self->resolve_comp_path_to_source($path);
}

#
# Load <$path> into a component, possibly parsing the source and/or
# caching the code. Returns a component object or undef if the
# component was not found.
#
sub load {
    my ($self, $path) = @_;
    my ($maxfilemod, $objfile, $objfilemod);
    my $code_cache = $self->{code_cache};
    my $resolver = $self->{resolver};

    #
    # Path must be absolute.
    #
    unless (substr($path, 0, 1) eq '/') {
        error "Component path given to Interp->load must be absolute (was given $path)";
    }

    #
    # Get source info from resolver.
    #
    my $source = $self->resolve_comp_path_to_source($path);

    # No component matches this path.
    return unless defined $source;

    # comp_id is the unique name for the component, used for cache key
    # and object file name.
    my $comp_id = $source->comp_id;

    #
    # Get last modified time of source.
    #
    my $srcmod = $source->last_modified;

    #
    # If code cache contains an up to date entry for this path, use
    # the cached comp.  Always use the cached comp in static_source
    # mode.
    #
    if ( exists $code_cache->{$comp_id} &&
         ( $self->static_source || $code_cache->{$comp_id}->{lastmod} >= $srcmod )
       ) {
        return $code_cache->{$comp_id}->{comp};
    }

    if ($self->{use_object_files}) {
        $objfile = $self->comp_id_to_objfile($comp_id);

        my @stat = stat $objfile;
        if ( @stat && ! -f _ ) {
            error "The object file '$objfile' exists but it is not a file!";
        }

        if ($self->static_source) {
            # No entry in the code cache so if the object file exists,
            # we will use it, otherwise we must create it.  These
            # values make that happen.
            $objfilemod = @stat ? $srcmod : 0;
        } else {
            # If the object file exists, get its modification time.
            # Otherwise (it doesn't exist or it is a directory) we
            # must create it.
            $objfilemod = @stat ? $stat[9] : 0;
        }
    }

    my $comp;
    if ($objfile) {
        #
        # We are using object files.  Update object file if necessary
        # and load component from there.
        #
        # If loading the object file generates an error, or results in
        # a non-component object, try regenerating the object file
        # once before giving up and reporting an error. This can be
        # handy in the rare case of an empty or corrupted object file.
        # (But add an exception for "Compilation failed in require" errors, since
        # the bad module will be added to %INC and the error will not occur
        # the second time - RT #39803).
        #
        if ($objfilemod < $srcmod) {
            $self->compiler->compile_to_file( file => $objfile, source => $source);
        }
        $comp = eval { $self->eval_object_code( object_file => $objfile ) };

        if (!UNIVERSAL::isa($comp, 'HTML::Mason::Component')) {
            if (!defined($@) || $@ !~ /failed in require/) {
                $self->compiler->compile_to_file( file => $objfile, source => $source);
                $comp = eval { $self->eval_object_code( object_file => $objfile ) };
            }

            if (!UNIVERSAL::isa($comp, 'HTML::Mason::Component')) {
                my $error = $@ ? $@ : "Could not get HTML::Mason::Component object from object file '$objfile'";
                $self->_compilation_error( $source->friendly_name, $error );
            }
        }
    } else {
        #
        # Not using object files. Load component directly into memory.
        #
        my $object_code = $source->object_code( compiler => $self->compiler );
        $comp = eval { $self->eval_object_code( object_code => $object_code ) };
        $self->_compilation_error( $source->friendly_name, $@ ) if $@;
    }
    $comp->assign_runtime_properties($self, $source);

    #
    # Delete any stale cached version of this component, then
    # cache it.
    #
    $self->delete_from_code_cache($comp_id);
    $code_cache->{$comp_id} = { lastmod => $srcmod, comp => $comp };

    return $comp;
}

sub delete_from_code_cache {
    my ($self, $comp_id) = @_;
    return unless defined $self->{code_cache}{$comp_id}{comp};

    delete $self->{code_cache}{$comp_id};
    return;
}

sub comp_id_to_objfile {
    my ($self, $comp_id) = @_;

    return File::Spec->catfile
               ( $self->object_dir,
                 $self->compiler->object_id,
                 ( split /\//, $comp_id ),
               ) . $self->object_file_extension;
}

#
# Empty in-memory code cache.
#
sub flush_code_cache {
    my $self = shift;

    # Necessary for preventing memory leaks
    if ($self->use_internal_component_caches) {
        foreach my $entry (values %{$self->{code_cache}}) {
            my $comp = $entry->{comp};
            $comp->flush_internal_caches;
        }
    }
    $self->{code_cache} = {};
    $self->{source_cache} = {};
}

#
# If code cache has exceeded maximum, remove least frequently used
# elements from cache until size falls below minimum.
#
sub purge_code_cache {
    my ($self) = @_;

    return if $self->{unlimited_code_cache};
    my $current_size = scalar(keys(%{$self->{code_cache}}));
    if ($current_size > $self->code_cache_max_size) {
        my $code_cache = $self->{code_cache};
        my $min_size = $self->code_cache_min_size;
        my $decay_factor = 0.75;

        my @elems;
        while (my ($path,$href) = each(%{$code_cache})) {
            push(@elems,[$path,$href->{comp}->mfu_count,$href->{comp}]);
        }
        @elems = sort { $a->[1] <=> $b->[1] } @elems;
        while (($current_size > $min_size) and @elems) {
            $self->delete_from_code_cache(shift(@elems)->[0]);
            $current_size--;
        }

        #
        # Multiply each remaining cache item's count by a decay factor,
        # to gradually reduce impact of old information.
        #
        foreach my $elem (@elems) {
            $elem->[2]->mfu_count( $elem->[2]->mfu_count * $decay_factor );
        }
    }
}

#
# Clear the object directory of all current files and subdirectories.
# Do this by renaming the object directory to a temporary name,
# immediately recreating an empty object directory, then removing
# the empty object directory. If another process tries to write
# the object file in between these steps, it'll create the top
# object directory instead.
#
# Would be nice to fork off a separate process to do the removing so
# that it doesn't affect a request's response time, but difficult to
# do this in an environment-generic way.
#
sub remove_object_files
{
    my $self = shift;

    my $object_dir = $self->object_dir;
    if (-d $object_dir) {
        my $temp_dir = File::Temp::tempdir(DIR => $self->data_dir);
        rename($object_dir, File::Spec->catdir( $temp_dir, 'target' ) )
            or die "could not rename '$object_dir' to '$temp_dir': $@";
        $self->_make_object_dir();
        rmtree($temp_dir);
    } else {
        $self->_make_object_dir();
    }
}

#
# Check the static_source_touch_file, if one exists, to see if it has
# changed since we last checked. If it has, clear the code cache and
# object files if appropriate.
#
sub check_static_source_touch_file
{
    my $self = shift;

    if (my $touch_file = $self->static_source_touch_file) {
        return unless -f $touch_file;
        my $touch_file_lastmod = (stat($touch_file))[9];
        if ($touch_file_lastmod > $self->{static_source_touch_file_lastmod}) {

            # File has been touched since we last checked.  First,
            # clear the object file directory if the last mod of
            # its ._object_create_marker is earlier than the touch file,
            # or if the marker doesn't exist.
            #
            if ($self->use_object_files) {
                my $object_create_marker_file = $self->object_create_marker_file;
                if (!-e $object_create_marker_file ||
                    (stat($object_create_marker_file))[9] < $touch_file_lastmod) {
                    $self->remove_object_files;
                }
            }

            # Next, clear the in-memory component cache.
            #
            $self->flush_code_cache;

            # Reset lastmod value.
            #
            $self->{static_source_touch_file_lastmod} = $touch_file_lastmod;
        }
    }
}

#
# Construct a component on the fly.  Virtual if 'path' parameter is
# given, otherwise anonymous.
#
sub make_component {
    my $self = shift;

    my %p = validate(@_, { comp_source => { type => SCALAR, optional => 1 },
                           comp_file   => { type => SCALAR, optional => 1 },
                           name        => { type => SCALAR, optional => 1 } });

    $p{comp_source} = read_file(delete $p{comp_file}) if exists $p{comp_file};
    param_error "Must specify either 'comp_source' or 'comp_file' parameter to 'make_component()'"
        unless defined $p{comp_source};

    $p{name} ||= '';

    my $source = HTML::Mason::ComponentSource->new( friendly_name => $p{name},
                                                    comp_path => $p{name},
                                                    comp_id => undef,
                                                    last_modified => time,
                                                    comp_class => 'HTML::Mason::Component',
                                                    source_callback => sub { $p{comp_source} },
                                                  );

    my $object_code = $source->object_code( compiler => $self->compiler);

    my $comp = eval { $self->eval_object_code( object_code => $object_code ) };
    $self->_compilation_error( $p{name}, $@ ) if $@;

    $comp->assign_runtime_properties($self, $source);

    return $comp;
}

sub set_global
{
    my ($self, $decl, @values) = @_;
    param_error "Interp->set_global: expects a variable name and one or more values"
        unless @values;
    my ($prefix, $name) = ($decl =~ s/^([\$@%])//) ? ($1, $decl) : ('$', $decl);

    my $varname = sprintf("%s::%s",$self->compiler->in_package,$name);
    no strict 'refs';
    no warnings 'once';
    if ($prefix eq '$') {
        $$varname = $values[0];
    } elsif ($prefix eq '@') {
        @$varname = @values;
    } else {
        %$varname = @values;
    }
}

sub comp_root
{
    my $self = shift;
    
    if (my $new_comp_root = shift) {
        die "cannot assign new comp_root unless dynamic_comp_root parameter is set"
          unless $self->dynamic_comp_root;
        $self->_assign_comp_root($new_comp_root);
    }
    if (@{$self->{comp_root}} == 1 and $self->{comp_root}[0][0] eq 'MAIN') {
        return $self->{comp_root}[0][1];
    } else {
        return $self->{comp_root};
    }
}

sub comp_root_array
{
    return @{ $_[0]->{comp_root} };
}

sub _assign_comp_root
{
    my ($self, $new_comp_root) = @_;

    # Force into lol format.
    if (!ref($new_comp_root)) {
        $new_comp_root = [[ MAIN => $new_comp_root ]];
    } elsif (ref($new_comp_root) ne 'ARRAY') {
        die "Component root $new_comp_root must be a scalar or array reference";
    }

    # Validate key/path pairs, and check to see if any of them
    # conflict with old pairs.
    my $comp_root_key_map = $self->{comp_root_key_map} ||= {};
    foreach my $pair (@$new_comp_root) {
        param_error "Multiple-path component root must consist of a list of two-element lists"
          if ref($pair) ne 'ARRAY';
        param_error "Component root key '$pair->[0]' cannot contain slash"
          if $pair->[0] =~ /\//;
        $pair->[1] = File::Spec->canonpath( $pair->[1] );
        param_error "comp_root path '$pair->[1]' is not an absolute directory"
          unless File::Spec->file_name_is_absolute( $pair->[1] );
            
        my ($key, $path) = @$pair;
        if (my $orig_path = $comp_root_key_map->{$key}) {
            if ($path ne $orig_path) {
                die "comp_root key '$key' was originally associated with '$path', cannot change to '$orig_path'";
            }
        } else {
            $comp_root_key_map->{$key} = $path;
        }
    }
    $self->{comp_root} = $new_comp_root;
}

sub resolve_comp_path_to_source
{
    my ($self, $path) = @_;
    
    my $source;
    if ($self->{static_source}) {
        # Maintain a separate source_cache for each component root,
        # because the set of active component roots can change
        # from request to request.
        #
        my $source_cache = $self->{source_cache};
        foreach my $pair (@{$self->{comp_root}}) {
            my $source_cache_for_root = $source_cache->{$pair->[0]} ||= {};
            unless (exists($source_cache_for_root->{$path})) {
                $source_cache_for_root->{$path}
                  = $self->{resolver}->get_info($path, @$pair);
            }
            last if $source = $source_cache_for_root->{$path};
        }
    } else {
        my $resolver = $self->{resolver};
        foreach my $pair ($self->comp_root_array) {
            last if $source = $resolver->get_info($path, @$pair);
        }
    }
    return $source;
}

sub files_written
{
    my $self = shift;
    return @{$self->{files_written}};
}

#
# Push onto list of written files.
#
sub push_files_written
{
    my $self = shift;
    my $fref = $self->{'files_written'};
    push(@$fref,@_);
}

#
# Look for component <$name> starting in <$startpath> and moving upwards
# to the root. Return component object or undef.
#
sub find_comp_upwards
{
    my ($self, $startpath, $name) = @_;
    $startpath =~ s{/+$}{};

    # Don't use File::Spec here, this is a URL path.
    do {
      my $comp = $self->load("$startpath/$name");
      return $comp if $comp;
    } while $startpath =~ s{/+[^/]*$}{};

    return;  # Nothing found
}

###################################################################
# The eval_object_code & write_object_file methods used to be in
# Parser.pm.  This is a temporary home only.  They need to be moved
# again at some point in the future (during some sort of interp
# re-architecting).
###################################################################

#
# eval_object_code
#   (object_code, object_file, error)
# Evaluate an object file or object text.  Return a component object
# or undef if error.
#
# I think this belongs in the resolver (or comp loader) - Dave
#
sub eval_object_code
{
    my ($self, %p) = @_;

    #
    # Evaluate object file or text with warnings on, unless
    # ignore_warnings_expr is '.'.
    #
    my $ignore_expr = $self->ignore_warnings_expr;
    my ($comp, $err);
    my $warnstr = '';

    {
        local $^W = $ignore_expr eq '.' ? 0 : 1;
        local $SIG{__WARN__} =
            ( $ignore_expr ?
              ( $ignore_expr eq '.' ?
                sub { } :
                sub { $warnstr .= $_[0] if $_[0] !~ /$ignore_expr/ }
              ) :
              sub { $warnstr .= $_[0] } );
        
        $comp = $self->_do_or_eval(\%p);
    }

    $err = $warnstr . $@;

    #
    # Return component or error
    #
    if ($err) {
        # attempt to stem very long eval errors
        $err =~ s/has too many errors\..+/has too many errors./s;
        compilation_error $err;
    } else {
        return $comp;
    }
}

sub _do_or_eval
{
    my ($self, $p) = @_;

    if ($p->{object_file}) {
        return do $p->{object_file};
    } else {
        # If in taint mode, untaint the object text
        (${$p->{object_code}}) = ${$p->{object_code}} =~ /^(.*)/s if taint_is_on;

        return eval ${$p->{object_code}};
    }
}

sub _compilation_error {
    my ($self, $filename, $err) = @_;

    HTML::Mason::Exception::Compilation->throw(error=>$err, filename=>$filename);
}


sub object_file {
    my ($self, $comp) = @_;
    return $comp->persistent ?
        $self->comp_id_to_objfile($comp->comp_id) :
        undef;
}

sub use_autohandlers
{
    my $self = shift;
    return (defined $self->{autohandler_name} and length $self->{autohandler_name});
}

# Generate HTML that describes Interp's current status.
# This is used in things like Apache::Status reports.  Currently shows:
# -- Interp properties
# -- loaded (cached) components
sub status_as_html {
    my ($self, %p) = @_;

    # Should I be scared about this?  =)

    my $comp_source = <<'EOF';

Interpreter properties:



 
Startup options:

 

<%perl>
foreach my $property (sort keys %$interp) {
    my $val = $interp->{$property};

    my $default = ( defined $val && defined $valid{$property}{default} && $val eq $valid{$property}{default} ) || ( ! defined $val && exists $valid{$property}{default} && ! defined $valid{$property}{default} );

    my $display = $val;
    if (ref $val) {
        $display = '';
        # only object can ->can, others die
        my $is_object = eval { $val->can('anything'); 1 };
        if ($is_object) {
            $display .= ref $val . ' object';
        } else {
            if (UNIVERSAL::isa($val, 'ARRAY')) {
                $display .= 'ARRAY reference - [ ';
                $display .= join ', ', @$val;
                $display .= '] ';
            } elsif (UNIVERSAL::isa($val, 'HASH')) {
                $display .= 'HASH reference - { ';
                my @pairs;
                while (my ($k, $v) = each %$val) {
                   push @pairs, "$k => $v";
                }
                $display .= join ', ', @pairs;
                $display .= ' }';
            } else {
                $display = ref $val . ' reference';
            }
        }
        $display .= '';
    }

    defined $display && $display =~ s,([\x00-\x1F]),'control-' . chr( ord('A') + ord($1) - 1 ) . '',eg; # does this work for non-ASCII?

% }


 

  
    <% $property | h %>
  
  
   <% defined $display ? $display : 'undef' %>
   <% $default ? '(default)' : '' %>
  
 

  

 
Components in memory cache:

 
% my $cache;
% if ($cache = $interp->code_cache and %$cache) {
%   foreach my $key (sort keys %$cache) {
      <% $key |h%> (modified <% scalar localtime $cache->{$key}->{lastmod} %>)
      

%   }
% } else {
    None
% }
  



<%args>
 $interp   # The interpreter we'll elucidate
 %valid    # Default values for interp member data

EOF

    my $comp = $self->make_component(comp_source => $comp_source);
    my $out;

    my $args = [interp => $self, valid => $self->validation_spec];
    $self->make_request(comp=>$comp, args=>$args, out_method=>\$out, %p)->exec;

    return $out;
}

sub set_escape
{
    my $self = shift;
    my %p = @_;

    while ( my ($name, $sub) = each %p )
    {
        my $flag_regex = $self->compiler->lexer->escape_flag_regex;

        param_error "Invalid escape name ($name)"
            if $name !~ /^$flag_regex$/ || $name =~ /^n$/;

        my $coderef;
        if ( ref $sub )
        {
            $coderef = $sub;
        }
        else
        {
            if ( $sub =~ /^\w+$/ )
            {
                no strict 'refs';
                unless ( defined &{"HTML::Mason::Escapes::$sub"} )
                {
                    param_error "Invalid escape: $sub (no matching subroutine in HTML::Mason::Escapes";
                }

                $coderef = \&{"HTML::Mason::Escapes::$sub"};
            }
            else
            {
                $coderef = eval $sub;
                param_error "Invalid escape: $sub ($@)" if $@;
            }
        }

        $self->{escapes}{$name} = $coderef;
    }
}

sub remove_escape
{
    my $self = shift;

    delete $self->{escapes}{ shift() };
}

sub apply_escapes
{
    my $self = shift;
    my $text = shift;

    foreach my $flag (@_)
    {
        param_error "Invalid escape flag: $flag"
            unless exists $self->{escapes}{$flag};

        $self->{escapes}{$flag}->(\$text);
    }

    return $text;
}

1;

__END__

=head1 NAME

HTML::Mason::Interp - Mason Component Interpreter

=head1 SYNOPSIS

    my $i = HTML::Mason::Interp->new (data_dir=>'/usr/local/mason',
                                      comp_root=>'/usr/local/www/htdocs/',
                                      ...other params...);

=head1 DESCRIPTION

Interp is the Mason workhorse, executing components and routing their
output and errors to all the right places. In a mod_perl environment,
Interp objects are handed off immediately to an ApacheHandler object
which internally calls the Interp implementation methods. In that case
the only user method is the new() constructor.

=head1 PARAMETERS TO THE new() CONSTRUCTOR

=over

=item autohandler_name

File name used for
L. Default is
"autohandler".  If this is set to an empty string ("") then
autohandlers are turned off entirely.

=item buffer_preallocate_size

=for html 

Number of bytes to preallocate in the output buffer for each request.
Defaults to 0. Setting this to, say, your maximum page size (or close
to it) can reduce the number of reallocations Perl performs as
components add to the output buffer.

=item code_cache_max_size

=for html 

Specifies the maximum number of components that should be held in the
in-memory code cache. The default is 'unlimited', meaning no
components will ever be discarded; Mason can perform certain
optimizations in this mode. Setting this to zero disables the code
cache entirely. See the L
section of the administrator's manual for further details.

=item comp_root

=for html 

The component root marks the top of your component hierarchy and
defines how component paths are translated into real file paths. For
example, if your component root is F, a component
path of F translates to the file
F.

Under L and
L, comp_root defaults to the server's
document root. In standalone mode comp_root defaults to the current
working directory.

This parameter may be either a scalar or an array reference.  If it is
a scalar, it should be a filesystem path indicating the component
root. If it is an array reference, it should be of the following form:

 [ [ foo => '/usr/local/foo' ],
   [ bar => '/usr/local/bar' ] ]

This is an array of two-element array references, not a hash.  The
"keys" for each path must be unique and their "values" must be
filesystem paths.  These paths will be searched in the provided order
whenever a component path is resolved. For example, given the above
component roots and a component path of F, Mason
would search first for F, then for
F.

The keys are used in several ways. They help to distinguish component
caches and object files between different component roots, and they
appear in the C of a component.

When you specify a single path for a component root, this is actually
translated into

  [ [ MAIN => path ] ]

If you have turned on L, you may modify the
component root(s) of an interpreter between requests by calling
C<$interp-Ecomp_root> with a value. However, the path associated
with any given key may not change between requests. For example,
if the initial component root is

 [ [ foo => '/usr/local/foo' ],
   [ bar => '/usr/local/bar' ], ]

then it may not be changed to

 [ [ foo => '/usr/local/bar' ],
   [ bar => '/usr/local/baz' ],

but it may be changed to

 [ [ foo   => '/usr/local/foo' ],
   [ blarg => '/usr/local/blarg' ] ]

In other words, you may add or remove key/path pairs but not modify an
already-used key/path pair. The reason for this restriction is that
the interpreter maintains a component cache per key that would become
invalid if the associated paths were to change.

=item compiler

The Compiler object to associate with this Interpreter.  By default a
new object of class L will be created.

=item compiler_class

The class to use when creating a compiler. Defaults to
L.

=item data_dir

The data directory is a writable directory that Mason uses for various
features and optimizations: for example, component object files and
data cache files. Mason will create the directory on startup, if necessary, and set its
permissions according to the web server User/Group.

Under L, data_dir defaults to a
directory called "mason" under the Apache server root. You will
need to change this on certain systems that assign a high-level
server root such as F!

In non-Apache environments, data_dir has no default. If it is left
unspecified, Mason will not use L, and the default
L will be
C instead of C.

=item dynamic_comp_root

True or false, defaults to false. Indicates whether the L
can be modified on this interpreter between requests. Mason can
perform a few optimizations with a fixed component root, so you
should only set this to true if you actually need it.

=item escape_flags

A hash reference of escape flags to set for this object.  See the
section on the L for more details.

=item ignore_warnings_expr

Regular expression indicating which warnings to ignore when loading
components. Any warning that is not ignored will prevent the
component from being loaded and executed. For example:

    ignore_warnings_expr =>
        'Global symbol.*requires explicit package'

If set to undef, all warnings are heeded. If set to '.', warnings
are turned off completely as a specially optimized case.

By default, this is set to 'Subroutine .* redefined'.  This allows you
to declare global subroutines inside <%once> sections and not receive
an error when the component is reloaded.

=item object_file_extension

Extension to add to the end of object files. Default is ".obj".

=item preloads

A list of component paths, optionally with glob wildcards, to load
when the interpreter initializes. e.g.

    preloads => ['/foo/index.html','/bar/*.pl']

Default is the empty list.  For maximum performance, this should only
be used for components that are frequently viewed and rarely updated.
See the L section of the administrator's manual for further details.

As mentioned in the developer's manual, a component's C<< <%once> >>
section is executed when it is loaded.  For preloaded components, this
means that this section will be executed before a Mason or Apache
request exist, so preloading a component that uses C<$m> or C<$r> in a
C<< <%once> >> section will fail.

=item request_class

The class to use when creating requests. Defaults to
L.

=item resolver

The Resolver object to associate with this Compiler. By default a new
object of class L will be created.

=item resolver_class

The class to use when creating a resolver. Defaults to
L.

=item static_source

True or false, default is false. When false, Mason checks the
timestamp of the component source file each time the component is used
to see if it has changed. This provides the instant feedback for
source changes that is expected for development.  However it does
entail a file stat for each component executed.

When true, Mason assumes that the component source tree is unchanging:
it will not check component source files to determine if the memory
cache or object file has expired.  This can save many file stats per
request. However, in order to get Mason to recognize a component
source change, you must flush the memory cache and remove object files.
See L for one easy way to arrange this.

We recommend turning this mode on in your production sites if
possible, if performance is of any concern.

=item static_source_touch_file

Specifies a filename that Mason will check once at the beginning of
of every request. When the file timestamp changes, Mason will (1) clear
its in-memory component cache, and (2) remove object files if
they have not already been deleted by another process.

This provides a convenient way to implement L mode.
All you need to do is make sure that a single file gets touched
whenever components change. For Mason's part, checking a single
file at the beginning of a request is much cheaper than checking
every component file when static_source=0.

=item use_object_files

True or false, default is true.  Specifies whether Mason creates
object files to save the results of component parsing. You may want to
turn off object files for disk space reasons, but otherwise this
should be left alone.

=back

=head1 ACCESSOR METHODS

All of the above properties have standard accessor methods of the same
name. Only comp_root and ignore_warnings_expr can be modified in an
existing interpreter; the rest are read-only.

=head1 ESCAPE FLAG METHODS

=over

=item apply_escapes ($text, $flags, [more flags...])

=for html 

This method applies a one or more escapes to a piece of text.  The
escapes are specified by giving their flag.  Each escape is applied to
the text in turn, after which the now-modified text is returned.

=item remove_escape ($name)

=for html 

Given an escape name, this removes that escape from the interpreter's
known escapes.  If the name is not recognized, it is simply ignored.

=item set_escape ($name => see below])

=for html 

This method is called to add an escape flag to the list of known
escapes for the interpreter.  The flag may only consist of the
characters matching C<\w> and the dash (-).  It must start with an
alpha character or an underscore (_).

The right hand side may be one of several things.  It can be a
subroutine reference.  It can also be a string match C, in
which case it is assumed to be the name of a subroutine in the
C module.  Finally, if it is a string that does
not match the above regex, then it is assumed to be Cable code,
which will return a subroutine reference.

When setting these with C directives in an Apache
configuration file, you can set them like this:

  PerlSetVar  MasonEscapeFlags  "h => \&HTML::Mason::Escapes::basic_html_escape"
  PerlSetVar  MasonEscapeFlags  "flag  => \&subroutine"
  PerlSetVar  MasonEscapeFlags  "uc    => sub { ${$_[0]} = uc ${$_[0]}; }"
  PerlAddVar  MasonEscapeFlags  "thing => other_thing"

=back

=head1 OTHER METHODS

=over

=item comp_exists (path)

=for html 

Given an I component path, this method returns a boolean
value indicating whether or not a component exists for that path.

=item exec (comp, args...)

=for html 

Creates a new HTML::Mason::Request object for the given I and
I, and executes it. The return value is the return value of
I, if any.

This is useful for running Mason outside of a web environment.
See L
for examples.

This method isn't generally useful in a mod_perl environment; see
L instead.

=item flush_code_cache

=for html 

Empties the component cache. When using Perl 5.00503 or earlier, you
should call this when finished with an interpreter, in order to remove
circular references that would prevent the interpreter from being
destroyed.

=item load (path)

=for html 

Returns the component object corresponding to an absolute component
C, or undef if none exists. Dies with an error if the component
fails to load because of a syntax error.

=item make_component (comp_source => ... )

=item make_component (comp_file => ... )

=for html 

This method compiles Mason component source code and returns a
Component object.  The source may be passed in as a string in C,
or as a filename in C.  When using C, the
filename is specified as a path on the file system, not as a path
relative to Mason's component root (see 
L<$m-Efetch_comp|HTML::Mason::Request/item_fetch_comp> for that).

If Mason encounters an error during processing, an exception will be thrown.

Example of usage:

    # Make an anonymous component
    my $anon_comp =
      eval { $interp->make_component
               ( comp_source => '<%perl>my $name = "World";Hello <% $name %>!' ) };
    die $@ if $@;

    $m->comp($anon_comp);

=item make_request (@request_params)

=for html 

This method creates a Mason request object. The arguments to be passed
are the same as those for the C<< HTML::Mason::Request->new >>
constructor or its relevant subclass. This method will likely only be
of interest to those attempting to write new handlers or to subclass
C.  If you want to create a I, see
L instead.

=item purge_code_cache ()

=for html 

Called during request execution in order to clear out the code
cache. Mainly useful to subclasses that may want to take some custom
action upon clearing the cache.

=item set_global ($varname, [values...])

=for html 

This method sets a global to be used in components. C is a
variable name, optionally preceded with a prefix (C<$>, C<@>, or
C<%>); if the prefix is omitted then C<$> is assumed. C is
followed by a value, in the case of a scalar, or by one or more values
in the case of a list or hash.  For example:

    # Set a global variable $dbh containing the database handle
    $interp->set_global(dbh => DBI->connect(...));

    # Set a global hash %session from a local hash
    $interp->set_global('%session', %s);

The global is set in the package that components run in: usually
C, although this can be overridden via the
L parameter.
The lines above, for example, are equivalent to:

    $HTML::Mason::Commands::dbh = DBI->connect(...);
    %HTML::Mason::Commands::session = %s;

assuming that L has not been changed.

Any global that you set should also be registered with the
L parameter; otherwise you'll get warnings from
C.

=back

=cut
HTML-Mason-1.59/lib/HTML/Mason/Exceptions.pm0000644000175000017500000004036113660015140020175 0ustar  autarchautarchpackage HTML::Mason::Exceptions;
$HTML::Mason::Exceptions::VERSION = '1.59';
use strict;
use warnings;

my %e;

BEGIN
{
    %e = ( 'HTML::Mason::Exception' =>
           { description => 'generic base class for all Mason exceptions',
             alias => 'error'},

           'HTML::Mason::Exception::Abort' =>
           { isa => 'HTML::Mason::Exception',
             fields => [qw(aborted_value)],
             description => 'a component called $m->abort' },

           'HTML::Mason::Exception::Decline' =>
           { isa => 'HTML::Mason::Exception',
             fields => [qw(declined_value)],
             description => 'a component called $m->decline' },

           'HTML::Mason::Exception::Compiler' =>
           { isa => 'HTML::Mason::Exception',
             alias => 'compiler_error',
             description => 'error thrown from the compiler' },

           'HTML::Mason::Exception::Compilation' =>
           { isa => 'HTML::Mason::Exception',
             alias => 'compilation_error',
             fields => [qw(filename)],
             description => "error thrown in eval of the code for a component" },

           'HTML::Mason::Exception::Compilation::IncompatibleCompiler' =>
           { isa => 'HTML::Mason::Exception::Compilation',
             alias => 'wrong_compiler_error',
             description => "a component was compiled by a compiler/lexer with incompatible options.  recompilation is needed" },

           'HTML::Mason::Exception::Params' =>
           { isa => 'HTML::Mason::Exception',
             alias => 'param_error',
             description => 'invalid parameters were given to a method/function' },

           'HTML::Mason::Exception::Syntax' =>
           { isa => 'HTML::Mason::Exception',
             alias => 'syntax_error',
             fields => [qw(source_line comp_name line_number)],
             description => 'invalid syntax was found in a component' },

           'HTML::Mason::Exception::System' =>
           { isa => 'HTML::Mason::Exception',
             alias => 'system_error',
             description => 'a system call of some sort failed' },

           'HTML::Mason::Exception::TopLevelNotFound' =>
           { isa => 'HTML::Mason::Exception',
             alias => 'top_level_not_found_error',
             description => 'the top level component could not be found' },

           'HTML::Mason::Exception::VirtualMethod' =>
           { isa => 'HTML::Mason::Exception',
             alias => 'virtual_error',
             description => 'a virtual method was not overridden' },

         );
}

use Exception::Class (%e);

HTML::Mason::Exception->Trace(1);

# To avoid circular reference between exception and request.
HTML::Mason::Exception->NoRefs(1);

# The import() method allows this:
#  use HTML::Mason::Exceptions(abbr => ['error1', 'error2', ...]);
# ...
#  error1 "something went wrong";

sub import
{
    my ($class, %args) = @_;

    my $caller = caller;
    if ($args{abbr})
    {
        foreach my $name (@{$args{abbr}})
        {
            no strict 'refs';
            die "Unknown exception abbreviation '$name'" unless defined &{$name};
            *{"${caller}::$name"} = \&{$name};
        }
    }
    {
        no strict 'refs';
        *{"${caller}::isa_mason_exception"} = \&isa_mason_exception;
        *{"${caller}::rethrow_exception"} = \&rethrow_exception;
    }
}

sub isa_mason_exception
{
    my ($err, $name) = @_;
    return unless defined $err;

    $name = $name ? "HTML::Mason::Exception::$name" : "HTML::Mason::Exception";
    no strict 'refs';
    die "no such exception class $name" unless $name->isa('HTML::Mason::Exception');

    return UNIVERSAL::isa($err, $name);
}

sub rethrow_exception
{
    my ($err) = @_;
    return unless $err;

    if ( UNIVERSAL::can($err, 'rethrow') ) {
        $err->rethrow;
    }
    elsif ( ref $err ) {
        die $err;
    }
    HTML::Mason::Exception->throw(error => $err);
}

package HTML::Mason::Exception;
$HTML::Mason::Exception::VERSION = '1.59';
use HTML::Mason::MethodMaker
    ( read_write => [ qw ( format ) ] );

sub new
{
    my ($class, %params) = @_;

    my $self = $class->SUPER::new(%params);
    $self->format('text');
    return $self;
}

# If we create a new exception from a Mason exception, just use the
# short error message, not the stringified exception. Otherwise
# exceptions can get stringified more than once.
sub throw
{
    my $class = shift;
    my %params = @_ == 1 ? ( error => $_[0] ) : @_;

    if (HTML::Mason::Exceptions::isa_mason_exception($params{error})) {
        $params{error} = $params{error}->error;
    }
    if (HTML::Mason::Exceptions::isa_mason_exception($params{message})) {
        $params{message} = $params{message}->error;
    }
    $class->SUPER::throw(%params);
}

sub filtered_frames
{
    my ($self) = @_;

    my (@frames);
    my $trace = $self->trace;
    my %ignore_subs = map { $_ => 1 }
        qw[
           (eval)
           Exception::Class::Base::throw
           Exception::Class::__ANON__
           HTML::Mason::Commands::__ANON__
           HTML::Mason::Component::run
           HTML::Mason::Exception::throw
           HTML::Mason::Exceptions::__ANON__
           HTML::Mason::Request::_run_comp
           ];
    while (my $frame = $trace->next_frame)
    {
        last if ($frame->subroutine eq 'HTML::Mason::Request::exec');
        unless ($frame->filename =~ /Mason\/Exceptions\.pm/ or
                $ignore_subs{ $frame->subroutine } or
                ($frame->subroutine eq 'HTML::Mason::Request::comp' and $frame->filename =~ /Request\.pm/)) {
            push(@frames, $frame);
        }
    }
    @frames = grep { $_->filename !~ /Mason\/Exceptions\.pm/ } $trace->frames if !@frames;
    return @frames;
}

sub analyze_error
{
    my ($self) = @_;
    my ($file, @lines, @frames);

    return $self->{_info} if $self->{_info};

    @frames = $self->filtered_frames;
    if ($self->isa('HTML::Mason::Exception::Syntax')) {
        $file = $self->comp_name;
        push(@lines, $self->line_number);
    } elsif ($self->isa('HTML::Mason::Exception::Compilation')) {
        $file = $self->filename;
        my $msg = $self->full_message;
        while ($msg =~ /at .* line (\d+)./g) {
            push(@lines, $1);
        }
    } elsif (@frames) {
        $file = $frames[0]->filename;
        @lines = $frames[0]->line;
    }
    my @context;
    @context = $self->get_file_context($file, \@lines) if @lines;

    $self->{_info} = {
        file    => $file,
        frames  => \@frames,
        lines   => \@lines,
        context => \@context,
    };
    return $self->{_info};
}

sub get_file_context
{
    my ($self, $file, $line_nums) = @_;

    my @context;
    my $fh = do { local *FH; *FH; };
    unless (defined($file) and open($fh, $file)) {
        @context = (['unable to open file', '']);
    } else {
        # Put the file into a list, indexed at 1.
        my @file = <$fh>;
        chomp(@file);
        unshift(@file, undef);

        # Mark the important context lines.
        # We do this by going through the error lines and incrementing hash keys to
        # keep track of which lines we eventually need to print, and we color the
        # line which the error actually occured on in red.
        my (%marks, %red);
        my $delta = 4;
        foreach my $line_num (@$line_nums) {
            foreach my $l (($line_num - $delta) .. ($line_num + $delta)) {
                next if ($l <= 0 or $l > @file);
                $marks{$l}++;
            }
            $red{$line_num} = 1;
        }

        # Create the context list.
        # By going through the keys of the %marks hash, we can tell which lines need
        # to be printed. We add a '...' line if we skip numbers in the context.
        my $last_num = 0;
        foreach my $line_num (sort { $a <=> $b } keys %marks) {
            push(@context, ["...", "", 0]) unless $last_num == ($line_num - 1);
            push(@context, ["$line_num:", $file[$line_num], $red{$line_num}]);;
            $last_num = $line_num;
        }
        push(@context, ["...", "", 0]) unless $last_num == @file;
        close $fh;
    }
    return @context;
}

# basically the same as as_string in Exception::Class::Base
sub raw_text
{
    my ($self) = @_;

    return $self->full_message . "\n\n" . $self->trace->as_string;
}

sub as_string
{
    my ($self) = @_;

    my $stringify_function = "as_" . $self->{format};
    return $self->$stringify_function();
}

sub as_brief
{
    my ($self) = @_;
    return $self->full_message;
}

sub as_line
{
    my ($self) = @_;
    my $info = $self->analyze_error;

    (my $msg = $self->full_message) =~ s/\n/\t/g;
    my $stack = join(", ", map { sprintf("[%s:%d]", $_->filename, $_->line) } @{$info->{frames}});
    return sprintf("%s\tStack: %s\n", $msg, $stack);
}

sub as_text
{
    my ($self) = @_;
    my $info = $self->analyze_error;

    my $msg = $self->full_message;
    my $stack = join("\n", map { sprintf("  [%s:%d]", $_->filename, $_->line) } @{$info->{frames}});
    return sprintf("%s\nStack:\n%s\n", $msg, $stack);
}

sub as_html
{
    my ($self) = @_;

    my $out;
    my $interp = HTML::Mason::Interp->new(out_method => \$out);

    my $comp = $interp->make_component(comp_source => <<'EOF');

<%args>
 $msg
 $info
 $error

<%filter>
 s/(]+>)/$1/g;
 s/<\/td>/<\/font><\/td>/g;


% HTML::Mason::Escapes::basic_html_escape(\$msg);
% $msg =~ s/\n/
/g;




System error



 

  error: 
  <% $msg %>
 

 

  context: 
  
   

%   foreach my $entry (@{$info->{context}}) {
%       my ($line_num, $line, $highlight) = @$entry;
%       $line = '' unless defined $line;
%       HTML::Mason::Escapes::basic_html_escape(\$line);
    

%    }

   

     <% $line_num %> 
     <% $highlight ? "" : "" %><% $line %><% $highlight ? "" : "" %>
    

  		
 

 

  code stack: 
  
%    foreach my $frame (@{$info->{frames}}) {
%        my $f = $frame->filename; HTML::Mason::Escapes::basic_html_escape(\$f);
%        my $l = $frame->line; HTML::Mason::Escapes::basic_html_escape(\$l);
        <% $f %>:<% $l %>

%    }
  		
 




raw error































































% my $raw = $error->raw_text;
% HTML::Mason::Escapes::basic_html_escape(\$raw);
% $raw =~ s/\t//g;




<% $raw %>



EOF

    $interp->exec($comp,
                  msg => $self->full_message,
                  info => $self->analyze_error,
                  error => $self);

    return $out;
}

package HTML::Mason::Exception::Compilation;
$HTML::Mason::Exception::Compilation::VERSION = '1.59';
sub full_message
{
    my $self = shift;

    return sprintf("Error during compilation of %s:\n%s\n", $self->filename || '', $self->message || '');
}

package HTML::Mason::Exception::Syntax;
$HTML::Mason::Exception::Syntax::VERSION = '1.59';
sub full_message
{
    my $self = shift;

    return sprintf("%s at %s line %d", $self->message || '', $self->comp_name || '', $self->line_number);
}

1;

__END__

=head1 NAME

HTML::Mason::Exceptions - Exception objects thrown by Mason

=head1 SYNOPSIS

  use HTML::Mason::Exceptions ( abbr => [ qw(system_error) ] );

  open FH, 'foo' or system_error "cannot open foo: $!";

=head1 DESCRIPTION

This module creates the hierarchy of exception objects used by Mason,
and provides some extra methods for them beyond those provided by
C

=head1 IMPORT

When this module is imported, it is possible to specify a list of
abbreviated function names that you want to use to throw exceptions.
In the L example, we use the C
function to throw a C exception.

These abbreviated functions do not allow you to set additional fields
in the exception, only the message.

=head1 EXCEPTIONS

=over

=item HTML::Mason::Exception

This is the parent class for all exceptions thrown by Mason.  Mason
sometimes throws exceptions in this class when we could not find a
better category for the message.

Abbreviated as C

=item HTML::Mason::Exception::Abort

The C<< $m->abort >> method was called.

Exceptions in this class contain the field C.

=item HTML::Mason::Exception::Decline

The C<< $m->decline >> method was called.

Exceptions in this class contain the field C.

=item HTML::Mason::Exception::Compilation

An exception occurred when attempting to C an existing object
file.

Exceptions in this class have the field C, which indicates
what file contained the code that caused the error.

Abbreviated as C.

=item HTML::Mason::Exception::Compiler

The compiler threw an exception because it received incorrect input.
For example, this would be thrown if the lexer told the compiler to
initialize compilation while it was in the middle of compiling another
component.

Abbreviated as C.

=item HTML::Mason::Exception::Compilation::IncompatibleCompiler

A component was compiled by a compiler or lexer with incompatible
options.  This is used to tell Mason to recompile a component.

Abbreviated as C.

=item HTML::Mason::Exception::Params

Invalid parameters were passed to a method or function.

Abbreviated as C.

=item HTML::Mason::Exception::Syntax

This exception indicates that a component contained invalid syntax.

Exceptions in this class have the fields C, which is the
actual source where the error was found, C, and
C.

Abbreviated as C.

=item HTML::Mason::Exception::System

A system call of some sort, such as a file open, failed.

Abbreviated as C.

=item HTML::Mason::Exception::TopLevelNotFound

The requested top level component could not be found.

Abbreviated as C.

=item HTML::Mason::VirtualMethod

Some piece of code attempted to call a virtual method which was not
overridden.

Abbreviated as C

=back

=head1 FIELDS

Some of the exceptions mentioned above have additional fields, which
are available via accessors.  For example, to get the line number of
an C exception, you call the
C method on the exception object.

=head1 EXCEPTION METHODS

All of the Mason exceptions implement the following methods:

=over

=item as_brief

This simply returns the exception message, without any trace information.

=item as_line

This returns the exception message and its trace information, all on a
single line with tabs between the message and each frame of the stack
trace.

=item as_text

This returns the exception message and stack information, with each
frame on a separate line.

=item as_html

This returns the exception message and stack as an HTML page.

=back

Each of these methods corresponds to a valid error_format parameter
for the L such as C or
C.

You can create your own method in the C
namespace, such as C, in which case you could set this
parameter to "you_wish".  This method will receive a single argument,
the exception object, and is expected to return some sort of string
containing the formatted error message.

=head1 EXCEPTION CLASS CHECKING

This module also exports the C function.  This
function takes the exception object and an optional string parameter
indicating what subclass to check for.

So it can be called either as:

  if ( isa_mason_exception($@) ) { ... }

or

  if ( isa_mason_exception($@, 'Syntax') ) { ... }

Note that when specifying a subclass you should not include the
leading "HTML::Mason::Exception::" portion of the class name.

=cut
HTML-Mason-1.59/lib/HTML/Mason/Tests.pm0000644000175000017500000006033713660015140017163 0ustar  autarchautarchpackage HTML::Mason::Tests;
$HTML::Mason::Tests::VERSION = '1.59';
use strict;
use warnings;

use Cwd;

use File::Path;
use File::Spec;

use HTML::Mason;
use HTML::Mason::Compiler::ToObject;

use Getopt::Long;

use Test::Builder ();

use vars qw($VERBOSE $DEBUG @SHARED);

my $Test = Test::Builder->new;

$VERBOSE = $ENV{MASON_DEBUG} || $ENV{MASON_VERBOSE} || $ENV{TEST_VERBOSE};
$DEBUG = $ENV{MASON_DEBUG};

$| = 1;

@SHARED = ( { path => '/shared/check_error',
              component => <<'EOF',
<% ($error) ? "Error: $error" : "No error!?" %>
<%init>
if ($error) {
  my @lines = split("\n",$error);
  $error = join("\n",@lines[0..$lines-1]);
  $error =~ s{\s+at .*}{}g;
}

<%args>
$error
$lines=>1

EOF
            },
            { path => '/shared/display_comp_obj',
              component => <<'EOF',
Declared args:
% my %decl = %{$comp->declared_args};
% foreach (sort keys %decl) {
<% $_ %><% (defined($decl{$_}->{default})) ? "=>".$decl{$_}->{default} : "" %>
% }

I am <% $comp->is_subcomp ? '' : 'not ' %>a subcomponent.
I am <% $comp->is_method ? '' : 'not ' %>a method.
I am <% $comp->is_file_based ? '' : 'not ' %>file-based.
% if (defined($comp->name)) {
My short name is <% $comp->name =~ /anon/ ? '[anon something]' : $comp->name %>.
% }
% if ($comp->is_subcomp and defined($comp->owner)) {
My parent component is <% $comp->owner->title %>.
% }
% if (defined($comp->dir_path)) {
My directory is <% $comp->dir_path %>.
% }
% my @subkeys = sort keys(%{$comp->subcomps});
I have <% scalar(@subkeys) %> subcomponent(s).
% if (@subkeys) {
Including one called <% $comp->subcomps($subkeys[0])->name %>.
% }
My title is <% $comp->title =~ /anon/ ? '[anon something]' : $comp->title %>.

% if (defined($comp->path)) {
My path is <% $comp->path %>.
% }
% if (defined($comp->comp_id)) {
My comp_id is <% $comp->comp_id =~ /anon/ ? '[anon something]' : $comp->comp_id %>.
% }
<%args>
$comp

EOF
            },
            { path => '/shared/display_req_obj',
              component => <<'EOF',
My depth is <% $m->depth %>.

I <% $m->is_subrequest ? 'am' : 'am not' %> a subrequest.

The top-level component is <% $m->request_comp->title %>.

My stack looks like:
-----
% foreach my $comp ($m->callers) {
<% $comp->title %>
% }
-----

EOF
            },
          );

#
# Get command options here so that we read tests_class before user
# calls new().
#
my %cmd_options;
GetOptions( 'create' => \$cmd_options{create},
            'tests-to-run=s' => \$cmd_options{tests_to_run},
            'tests-to-skip=s' => \$cmd_options{tests_to_skip},
            'tests-class=s' => \$cmd_options{tests_class},
            );

#
# Allow options to be passed in the environment as well.
#
$cmd_options{tests_to_run} = $ENV{MASON_TESTS_TO_RUN}
    if !defined($cmd_options{tests_to_run}) and defined($ENV{MASON_TESTS_TO_RUN});
$cmd_options{tests_to_skip} = $ENV{MASON_TESTS_TO_SKIP}
    if !defined($cmd_options{tests_to_skip}) and defined($ENV{MASON_TESTS_TO_SKIP});
$cmd_options{tests_class} = $ENV{MASON_TESTS_CLASS}
    if !defined($cmd_options{tests_class}) and defined($ENV{MASON_TESTS_CLASS});

# If user specifies tests_class, load that package; otherwise,
# default it to this package.
if (defined($cmd_options{tests_class})) {
    eval "use $cmd_options{tests_class}";
    die $@ if $@;
} else {
    $cmd_options{tests_class} = __PACKAGE__;
}

my %tests_to_run;
if ($cmd_options{tests_to_run}) {
    for ($cmd_options{tests_to_run}) { s/^\s+//; s/\s+$// }
    my @tests_to_run = split(/\s*,\s*/, $cmd_options{tests_to_run});
    if (grep { /[^0-9]/ } @tests_to_run) {
        @tests_to_run = sort { $a cmp $b } @tests_to_run;
    } else {
        @tests_to_run = sort { $a <=> $b } @tests_to_run;
    }
    %tests_to_run = map { ($_, 1) } @tests_to_run;
    $Test->diag(sprintf("Running only test%s %s\n", @tests_to_run == 1 ? "" : "s", join(", ", @tests_to_run)))
}

my %tests_to_skip;
if ($cmd_options{tests_to_skip}) {
    for ($cmd_options{tests_to_skip}) { s/^\s+//; s/\s+$// }
    my @tests_to_skip = split(/\s*,\s*/, $cmd_options{tests_to_skip});
    %tests_to_skip = map { ($_, 1) } @tests_to_skip;
    $Test->diag(printf ("Skipping test%s %s\n", @tests_to_skip == 1 ? "" : "s", join(", ", @tests_to_skip)));
}

sub new
{
    my $class = shift;
    my %p = (@_, %cmd_options);

    die "No group name provided\n"
        unless exists $p{name};

    die "No description for test group provided\n"
        unless exists $p{description};

    $p{pre_test_cleanup} = 1
        unless exists $p{pre_test_cleanup};

    return bless {
                  %p,
                  support => [],
                  tests => [],
                 }, $class;
}

# Returns the tests class to use for class methods - defaults to this package.
sub tests_class
{
    return $cmd_options{tests_class};
}

sub add_support
{
    my $self = shift;
    my %p = @_;

    die "'support' key array member contains no 'path' key\n"
        unless exists $p{path};

    die "'support' key array member contains no 'component' key\n"
        unless exists $p{component};

    push @{ $self->{support} }, \%p;
}

sub add_test
{
    my $self = shift;
    my %p = @_;

    die "no name provided for test\n"
        unless exists $p{name};

    unless ( exists $p{path} )
    {
        $p{path} = $p{call_path} || $p{name};
    }

    my $call_path = "/$self->{name}";
    if ( exists $p{call_path} )
    {
        $call_path .= '/' unless substr( $p{call_path}, 0, 1 ) eq '/';
        $call_path .= $p{call_path};
    }
    else
    {
        $call_path .= '/' . $p{name};
    }
    $p{call_path} = $call_path;

    if ( ref($p{call_args}) eq 'HASH' )
    {
        my @lst = %{$p{call_args}};
        $p{call_args} = \@lst;
    }
    elsif ( !exists($p{call_args}) ) {
        $p{call_args} = [];
    }

    die "'$p{name}' test has no description\n"
        unless exists $p{description};

    die "'$p{name}' test has no component\n"
        unless exists $p{component} || $p{skip_component};

    die "'$p{name}' test has no 'expect' or 'expect_error' key\n"
        unless exists $p{expect} || exists $p{expect_error} || $p{skip_expect} || $self->{create};

    foreach ( qw( interp_params ) )
    {
        die "$_ must be a hash reference"
            if exists $p{$_} && ! UNIVERSAL::isa( $p{$_}, 'HASH' );
    }

    push @{ $self->{tests} }, \%p;
}

sub run
{
    my $self = shift;

    die "No tests exist in this group"
        unless @{ $self->{tests} };

    if ($DEBUG)
    {
        $Test->diag( "Will " . ( $self->{create} ? '' : 'not ' ) . "create 'expect' files\n" );
    }

    eval
    {
        # 1 indicates to be silent on missing directories
        $self->_cleanup(1) if $self->{pre_test_cleanup};
        $self->_make_dirs;
        $self->_write_shared_comps;
        $self->_write_support_comps;
        $self->_run_tests;
    };

    $self->_cleanup unless $ENV{MASON_NO_CLEANUP};

    die $@ if $@;
}

sub _make_dirs
{
    my $self = shift;

    my $comp_root = $self->comp_root;
    my $data_dir = $self->data_dir;

    unless ( -d $self->comp_root )
    {
        $Test->diag( "Making comp_root directory: $comp_root\n" ) if $DEBUG;
        mkpath( $self->comp_root, 0, 0755 )
            or die "Unable to make base test directory '$comp_root': $!";
    }

    unless ( -d $self->data_dir )
    {
        $Test->diag( "Making data_dir directory: $data_dir\n" ) if $DEBUG;
        mkpath( $self->data_dir, 0, 0755 )
            or die "Unable to make base test directory '$data_dir': $!";
    }
}

sub base_path
{
    my $proto = shift;

    if (ref $proto)
    {
        $proto->{base_path} ||= File::Spec->catdir( cwd(), 'mason_tests', $$ );
        return $proto->{base_path};
    }
    else
    {
        return File::Spec->catdir( cwd(), 'mason_tests', $$ );
    }
}

sub comp_root
{
    my $proto = shift;

    return File::Spec->catdir( $proto->base_path, 'comps' );
}

sub data_dir
{
    my $proto = shift;

    return File::Spec->catdir( $proto->base_path, 'data' );
}

sub _write_shared_comps
{
    my $self = shift;

    return unless @SHARED;

    foreach my $comp ( @SHARED )
    {
        my @path = split m(/), $comp->{path};
        my $file = pop @path;

        my $dir = File::Spec->catdir( $self->comp_root, @path );

        $self->write_comp( $comp->{path}, $dir, $file, $comp->{component} );
    }
}

sub _write_support_comps
{
    my $self = shift;

    unless ( @{ $self->{support} } )
    {
        $Test->diag( "No support comps to create\n" ) if $DEBUG;
        return;
    }

    foreach my $supp ( @{ $self->{support} } )
    {
        my @path = split m(/), $supp->{path};
        my $file = pop @path;

        my $dir = File::Spec->catdir( $self->comp_root, $self->{name}, @path );

        $self->write_comp( $supp->{path}, $dir, $file, $supp->{component} );
    }
}

sub _write_test_comp
{
    my $self = shift;
    my $test = $self->{current_test};

    my @path = split m(/), $test->{path};
    my $file = pop @path;

    my $dir = File::Spec->catdir( $self->comp_root, $self->{name}, @path );
    unless ( -d $dir )
    {
        $Test->diag( "Making dir: $dir\n" ) if $DEBUG;
        mkpath( $dir, 0, 0755 )
            or die "Unable to create directory '$dir': $!";
    }

    $self->write_comp( $test->{path}, $dir, $file, $test->{component} );
}

sub write_comp
{
    my $self = shift;
    my ($path, $dir, $file, $component) = @_;

    unless (-d $dir)
    {
        $Test->diag( "Making dir: $dir\n" ) if $DEBUG;
        mkpath( $dir, 0, 0755 )
            or die "Unable to create directory '$dir': $!";
    }

    my $real_file = File::Spec->catfile( $dir, $file );

    $Test->diag( "Making component $path at $real_file\n" )
        if $DEBUG;

    open my $fh, ">$real_file"
        or die "Unable to write to '$real_file': $!";
    print $fh $component
        or die "Unable to write to '$real_file': $!";
    close $fh
        or die "Unable to write to '$real_file': $!";
}

sub _run_tests
{
    my $self = shift;

    my $count = scalar @{ $self->{tests} };
    $Test->plan( tests => $count );

    if ($VERBOSE)
    {
        $Test->diag( "Running $self->{name} tests ($count tests): $self->{description}\n" );
    }

    my $x = 1;
    foreach my $test ( @{ $self->{tests} } )
    {
        $self->{current_test} = $test;

        #
        # If tests_to_run or tests_to_skip were specified in the
        # environment or command line, check them to see whether to
        # run the test.
        #
        if (%tests_to_run or %tests_to_skip) {

            # Look for any of the specs [test_file_name:](test_number|test_name|*)
            my $wildcard_name = join(":", $self->{name}, "*");
            my $full_name = join(":", $self->{name}, $test->{name});
            my $full_number = join(":", $self->{name}, $x);
            my @all_specs = ($x, $test->{name}, $full_name, $full_number, $wildcard_name);

            # If our test isn't mentioned in %tests_to_run or is
            # mentioned in %tests_to_skip, skip it.
            #
            if ((%tests_to_run and !(grep { $tests_to_run{$_} } @all_specs))
                or (%tests_to_skip and (grep { $tests_to_skip{$_} } @all_specs))) {

                # Use presence of PERL_DL_NONLAZY to decide if we are
                # running inside "make test", and if so, actually
                # print the appropriate skip response to comply with the
                # Test::Harness standard. If the user is running the
                # test by hand, this would just be clutter.
                #
                # Checking PERL_DL_NONLAZY is a hack but I don't
                # know of a better detection method.
                #
                $self->_skip if ($ENV{PERL_DL_NONLAZY});
                $x++;
                next;
            }
        }
        $Test->diag( "Running $test->{name} (#$x): $test->{description}\n" ) if $VERBOSE;
        $self->_make_component unless $test->{skip_component};
        $self->_run_test;
        $x++;
    }
}

sub _make_component
{
    my $self = shift;
    my $test = $self->{current_test};
    $self->_write_test_comp;
}

sub _make_main_interp
{
    my $self = shift;
    my $test = $self->{current_test};
    return $test->{interp} if $test->{interp};

    my %interp_params = ( exists $test->{interp_params} ?
                          %{ $test->{interp_params} } :
                          () );

    if ($DEBUG && %interp_params)
    {
        $Test->diag( "Interp params:\n" );
        while ( my ($k, $v) = each %interp_params)
        {
            $Test->diag( "  $k => $v\n" );
        }
    }

    return $self->_make_interp ( comp_root => $self->comp_root,
                                 data_dir  => $self->data_dir,
                                 %interp_params );
}

sub _make_interp
{
    my ($class, %interp_params) = @_;

    return HTML::Mason::Interp->new( %interp_params );
}

sub _run_test
{
    my $self = shift;
    my $test = $self->{current_test};

    $self->{buffer} = '';
    my $interp = $self->_make_main_interp;
    $interp->out_method( sub { for (@_) { $self->{buffer} .= $_ if defined $_ } } );

    my $warnings = '';
    local $SIG{__WARN__} = sub { $warnings .= $_ for @_ };
    eval {
        # Run pre_code if test has it - pass in interp
        if ($test->{pre_code}) {
            $test->{pre_code}->($interp);
        }
        $self->_execute($interp);
    };

    return $self->check_result($@, $warnings);
}

sub _execute
{
    my ($self, $interp) = @_;
    my $test = $self->{current_test};

    $Test->diag( "Calling $test->{name} test with path: $test->{call_path}\n" ) if $DEBUG;
    $test->{pretest_code}->() if $test->{pretest_code};
    $interp->exec( $test->{call_path}, @{$test->{call_args}} );
}

sub check_result {
    my ($self, $error, $warnings) = @_;
    my $test = $self->{current_test};

    local $HTML::Mason::Tests::TODO = $self->{current_test}{todo}
        if exists $self->{current_test}{todo};
    $Test->todo if exists $self->{current_test}{todo};

    if ($error)
    {
        if ( $test->{expect_error} )
        {
            if ( $error =~ /$test->{expect_error}/ )
            {
                return $self->_success
            }
            else
            {
                if ($VERBOSE)
                {
                    $Test->diag( "Got error:\n$error\n...but expected something matching:\n$test->{expect_error}\n" );
                }
                return $self->_fail;
            }
        }
        else
        {
            $Test->diag( "Unexpected error running $test->{name}:\n$error" ) if $VERBOSE;
            return $self->_fail;
        }

    }
    elsif ( $test->{expect_error} )
    {
        $Test->diag( "Expected an error matching '$test->{expect_error}' but no error occurred - got successful output:\n$self->{buffer}\n" ) if $VERBOSE;
        return $self->_fail;
    }

    if ($self->{create})
    {
        $Test->diag( "Results for $test->{name}:\n$self->{buffer}\n" );
        return;
    }

    my $success =
        ( $test->{skip_expect} ?
          1 :
          $self->check_output( actual => $self->{buffer}, expect => $test->{expect} )
        );

    if ( $test->{expect_warnings} )
    {
        unless ( $warnings =~ /$test->{expect_warnings}/ )
        {
            $Test->diag( "Got warnings:\n$warnings\n...but expected something matching:\n$test->{expect_warnings}\n" );
            $success = 0;
        }
    }

    $Test->diag( "Got warnings: $warnings" ) if $warnings && ( ! $test->{expect_warnings} || $VERBOSE );
    $success = 0 if $test->{no_warnings} && $warnings;

    $success ? $self->_success : $self->_fail;
}

sub check_output
{
    my ($self, %p) = @_;

    my $same;

    # Allow a regex for $p{expect}
    if (ref $p{expect}) {
        $same = ($p{actual} =~ /$p{expect}/);

    } else {
        # Whitespace at end can vary.  (Or rather, it is varying in the tests, and
        # should be made not to vary, but I don't have time to fix it yet.)

        for ($p{actual}, $p{expect}) {  s/\s+$//  }
        $same = ($p{actual} eq $p{expect});
    }

    if (!$same and $VERBOSE) {
        $Test->diag( "Got ...\n-----\n$p{actual}\n-----\n   ... but expected ...\n-----\n$p{expect}\n-----\n" );
    }
    return $same;
}

sub _fail
{
    my $self = shift;
    my $test = $self->{current_test};

    $Test->ok( 0, $test->{name} );
}

sub _success
{
    my $self = shift;
    my $test = $self->{current_test};

    $Test->ok( 1, $test->{name} );
}

sub _skip
{
    my $self = shift;
    my $test = $self->{current_test};

    $Test->skip;
}

#
# We use our own rm_tree, rather than File::Path::rmtree, so that we
# can silently fail to entirely remove directories. On some systems
# .nfs files prevent total removal of directories but should not
# otherwise interfere with tests.
#
sub rm_tree {
    my ($path, $debug, $silent) = @_;
    $path =~ s#/$##;
    if (-d $path) {
        local *DIR;
        opendir DIR, $path or warn "Can't open $path: $!";
        while (defined(my $file = readdir DIR)) {
            next if $file eq '.' or $file eq '..';
            rm_tree("$path/$file");
        }
        closedir DIR;
        rmdir $path;
    } elsif (-f $path) {
        unlink $path;
    } else {
        $Test->diag( "Can't find $path to remove" )
            unless $silent;
    }
}

sub _cleanup
{
    my $self = shift;

    rm_tree( $self->base_path, $DEBUG, @_ );
}

1;

__END__

=head1 NAME

HTML::Mason::Tests - Test harness for testing Mason

=head1 SYNOPSIS

 use HTML::Mason::Tests;

 my $group = HTML::Mason::Tests->new( name => 'name of group', description => 'tests something' );
 $group->add_test( name => 'foo',
                   description => 'tests foo',
                   component => <<'EOF'
 <%args>
 $foo => 1
 
 <% $foo %>
 EOF
                   expect => <<'EOF',
 1
 EOF
                 );

 $group->run;

=head1 DESCRIPTION

This module is designed to automate as much as possible of the Mason
test suite.  It does tasks like write component files to disk, call
them, compare the actual results to the expected results, and more.
In addition, it also is capable of printing out useful information
about test failures when run in verbose mode.  See the ADDITIONAL RUN
MODES section for more information.

It also makes sure that any given group of tests provides all the
information needed to run them (test names, components and results,
etc.).

Now you have no excuse for writing new tests (and that goes double for
me!).

=head1 METHODS

=head2 new

Takes the following parameters:

=over 4

=item * name (required)

The name of the entire group of tests.

=item * description (required)

What this group tests.

=item * pre_test_cleanup (optional, default=1)

If this is true (the default), the component root and data directory
will be deleted both before and after running tests.

=back

=head2 add_support

Takes the following parameters:

=over 4

=item * path (required)

The path that other components will expect this component to be
reachable at.  All paths are prepended with the group name.  So '/bar'
as a support component in the 'foo' group's ultimate path would be
'/foo/bar'.

=item * component

Text of the support component.  This parameter must have a value
unless the skip_component parameter is true.

=item * skip_component

If true, then the test harness will not write a component to disk for
this test.

=back

=head2 add_test

Takes the following parameters:

=over 4

=item * name (required)

The name of this test.

=item * description (required)

What this test is testing.

=item * component (required)

Text of the component.

=item * path (optional)

The path that this component should written to.  As with support
components, this path is prepended with the group's name.  If no path
is given, it uses call_path, if given, otherwise it uses the name
parameter.

=item * call_path (optional)

The path that should be used to call the component.  If none is given,
it will be //.  If a value is given, it is
still prepended by //.

=item * call_args (optional)

The arguments that should be passed to the component, in list or hash
reference form. If none is given, no arguments are passed.

=item * compiler_params

This is a hash reference of parameters to be passed to the Compiler->new
method.

=item * interp_params

This is a hash reference of parameters to be passed to the Interp->new
method.

=item * interp

Provide an HTML::Mason::Interp object to be used for the test.

=item * todo

If this is given, the test will be treated as a todo test, so it will
be expected to fail.  This should be a string.

=back

One of the following three options is required:

=over 4

=item * expect

The text expected as a result of calling the component.  This
parameter is _not_ required when running in L.

=item * expect_error

A regex that will be matched against the error returned from the
component execution.

=item * no_warnings

If true, this means that the test expects to run without generating
any warnings.  If warnings are generated, the test fails.

=item * expect_warnings

A regex that will be matched against any warnings output when running
the component.

=item * skip_expect

This causes the component to be run but its output is ignored.
However, if the component execution causes an error this will cause
the test to fail.  This is used in a few situations where it is
necessary to just run a component as part the preparation for another
test.

=back

=head2 run

Run the tests in the group.

=head2 Class methods

These methods are provided since some tests may need to know these
values.

=head2 base_path

The base path under which the component root and data directory for
the tests are created.

=head2 comp_root

Returns the component root directory.

=head2 data_dir

Return the data directory

=head2 check_output ( actual => $actual_output, expect => $expected_output )

Given the parameters shown above, this method will check to see if the
two are equal.  If they're not equal, it will print out an error
message attempting to highlight the difference.

=head1 ADDITIONAL RUN MODES

The following additional modes are available for running tests.

=head2 Verbose mode

To turn this on, set the environment variables MASON_VERBOSE or
MASON_DEBUG as true or run the tests as 'make test TEST_VERBOSE=1'.
In this mode, the C method will output information about tests as
they are run.  If a test fails, then it will also show the cause of
the failure.

=head2 Debug mode

To turn this on, set the MASON_DEBUG environment variable to a true
value.  In this mode, the C method will print detailed
information of its actions.  This mode includes the output printed in
VERBOSE mode.

=head2 No cleanup mode

Setting the MASON_NO_CLEANUP environment variable will tell the module
to not clean up generated data from running the tests.  This includes
the components written to disk and the data directory used during
testing.  This can be useful when debugging.

=head2 Create mode

If the individual tests are run from the command line with the
'--create' flag, then instead of checking the output of a component,
the test harness will simply output its results.  This allows you to
cut and paste these results back into the test file (assuming they are
correct!).

=head2 Running and/or skipping selected tests

You can run just some of a test file with the '--tests-to-run' flag or
the MASON_TESTS_TO_RUN environment variable. Similarly you can skip
specific tests with the '--tests-to-skip' flag or the
MASON_TESTS_TO_SKIP environment variable.

The value of either flag is a comma-separated list of one or more of

   [test_file_name:](test_number|test_name|*)

e.g.

    perl ./01-syntax.t --tests-to-run=3,5
    MASON_TESTS_TO_SKIP=fake_percent,empty_percents perl ./01-syntax.t
    MASON_TESTS_TO_RUN="misc:autohandler, request:*, interp:private1" make test

=head2 Subclassing this module

You can run tests with your own Tests.pm subclass using the
'--tests-class' flag or the MASON_TESTS_CLASS environment variable.
The value is a fully qualified package name that will be loaded before
each test file is run.  e.g.

    perl ./01-syntax.t --tests-class=HTML::Mason::Tests::MyTests
    MASON_TESTS_CLASS=HTML::Mason::Tests::MyTests make test

For example, if you have created your own lexer subclass and want
to make sure that tests still pass with it, create a Tests subclass
that overrides the _make_interp method to use your subclass:

    sub _make_interp
    {
        my ($self, %interp_params) = @_;

        return HTML::Mason::Interp->new
            ( lexer_class => HTML::Mason::MyLexer,
              %interp_params );
    }

=cut
HTML-Mason-1.59/lib/HTML/Mason/Cache/0000755000175000017500000000000013660015140016515 5ustar  autarchautarchHTML-Mason-1.59/lib/HTML/Mason/Cache/BaseCache.pm0000644000175000017500000001065313660015140020656 0ustar  autarchautarch# 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.

package HTML::Mason::Cache::BaseCache;
$HTML::Mason::Cache::BaseCache::VERSION = '1.59';
use strict;
use warnings;

#
# Override to handle busy_lock and expire_if.
#
sub get
{
    my ($self, $key, %params) = @_;
    die "must specify key" unless defined($key);

    foreach my $param (keys(%params)) {
        unless ($param =~ /^(busy_lock|expire_if)$/) {
            die "unknown param '$param'";
        }
    }

    $self->_conditionally_auto_purge_on_get();

    if (my $sub = $params{expire_if}) {
        $self->expire_if($key, $sub);
    }

    my $object = $self->get_object($key) or
        return undef;

    if (Cache::BaseCache::Object_Has_Expired($object))
    {
        if ($params{busy_lock}) {
            # If busy_lock value provided, set a new "temporary"
            # expiration time that many seconds forward, and return
            # undef so that this process will start recomputing.
            my $busy_lock_time = Cache::BaseCache::Canonicalize_Expiration_Time($params{busy_lock});
            $object->set_expires_at(time + $busy_lock_time);
            $self->set_object($key, $object);
        } else {
            $self->remove($key);
        }
        return undef;
    }

    return $object->get_data( );
}

sub expire
{
    my ($self, $key) = @_;

    if (my $obj = $self->get_object($key)) {
        $obj->set_expires_at(time-1);
        $self->set_object($key, $obj);
    }
}

sub expire_if
{
    my ($self, $key, $sub) = @_;
    die "must specify subroutine" unless defined($sub) and ref($sub) eq 'CODE';

    if (my $obj = $self->get_object($key)) {
        my $retval = $sub->($obj);
        if ($retval) {
            $self->expire($key);
        }
        return $retval;
    } else {
        return 1;
    }
}


1;

__END__

=head1 NAME

HTML::Mason::Cache::BaseCache - Base cache object

=head1 DESCRIPTION

This is the base module for all cache implementations used in Mason.
It provides a few additional methods on top of C in
Dewitt Clinton's C package.

An object of this class is returned from L<$m-Ecache|HTML::Mason::Request/item_cache>.

=head1 METHODS

=over

=item clear ()

=for html 

Remove all values in the cache.

=item get (key, [%params])

=for html 

Returns the value associated with I or undef if it is
non-existent or expired. This is extended with the following optional
name/value parameters:

=over

=item busy_lock => duration

If the value has expired, set its expiration time to the current time plus
I (instead of removing it from the cache) before returning undef.
This is used to prevent multiple processes from recomputing the same
expensive value simultaneously. The I may be of any form acceptable
to L.

=item expire_if => sub

If the value exists and has not expired, call I with the cache
object as a single parameter. If I returns a true value, expire
the value.

=back

=item get_object (key)

=for html 

Returns the underlying C object associated with I.
The most useful methods on this object are

    $co->get_created_at();    # when was object stored in cache
    $co->get_accessed_at();   # when was object last accessed
    $co->get_expires_at();    # when does object expire

=item expire (key)

=for html 

Expires the value associated with I, if it exists. Differs from
L only in that
the cache object is left around, e.g. for retrieval by
L.

=item remove (key)

=for html 

Removes the cache object associated with I, if it exists.

=item set (key, data, [duration])

=for html 

Associates I with I in the cache. I
indicates the time until the value should be erased.  If
I is unspecified, the value will never expire
by time.

I<$expires_in> may be a simple number of seconds, or a string of the
form "[number] [unit]", e.g., "10 minutes".  The valid units are s,
second, seconds, sec, m, minute, minutes, min, h, hour, hours, d, day,
days, w, week, weeks, M, month, months, y, year, and years.

=back

=cut
HTML-Mason-1.59/lib/HTML/Mason/Parser.pm0000644000175000017500000000074313660015140017310 0ustar  autarchautarch
die "The Parser module is no longer a part of HTML::Mason.  Please see ".
    "the Lexer and Compiler modules, its replacements.\n";

1;  # heh

__END__

=pod

=head1 NAME

HTML::Mason::Parser - Old module for compiling components

=head1 DESCRIPTION

The Parser object is no longer part of Mason.  It has been replaced by
the Compiler and Lexer objects.  See the L and the L for more details.

=cut
HTML-Mason-1.59/lib/HTML/Mason/Handler.pm0000644000175000017500000000171213660015140017426 0ustar  autarchautarch# -*- cperl-indent-level: 4; cperl-continued-brace-offset: -4; cperl-continued-statement-offset: 4 -*-

# 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.

#
# ** Proposed virtual subclass for handler classes (e.g. ApacheHandler). Not in use yet.
# 

package HTML::Mason::Handler;
$HTML::Mason::Handler::VERSION = '1.59';
use strict;
use warnings;

use HTML::Mason::Exceptions ( abbr => [ qw( virtual_error ) ] );

use Class::Container;
use base qw(Class::Container);


sub handle_request
{
    my $self = shift;

    my $req = $self->prepare_request(@_);

    return ref $req ? $req->exec() : $req;
}

sub prepare_request
{
    virtual_error "The prepare_request method must be overridden in a handler subclass.";
}

sub request_args
{
    virtual_error "The request_args method must be overridden in a handler subclass.";
}


1;

__END__

HTML-Mason-1.59/lib/HTML/Mason/MethodMaker.pm0000644000175000017500000001326413660015140020256 0ustar  autarchautarch# 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.

package HTML::Mason::MethodMaker;
$HTML::Mason::MethodMaker::VERSION = '1.59';
use strict;
use warnings;

use Params::Validate qw(validate_pos);

sub import
{
    my $caller = caller;
    shift; # don't need class name
    my %p = @_;

    if ($p{read_only})
    {
        foreach my $ro ( ref $p{read_only} ? @{ $p{read_only} } : $p{read_only} )
        {
            no strict 'refs';
            *{"$caller\::$ro"} = sub { return $_[0]->{$ro} };
        }
    }

    #
    # The slight weirdness to avoid calling shift in these rw subs is
    # _intentional_.  These subs get called a lot simply to read the
    # value, and optimizing this common case actually does achieve
    # something.
    #
    if ($p{read_write})
    {
        foreach my $rw ( ref $p{read_write} ? @{ $p{read_write} } : $p{read_write} )
        {
            if (ref $rw)
            {
                my ($name, $spec) = @$rw;
                my $sub =
                    sub { if (@_ > 1)
                          {
                              my $s = shift;
                              validate_pos(@_, $spec);
                              $s->{$name} = shift;
                              return $s->{$name};
                          }
                          return $_[0]->{$name};
                        };
                no strict 'refs';
                *{"$caller\::$name"} = $sub
            }
            else
            {
                my $sub =
                    sub { if (@_ > 1)
                          {
                              $_[0]->{$rw} = $_[1];
                          }
                          return $_[0]->{$rw};
                        };
                no strict 'refs';
                *{"$caller\::$rw"} = $sub;
            }
        }
    }

    if ($p{read_write_contained})
    {
        foreach my $object (keys %{ $p{read_write_contained} })
        {
            foreach my $rwc (@{ $p{read_write_contained}{$object} })
            {
                if (ref $rwc)
                {
                    my ($name, $spec) = @$rwc;
                    my $sub =
                        sub { my $s = shift;
                              my %new;
                              if (@_)
                              {
                                  validate_pos(@_, $spec);
                                  %new = ( $name => $_[0] );
                              }
                              my %args = $s->delayed_object_params( $object,
                                                                    %new );
                              return $args{$rwc};
                            };
                    no strict 'refs';
                    *{"$caller\::$name"} = $sub;
                }
                else
                {
                    my $sub =
                        sub { my $s = shift;
                              my %new = @_ ? ( $rwc => $_[0] ) : ();
                              my %args = $s->delayed_object_params( $object,
                                                                    %new );
                              return $args{$rwc};
                            };
                    no strict 'refs';
                    *{"$caller\::$rwc"} = $sub;
                }
            }
        }
    }
}

1;

=pod

=head1 NAME

HTML::Mason::MethodMaker - Used to create simple get & get/set methods in other classes

=head1 SYNOPSIS

 use HTML::Mason::MethodMaker
     ( read_only => 'foo',
       read_write => [
                      [ bar => { type => SCALAR } ],
                      [ baz => { isa => 'HTML::Mason::Baz' } ],
                      'quux', # no validation
                     ],
       read_write_contained => { other_object =>
                                 [
                                  [ 'thing1' => { isa => 'Thing1' } ],
                                  'thing2', # no validation
                                 ]
                               },
     );

=head1 DESCRIPTION

This automates the creation of simple accessor methods.

=head1 USAGE

This module creates methods when it is C'd by another module.
There are three types of methods: 'read_only', 'read_write',
'read_write_contained'.

Attributes specified as 'read_only' get an accessor that only returns
the value of the attribute.  Presumably, these attributes are set via
more complicated methods in the class or as a side effect of one of
its methods.

Attributes specified as 'read_write' will take a single optional
parameter.  If given, this parameter will become the new value of the
attribute.  This value is then returned from the method.  If no
parameter is given, then the current value is returned.

If you want the accessor to use C to validate any
values passed to the accessor (and you _do_), then the the accessor
specification should be an array reference containing two elements.
The first element is the accessor name and the second is the
validation spec.

The 'read_write_contained' parameter is used to create accessor for
delayed contained objects.  A I contained object is one that
is B created in the containing object's accessor, but rather at
some point after the containing object is constructed.  For example,
the Interpreter object creates Request objects after the Interpreter
itself has been created.

The value of the 'read_write_contained' parameter should be a hash
reference.  The keys are the internal name of the contained object,
such as "request" or "compiler".  The values for the keys are the same
as the parameters given for 'read_write' accessors.

=cut
HTML-Mason-1.59/lib/HTML/Mason/Params.pod0000644000175000017500000010304413660015140017443 0ustar  autarchautarch#
# This documentation was automatically generated by the
# make_params_pod.pl script in the release
# directory of the CVS repository.
#
# Edit that script instead of this document.
#

=head1 NAME

HTML::Mason::Params - Mason configuration parameters

=head1 DESCRIPTION

This document lists all of the Mason configuration parameters that are
intended to be used by end users.

=head1 PERL AND APACHE NAMES

Each parameter has two names: a Perl version and an Apache version.
The Perl version uses C, while the Apache
version uses C with a C prefix. The conversion from
one version to the other is otherwise very predictable. For example,

=over 4

=item *

C C--E> C

=item *

C C--E> C

=item *

C C--E> C

=back

=head2 Where Apache Names Are Used

The Apache parameter names are used in the Apache configuration file
in an L.

=head2 Where Perl Names Are Used

The Perl parameter names are used from Perl code, i.e. anywhere other
than the Apache configuration file. For example,

=over 4

=item *

In an L, you can pass most of these parameters to the
L constructor.

=item *

In a L, you can pass most of these parameters to the
L constructor.

=item *

When launching a L, you can
pass any of the C parameters to
L.

=back

=head1 PARAMETERS



=head2 allow_globals

=over 4

=item * Perl name:           allow_globals

=item * Apache name:         MasonAllowGlobals

=item * Type in httpd.conf:  list

=item * Default:             []

=item * Belongs to:          C




=back

List of variable names, complete with prefix (C<$@%>), that you intend
to use as globals in components.  Normally global variables are
forbidden by C, but any variable mentioned in this list is
granted a reprieve via a "use vars" statement. For example:

    allow_globals => [qw($DBH %session)]

In a mod_perl environment, C<$r> (the request object) is automatically
added to this list.


=head2 apache_status_title

=over 4

=item * Perl name:           apache_status_title

=item * Apache name:         MasonApacheStatusTitle

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason status

=item * Belongs to:          C




=back

Title that you want this ApacheHandler to appear as under
Apache::Status.  Default is "HTML::Mason status".  This is useful if
you create more than one ApacheHandler object and want them all
visible via Apache::Status.


=head2 args_method

=over 4

=item * Perl name:           args_method

=item * Apache name:         MasonArgsMethod

=item * Type in httpd.conf:  string

=item * Default:             mod_perl

=item * Belongs to:          C




=back

Method to use for unpacking GET and POST arguments. The valid options
are 'CGI' and 'mod_perl'; these indicate that a C or
C object (respectively) will be created for the
purposes of argument handling.

'mod_perl' is the default under mod_perl-1 and requires that you have 
installed the C package.  Under mod_perl-2, the default
is 'CGI' because C is still in development.

If args_method is 'mod_perl', the C<$r> global is upgraded to an
Apache::Request object. This object inherits all Apache methods and
adds a few of its own, dealing with parameters and file uploads.  See
C for more information.

If the args_method is 'CGI', the Mason request object (C<$m>) will have a
method called C available.  This method returns the CGI
object used for argument processing.

While Mason will load C or C as needed at runtime, it
is recommended that you preload the relevant module either in your
F or F file, as this will save some memory.


=head2 auto_send_headers

=over 4

=item * Perl name:           auto_send_headers

=item * Apache name:         MasonAutoSendHeaders

=item * Type in httpd.conf:  boolean

=item * Default:             1

=item * Belongs to:          C




=back

=for html 

True or false, default is true.  Indicates whether Mason should
automatically send HTTP headers before sending content back to the
client. If you set to false, you should call C<$r-Esend_http_header>
manually.

See the L section of the developer's manual for more details about the automatic
header feature.

NOTE: This parameter has no effect under mod_perl-2, since calling
C<$r-Esend_http_header> is no longer needed.


=head2 autoflush

=over 4

=item * Perl name:           autoflush

=item * Apache name:         MasonAutoflush

=item * Type in httpd.conf:  boolean

=item * Default:             0

=item * Belongs to:          C




=back

True or false, default is false. Indicates whether to flush the output
buffer (C<$m-Eflush_buffer>) after every string is output. Turn on
autoflush if you need to send partial output to the client, for
example in a progress meter.

As of Mason 1.3, autoflush will only work if L has
been set.  Components can be compiled more efficiently if they don't
have to check for autoflush. Before using autoflush you might consider
whether a few manual C<$m-Eflush_buffer> calls would work nearly
as well.


=head2 autohandler_name

=over 4

=item * Perl name:           autohandler_name

=item * Apache name:         MasonAutohandlerName

=item * Type in httpd.conf:  string

=item * Default:             autohandler

=item * Belongs to:          C




=back

File name used for
L. Default is
"autohandler".  If this is set to an empty string ("") then
autohandlers are turned off entirely.


=head2 buffer_preallocate_size

=over 4

=item * Perl name:           buffer_preallocate_size

=item * Apache name:         MasonBufferPreallocateSize

=item * Type in httpd.conf:  string

=item * Default:             0

=item * Belongs to:          C




=back

=for html 

Number of bytes to preallocate in the output buffer for each request.
Defaults to 0. Setting this to, say, your maximum page size (or close
to it) can reduce the number of reallocations Perl performs as
components add to the output buffer.


=head2 code_cache_max_size

=over 4

=item * Perl name:           code_cache_max_size

=item * Apache name:         MasonCodeCacheMaxSize

=item * Type in httpd.conf:  string

=item * Default:             unlimited

=item * Belongs to:          C




=back

=for html 

Specifies the maximum number of components that should be held in the
in-memory code cache. The default is 'unlimited', meaning no
components will ever be discarded; Mason can perform certain
optimizations in this mode. Setting this to zero disables the code
cache entirely. See the L
section of the administrator's manual for further details.


=head2 comp_class

=over 4

=item * Perl name:           comp_class

=item * Apache name:         MasonCompClass

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason::Component

=item * Belongs to:          C




=back

The class into which component objects are blessed.  This defaults to
L.


=head2 comp_root

=over 4

=item * Perl name:           comp_root

=item * Apache name:         MasonCompRoot

=item * Type in httpd.conf:  list

=item * Default:             Varies

=item * Belongs to:          C




=back

=for html 

The component root marks the top of your component hierarchy and
defines how component paths are translated into real file paths. For
example, if your component root is F, a component
path of F translates to the file
F.

Under L and
L, comp_root defaults to the server's
document root. In standalone mode comp_root defaults to the current
working directory.

This parameter may be either a scalar or an array reference.  If it is
a scalar, it should be a filesystem path indicating the component
root. If it is an array reference, it should be of the following form:

 [ [ foo => '/usr/local/foo' ],
   [ bar => '/usr/local/bar' ] ]

This is an array of two-element array references, not a hash.  The
"keys" for each path must be unique and their "values" must be
filesystem paths.  These paths will be searched in the provided order
whenever a component path is resolved. For example, given the above
component roots and a component path of F, Mason
would search first for F, then for
F.

The keys are used in several ways. They help to distinguish component
caches and object files between different component roots, and they
appear in the C of a component.

When you specify a single path for a component root, this is actually
translated into

  [ [ MAIN => path ] ]

If you have turned on L, you may modify the
component root(s) of an interpreter between requests by calling
C<$interp-Ecomp_root> with a value. However, the path associated
with any given key may not change between requests. For example,
if the initial component root is

 [ [ foo => '/usr/local/foo' ],
   [ bar => '/usr/local/bar' ], ]

then it may not be changed to

 [ [ foo => '/usr/local/bar' ],
   [ bar => '/usr/local/baz' ],

but it may be changed to

 [ [ foo   => '/usr/local/foo' ],
   [ blarg => '/usr/local/blarg' ] ]

In other words, you may add or remove key/path pairs but not modify an
already-used key/path pair. The reason for this restriction is that
the interpreter maintains a component cache per key that would become
invalid if the associated paths were to change.


=head2 compiler_class

=over 4

=item * Perl name:           compiler_class

=item * Apache name:         MasonCompilerClass

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason::Compiler::ToObject

=item * Belongs to:          C




=back

The class to use when creating a compiler. Defaults to
L.


=head2 component_error_handler

=over 4

=item * Perl name:           component_error_handler

=item * Apache name:         MasonComponentErrorHandler

=item * Type in httpd.conf:  code

=item * Default:             sub { package HTML::Mason::Exceptions; use warnings; use strict 'refs'; my($err) = @_; return unless $err; if (UNIVERSAL::can($err, 'rethrow')) { $err->rethrow; } elsif (ref $err) { die $err; } 'HTML::Mason::Exception'->throw('error', $err); }

=item * Belongs to:          C




=back

A code reference used to handle errors thrown during component
compilation or runtime. By default, this is a subroutine that turns
non-exception object errors in components into exceptions. If this
parameter is set to a false value, these errors are simply rethrown
as-is.

Turning exceptions into objects can be expensive, since this will
cause the generation of a stack trace for each error. If you are using
strings or unblessed references as exceptions in your code, you may
want to turn this off as a performance boost.


=head2 data_cache_api

=over 4

=item * Perl name:           data_cache_api

=item * Apache name:         MasonDataCacheApi

=item * Type in httpd.conf:  string

=item * Default:             1.1

=item * Belongs to:          C




=back

The C<$m-Ecache> API to use:

=over

=item *

'1.1', the default, indicates a C based API.

=item *

'chi' indicates a C based API.

=item *

'1.0' indicates the custom cache API used in Mason 1.0x and
earlier. This compatibility layer is provided as a convenience for
users upgrading from older versions of Mason, but will not be
supported indefinitely.

=back


=head2 data_cache_defaults

=over 4

=item * Perl name:           data_cache_defaults

=item * Apache name:         MasonDataCacheDefaults

=item * Type in httpd.conf:  hash_list

=item * Default:             None

=item * Belongs to:          C




=back

A hash reference of default options to use for the C<$m-Ecache>
command.  For example, to use Cache::Cache's C
implementation by default:

    data_cache_defaults => {cache_class => 'MemoryCache'}

To use the CHI C driver by default:

    data_cache_api      => 'CHI',
    data_cache_defaults => {driver => 'FastMmap'},

These settings are overridden by options given to particular
C<$m-Ecache> calls.


=head2 data_dir

=over 4

=item * Perl name:           data_dir

=item * Apache name:         MasonDataDir

=item * Type in httpd.conf:  string

=item * Default:             None

=item * Belongs to:          C




=back

The data directory is a writable directory that Mason uses for various
features and optimizations: for example, component object files and
data cache files. Mason will create the directory on startup, if necessary, and set its
permissions according to the web server User/Group.

Under L, data_dir defaults to a
directory called "mason" under the Apache server root. You will
need to change this on certain systems that assign a high-level
server root such as F!

In non-Apache environments, data_dir has no default. If it is left
unspecified, Mason will not use L, and the default
L will be
C instead of C.


=head2 decline_dirs

=over 4

=item * Perl name:           decline_dirs

=item * Apache name:         MasonDeclineDirs

=item * Type in httpd.conf:  boolean

=item * Default:             1

=item * Belongs to:          C




=back

True or false, default is true. Indicates whether Mason should decline
directory requests, leaving Apache to serve up a directory index or a
C error as appropriate. See the L section of the administrator's manual
for more information about handling directories with Mason.


=head2 default_escape_flags

=over 4

=item * Perl name:           default_escape_flags

=item * Apache name:         MasonDefaultEscapeFlags

=item * Type in httpd.conf:  string

=item * Default:             []

=item * Belongs to:          C




=back

Escape flags to apply to all <% %> expressions by default. The current
valid flags are

    h - escape for HTML ('<' => '<', etc.)
    u - escape for URL (':' => '%3A', etc.)

The developer can override default escape flags on a per-expression
basis; see the L section of the developer's manual.

If you want to set I flags as the default, this should be
given as a reference to an array of flags.


=head2 define_args_hash

=over 4

=item * Perl name:           define_args_hash

=item * Apache name:         MasonDefineArgsHash

=item * Type in httpd.conf:  string

=item * Default:             auto

=item * Belongs to:          C




=back

One of "always", "auto", or "never".  This determines whether or not
an C<%ARGS> hash is created in components.  If it is set to "always",
one is always defined.  If set to "never", it is never defined.

The default, "auto", will cause the hash to be defined only if some
part of the component contains the string "ARGS".  This is somewhat
crude, and may result in some false positives, but this is preferable
to false negatives.

Not defining the args hash means that we can avoid copying component
arguments, which can save memory and slightly improve execution speed.


=head2 dhandler_name

=over 4

=item * Perl name:           dhandler_name

=item * Apache name:         MasonDhandlerName

=item * Type in httpd.conf:  string

=item * Default:             dhandler

=item * Belongs to:          C




=back

File name used for L. Default
is "dhandler".  If this is set to an empty string ("") then dhandlers
are turned off entirely.


=head2 dynamic_comp_root

=over 4

=item * Perl name:           dynamic_comp_root

=item * Apache name:         MasonDynamicCompRoot

=item * Type in httpd.conf:  boolean

=item * Default:             0

=item * Belongs to:          C




=back

True or false, defaults to false. Indicates whether the L
can be modified on this interpreter between requests. Mason can
perform a few optimizations with a fixed component root, so you
should only set this to true if you actually need it.


=head2 enable_autoflush

=over 4

=item * Perl name:           enable_autoflush

=item * Apache name:         MasonEnableAutoflush

=item * Type in httpd.conf:  boolean

=item * Default:             1

=item * Belongs to:          C




=back

True or false, default is true. Indicates whether components are
compiled with support for L. The component can be compiled
to a more efficient form if it does not have to check for autoflush
mode, so you should set this to 0 if you can.


=head2 error_format

=over 4

=item * Perl name:           error_format

=item * Apache name:         MasonErrorFormat

=item * Type in httpd.conf:  string

=item * Default:             Varies

=item * Belongs to:          C




=back

Indicates how errors are formatted. The built-in choices are

=over

=item *

I - just the error message with no trace information

=item *

I - a multi-line text format

=item *

I - a single-line text format, with different pieces of
information separated by tabs (useful for log files)

=item *

I - a fancy html format

=back

The default format under L and
L is either I or I depending
on whether the error mode is I or I, respectively. The
default for standalone mode is I.

The formats correspond to C methods named
as_I. You can define your own format by creating an
appropriately named method; for example, to define an "xml" format,
create a method C patterned after one of
the built-in methods.


=head2 error_mode

=over 4

=item * Perl name:           error_mode

=item * Apache name:         MasonErrorMode

=item * Type in httpd.conf:  string

=item * Default:             Varies

=item * Belongs to:          C




=back

Indicates how errors are returned to the caller.  The choices are
I, meaning die with the error, and I, meaning output
the error just like regular output.

The default under L and
L is I, causing the error to be
displayed in the browser.  The default for standalone mode is
I.


=head2 escape_flags

=over 4

=item * Perl name:           escape_flags

=item * Apache name:         MasonEscapeFlags

=item * Type in httpd.conf:  hash_list

=item * Default:             None

=item * Belongs to:          C




=back

A hash reference of escape flags to set for this object.  See the
section on the L for more details.


=head2 ignore_warnings_expr

=over 4

=item * Perl name:           ignore_warnings_expr

=item * Apache name:         MasonIgnoreWarningsExpr

=item * Type in httpd.conf:  regex

=item * Default:             qr/Subroutine .* redefined/i

=item * Belongs to:          C




=back

Regular expression indicating which warnings to ignore when loading
components. Any warning that is not ignored will prevent the
component from being loaded and executed. For example:

    ignore_warnings_expr =>
        'Global symbol.*requires explicit package'

If set to undef, all warnings are heeded. If set to '.', warnings
are turned off completely as a specially optimized case.

By default, this is set to 'Subroutine .* redefined'.  This allows you
to declare global subroutines inside <%once> sections and not receive
an error when the component is reloaded.


=head2 in_package

=over 4

=item * Perl name:           in_package

=item * Apache name:         MasonInPackage

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason::Commands

=item * Belongs to:          C




=back

This is the package in which a component's code is executed.  For
historical reasons, this defaults to C.


=head2 interp_class

=over 4

=item * Perl name:           interp_class

=item * Apache name:         MasonInterpClass

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason::Interp

=item * Belongs to:          C




=back

The class to use when creating a interpreter. Defaults to
L.


=head2 lexer_class

=over 4

=item * Perl name:           lexer_class

=item * Apache name:         MasonLexerClass

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason::Lexer

=item * Belongs to:          C




=back

The class to use when creating a lexer. Defaults to L.


=head2 max_recurse

=over 4

=item * Perl name:           max_recurse

=item * Apache name:         MasonMaxRecurse

=item * Type in httpd.conf:  string

=item * Default:             32

=item * Belongs to:          C




=back

The maximum recursion depth for the component stack, for the request
stack, and for the inheritance stack. An error is signalled if the
maximum is exceeded.  Default is 32.


=head2 named_component_subs

=over 4

=item * Perl name:           named_component_subs

=item * Apache name:         MasonNamedComponentSubs

=item * Type in httpd.conf:  boolean

=item * Default:             0

=item * Belongs to:          C




=back

When compiling a component, use uniquely named subroutines for the a
component's body, subcomponents, and methods. Doing this allows you to
effectively profile Mason components. Without this, all components
simply show up as __ANON__ or something similar in the profiler.


=head2 object_file_extension

=over 4

=item * Perl name:           object_file_extension

=item * Apache name:         MasonObjectFileExtension

=item * Type in httpd.conf:  string

=item * Default:             .obj

=item * Belongs to:          C




=back

Extension to add to the end of object files. Default is ".obj".


=head2 out_method

=over 4

=item * Perl name:           out_method

=item * Apache name:         MasonOutMethod

=item * Type in httpd.conf:  code

=item * Default:             Print to STDOUT

=item * Belongs to:          C




=back

Indicates where to send output. If out_method is a reference to a
scalar, output is appended to the scalar.  If out_method is a
reference to a subroutine, the subroutine is called with each output
string. For example, to send output to a file called "mason.out":

    my $fh = new IO::File ">mason.out";
    ...
    out_method => sub { $fh->print($_[0]) }

By default, out_method prints to standard output. Under
L, standard output is
redirected to C<< $r->print >>.


=head2 plugins

=over 4

=item * Perl name:           plugins

=item * Apache name:         MasonPlugins

=item * Type in httpd.conf:  list

=item * Default:             []

=item * Belongs to:          C




=back

An array of plugins that will be called at various stages of request
processing.  Please see L for
details.


=head2 postamble

=over 4

=item * Perl name:           postamble

=item * Apache name:         MasonPostamble

=item * Type in httpd.conf:  string

=item * Default:             None

=item * Belongs to:          C




=back

Text given for this parameter is placed at the end of each
component. See also L.  The request will be available as
C<$m> in postamble code.


=head2 postprocess_perl

=over 4

=item * Perl name:           postprocess_perl

=item * Apache name:         MasonPostprocessPerl

=item * Type in httpd.conf:  code

=item * Default:             None

=item * Belongs to:          C




=back

Sub reference that is called to postprocess the Perl portion of a
compiled component, just before it is assembled into its final
subroutine form.  The sub is called with a single parameter, a scalar
reference to the Perl portion of the component.  The sub is expected
to process the string in-place. See also
L and L.


=head2 postprocess_text

=over 4

=item * Perl name:           postprocess_text

=item * Apache name:         MasonPostprocessText

=item * Type in httpd.conf:  code

=item * Default:             None

=item * Belongs to:          C




=back

Sub reference that is called to postprocess the text portion of a
compiled component, just before it is assembled into its final
subroutine form.  The sub is called with a single parameter, a scalar
reference to the text portion of the component.  The sub is expected
to process the string in-place. See also
L and L.


=head2 preamble

=over 4

=item * Perl name:           preamble

=item * Apache name:         MasonPreamble

=item * Type in httpd.conf:  string

=item * Default:             None

=item * Belongs to:          C




=back

Text given for this parameter is placed at the beginning of each
component, but after the execution of any C<< <%once> >> block. See
also L. The request will be available as C<$m> in preamble
code.


=head2 preloads

=over 4

=item * Perl name:           preloads

=item * Apache name:         MasonPreloads

=item * Type in httpd.conf:  list

=item * Default:             None

=item * Belongs to:          C




=back

A list of component paths, optionally with glob wildcards, to load
when the interpreter initializes. e.g.

    preloads => ['/foo/index.html','/bar/*.pl']

Default is the empty list.  For maximum performance, this should only
be used for components that are frequently viewed and rarely updated.
See the L section of the administrator's manual for further details.

As mentioned in the developer's manual, a component's C<< <%once> >>
section is executed when it is loaded.  For preloaded components, this
means that this section will be executed before a Mason or Apache
request exist, so preloading a component that uses C<$m> or C<$r> in a
C<< <%once> >> section will fail.


=head2 preprocess

=over 4

=item * Perl name:           preprocess

=item * Apache name:         MasonPreprocess

=item * Type in httpd.conf:  code

=item * Default:             None

=item * Belongs to:          C




=back

Sub reference that is called to preprocess each component before the compiler does
it's magic.  The sub is called with a single parameter, a scalar reference
to the script.  The sub is expected to process the script in-place.   This is
one way to extend the HTML::Mason syntax with new tags, etc., although a much
more flexible way is to subclass the Lexer or Compiler class. See also
L and L.


=head2 request_class

=over 4

=item * Perl name:           request_class

=item * Apache name:         MasonRequestClass

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason::Request

=item * Belongs to:          C




=back

The class to use when creating requests. Defaults to
L.


=head2 resolver_class

=over 4

=item * Perl name:           resolver_class

=item * Apache name:         MasonResolverClass

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason::Resolver::File

=item * Belongs to:          C




=back

The class to use when creating a resolver. Defaults to
L.


=head2 static_source

=over 4

=item * Perl name:           static_source

=item * Apache name:         MasonStaticSource

=item * Type in httpd.conf:  boolean

=item * Default:             0

=item * Belongs to:          C




=back

True or false, default is false. When false, Mason checks the
timestamp of the component source file each time the component is used
to see if it has changed. This provides the instant feedback for
source changes that is expected for development.  However it does
entail a file stat for each component executed.

When true, Mason assumes that the component source tree is unchanging:
it will not check component source files to determine if the memory
cache or object file has expired.  This can save many file stats per
request. However, in order to get Mason to recognize a component
source change, you must flush the memory cache and remove object files.
See L for one easy way to arrange this.

We recommend turning this mode on in your production sites if
possible, if performance is of any concern.


=head2 static_source_touch_file

=over 4

=item * Perl name:           static_source_touch_file

=item * Apache name:         MasonStaticSourceTouchFile

=item * Type in httpd.conf:  string

=item * Default:             None

=item * Belongs to:          C




=back

Specifies a filename that Mason will check once at the beginning of
of every request. When the file timestamp changes, Mason will (1) clear
its in-memory component cache, and (2) remove object files if
they have not already been deleted by another process.

This provides a convenient way to implement L mode.
All you need to do is make sure that a single file gets touched
whenever components change. For Mason's part, checking a single
file at the beginning of a request is much cheaper than checking
every component file when static_source=0.


=head2 subcomp_class

=over 4

=item * Perl name:           subcomp_class

=item * Apache name:         MasonSubcompClass

=item * Type in httpd.conf:  string

=item * Default:             HTML::Mason::Component::Subcomponent

=item * Belongs to:          C




=back

The class into which subcomponent objects are blessed.  This defaults
to L.


=head2 use_object_files

=over 4

=item * Perl name:           use_object_files

=item * Apache name:         MasonUseObjectFiles

=item * Type in httpd.conf:  boolean

=item * Default:             1

=item * Belongs to:          C




=back

True or false, default is true.  Specifies whether Mason creates
object files to save the results of component parsing. You may want to
turn off object files for disk space reasons, but otherwise this
should be left alone.


=head2 use_source_line_numbers

=over 4

=item * Perl name:           use_source_line_numbers

=item * Apache name:         MasonUseSourceLineNumbers

=item * Type in httpd.conf:  boolean

=item * Default:             1

=item * Belongs to:          C




=back

True or false, default is true. Indicates whether component line
numbers that appear in error messages, stack traces, etc. are in terms
of the source file instead of the object file. Mason does this by
inserting '#line' directives into compiled components.  While source
line numbers are more immediately helpful, object file line numbers
may be more appropriate for in-depth debugging sessions.


=head2 use_strict

=over 4

=item * Perl name:           use_strict

=item * Apache name:         MasonUseStrict

=item * Type in httpd.conf:  boolean

=item * Default:             1

=item * Belongs to:          C




=back

True or false, default is true. Indicates whether or not a given
component should C.

=head2 use_warnings

=over 4

=item * Perl name:           use_warnings

=item * Apache name:         MasonUseWarnings

=item * Type in httpd.conf:  boolean

=item * Default:             1

=item * Belongs to:          C

=back

True or false, default is false. Indicates whether or not a given
component should C.
HTML-Mason-1.59/lib/HTML/Mason/ComponentSource.pm0000644000175000017500000001242213660015140021174 0ustar  autarchautarch# 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.

package HTML::Mason::ComponentSource;
$HTML::Mason::ComponentSource::VERSION = '1.59';
use strict;
use warnings;
use File::Basename;
use File::Spec;
use HTML::Mason::Exceptions( abbr => [qw(param_error error)] );
use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { param_error join '', @_  } );

# for reference later
#
# BEGIN
# {
#     __PACKAGE__->valid_params
#         (
#          comp_id       => { type => SCALAR | UNDEF, public => 0 },
#          friendly_name => { type => SCALAR, public => 0 },
#          last_modified => { type => SCALAR, public => 0 },
#          comp_path     => { type => SCALAR, public => 0 },
#          comp_class    => { isa => 'HTML::Mason::Component',
#                             default => 'HTML::Mason::Component',
#                             public => 0 },
#          extra         => { type => HASHREF, default => {}, public => 0 },
#          source_callback => { type => CODEREF, public => 0 },
#     );
# }

use HTML::Mason::MethodMaker
    ( read_only => [ qw( comp_id
                         friendly_name
                         last_modified
                         comp_path
                         comp_class
                         extra
                        ) ],
      );

my %defaults = ( comp_class => 'HTML::Mason::Component' );

sub new
{
    my $class = shift;

    return bless { %defaults, @_ }, $class
}

sub comp_source_ref
{
    my $self = shift;

    my $source = eval { $self->{source_callback}->() };

    rethrow_exception $@;

    unless ( defined $source )
    {
        error "source callback returned no source for $self->{friendly_name} component";
    }

    my $sourceref = ref($source) ? $source : \$source;
    return $sourceref;
}

sub comp_source { ${shift()->comp_source_ref} }

sub object_code
{
    my $self = shift;
    my %p = validate( @_, { compiler => { isa => 'HTML::Mason::Compiler' } } );

    return $p{compiler}->compile( comp_source => $self->comp_source,
                                  name => $self->friendly_name,
                                  comp_path => $self->comp_path,
                                  comp_class => $self->comp_class,
                                );
}

1;

__END__

=head1 NAME

HTML::Mason::ComponentSource - represents information about an component

=head1 SYNOPSIS

    my $info = $resolver->get_info($comp_path);

=head1 DESCRIPTION

Mason uses the ComponentSource class to store information about a
source component, one that has yet to be compiled.

=head1 METHODS

=over

=item new

This method takes the following arguments:

=over 4

=item * comp_path

The component's component path.

=item * last_modified

This is the last modification time for the component, in Unix time
(seconds since the epoch).

=item * comp_id

This is a unique id for the component used to distinguish two
components with the same name in different component roots.

If your resolver does not support multiple component roots, this can
simply be the same as the "comp_path" key or it can be any other id
you wish.

This value will be used when constructing filesystem paths so it needs
to be something that works on different filesystems.  If it contains
forward slashes, these will be converted to the appropriate
filesystem-specific path separator.

In fact, we encourage you to make sure that your component ids have
some forward slashes in them or also B of your generated object
files will end up in a single directory, which could affect
performance.

=item * comp_class

The component class into which this particular component should be
blessed when it is created.  This must be a subclass of
C, which is the default.

=item * friendly_name

This is used when displaying error messages related to the component,
like parsing errors.  This should be something that will help whoever
sees the message identify the component.  For example, for component
stored on the filesystem, this should be the absolute path to the
component.

=item * source_callback

This is a subroutine reference which, when called, returns the
component source.

The reasoning behind using this parameter is that it helps avoid a
profusion of tiny little C subclasses that
don't do very much.

=item * extra

This optional parameter should be a hash reference.  It is used to
pass information from the resolver to the component class.

This is needed since a
L|HTML::Mason::Resolver> subclass and a
L|HTML::Mason::Component> subclass can be
rather tightly coupled, but they must communicate with each through
the interpreter (this may change in the future).

=back

=item comp_path

=item last_modified

=item comp_id

=item comp_class

=item friendly_name

=item extra

These are all simple accessors that return the value given to the
constructor.

=item comp_source

Returns the source of the component.

=item object_code ( compiler => $compiler )

Given a compiler, this method returns the object code for the
component.

=back

L,
L,
L

=cut
HTML-Mason-1.59/lib/HTML/Mason/Lexer.pm0000644000175000017500000004474513660015140017145 0ustar  autarchautarch# 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.

package HTML::Mason::Lexer;
$HTML::Mason::Lexer::VERSION = '1.59';
use strict;
use warnings;

use HTML::Mason::Exceptions( abbr => [qw(param_error syntax_error error)] );

use HTML::Mason::Tools qw( taint_is_on );

use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { param_error join '', @_ } );

use Class::Container;
use base qw(Class::Container);

# This is a block name and what method should be called to lex its
# contents if it is encountered.  'def' & 'method' blocks are special
# cases we actually call ->start again to recursively parse the
# contents of a subcomponent/method.  Theoretically, adding a block is
# as simple as adding an entry to this hash, and possibly a new
# contents lexing methods.
my %blocks = ( args    => 'variable_list_block',
               attr    => 'key_val_block',
               flags   => 'key_val_block',
               cleanup => 'raw_block',
               doc     => 'doc_block',
               filter  => 'raw_block',
               init    => 'raw_block',
               once    => 'raw_block',
               perl    => 'raw_block',
               shared  => 'raw_block',
               text    => 'text_block',
             );

sub block_names
{
    return keys %blocks;
}

sub block_body_method
{
    return $blocks{ $_[1] };
}

{
    my $blocks_re;

    my $re = join '|', __PACKAGE__->block_names;
    $blocks_re = qr/$re/i;

    sub blocks_regex
    {
        return $blocks_re;
    }
}

sub lex
{
    my $self = shift;
    my %p = validate(@_,
                     {comp_source => SCALAR|SCALARREF,
                      name => SCALAR,
                      compiler => {isa => 'HTML::Mason::Compiler'}}
                    );

    # Note - we could improve memory usage here if we didn't make a
    # copy of the scalarref, but that will take some more work to get
    # it working
    $p{comp_source} = ${$p{comp_source}} if ref $p{comp_source};

    # Holds information about the current lex.  Make it local() so
    # we're fully re-entrant.
    local $self->{current} = \%p;
    my $current = $self->{current}; # For convenience

    # Clean up Mac and DOS line endings
    $current->{comp_source} =~ s/\r\n?/\n/g;

    # Initialize lexer state
    $current->{lines} = 1;
    $current->{in_def} = $current->{in_method} = 0;

    # This will be overridden if entering a def or method section.
    $current->{ending} = qr/\G\z/;

    # We need to untaint the component or else the regexes will fail
    # to a Perl bug.  The delete is important because we need to
    # create an entirely new scalar, not just modify the existing one.
    ($current->{comp_source}) = (delete $current->{comp_source}) =~ /(.*)/s
        if taint_is_on;

    eval
    {
        $current->{compiler}->start_component;
        $self->start;
    };
    my $err = $@;
    # Always call end_component, but throw the first error
    eval
    {
        $current->{compiler}->end_component;
    };
    $err ||= $@;

    rethrow_exception $err;
}

sub start
{
    my $self = shift;

    my $end;
    while (1)
    {
        last if $end = $self->match_end;

        $self->match_block && next;

        $self->match_named_block && next;

        $self->match_substitute && next;

        $self->match_comp_call && next;

        $self->match_perl_line && next;

        $self->match_comp_content_call && next;

        $self->match_comp_content_call_end && next;

        $self->match_text && next;

        if ( ( $self->{current}{in_def} || $self->{current}{in_method} ) &&
             $self->{current}{comp_source} =~ /\G\z/ )
        {
            my $type = $self->{current}{in_def} ? 'def' : 'method';
            $self->throw_syntax_error("Missing closing  tag");
        }

        last if $self->{current}{comp_source} =~ /\G\z/;

        # We should never get here - if we do, we're in an infinite loop.
        $self->throw_syntax_error("Infinite parsing loop encountered - Lexer bug?");
    }

    if ( $self->{current}{in_def} || $self->{current}{in_method} )
    {
        my $type = $self->{current}{in_def} ? 'def' : 'method';
        unless ( $end =~ m,\n?,i )
        {
            my $block_name = $self->{current}{"in_$type"};
            $self->throw_syntax_error("No  tag for <%$type $block_name> block");
        }
    }
}

sub match_block
{
    my $self = shift;

    my $blocks_re = $self->blocks_regex;

    if ( $self->{current}{comp_source} =~ /\G<%($blocks_re)>/igcs )
    {
        my $type = lc $1;
        $self->{current}{compiler}->start_block( block_type => $type );

        my $method = $self->block_body_method($type);
        $self->$method( {block_type => $type} );

        return 1;
    }
}

sub generic_block
{
    my ($self, $method, $p) = @_;

    $p->{allow_text} = 1;
    my ($block, $nl) = $self->match_block_end( $p );

    $self->{current}{compiler}->$method( block_type => $p->{block_type},
                                         block => $block );

    $self->{current}{lines} += $block =~ tr/\n//;
    $self->{current}{lines}++ if $nl;

    $self->{current}{compiler}->end_block( block_type => $p->{block_type} );
}

sub text_block
{
    my $self = shift;
    $self->generic_block('text_block', @_);
}

sub raw_block
{
    my $self = shift;
    $self->generic_block('raw_block', @_);
}

sub doc_block
{
    my $self = shift;
    $self->generic_block('doc_block', @_);
}

sub variable_list_block
{
    my ($self, $p) = @_;

    my $ending = qr/ \n | <\/%\Q$p->{block_type}\E> /ix;
    while ( $self->{current}{comp_source} =~ m,
                       \G               # last pos matched
                       (?:
                        [ \t]*
                        ( [\$\@\%] )    # variable type
                        ( [^\W\d]\w* )  # only allows valid Perl variable names
                        [ \t]*
                        # if we have a default arg we'll suck up
                        # any comment it has as part of the default
                        # otherwise explcitly search for a comment
                        (?:
                         (?:              # this entire entire piece is optional
                           =>
                          ( [^\n]+? )     # default value
                         )
                         |
                         (?:              # an optional comment
                          [ \t]*
                          \#
                          [^\n]*
                         )
                        )?
                        (?= $ending )
                        |
                        [ \t]*          # a comment line
                        \#
                        [^\n]*
                        (?= $ending )
                        |
                        [ \t]*          # just space
                       )
                       (\n |          # newline or
                          (?= <\/%\Q$p->{block_type}\E> ) )   # end of block (don't consume it)
                      ,ixgc
          )
    {
        if ( defined $1 && defined $2 && length $1 && length $2 )
        {
            $self->{current}{compiler}->variable_declaration( block_type => $p->{block_type},
                                                              type => $1,
                                                              name => $2,
                                                              default => $3,
                                                            );
        }

        $self->{current}{lines}++ if $4;
    }

    $p->{allow_text} = 0;
    my $nl = $self->match_block_end( $p );
    $self->{current}{lines}++ if $nl;

    $self->{current}{compiler}->end_block( block_type => $p->{block_type} );
}

sub key_val_block
{
    my ($self, $p) = @_;

    my $ending = qr, (?: \n |           # newline or
                         (?= {block_type}\E> ) )   # end of block (don't consume it)
                   ,ix;

    while ( $self->{current}{comp_source} =~ /
                      \G
                      [ \t]*
                      ([\w_]+)          # identifier
                      [ \t]*=>[ \t]*    # separator
                      (\S[^\n]*?)       # value ( must start with a non-space char)
                      $ending
                      |
                      \G\n              # a plain empty line
                      |
                      \G
                      [ \t]*            # an optional comment
                      \#
                      [^\n]*
                      $ending
                      |
                      \G[ \t]+?
                      $ending
                     /xgc )
    {
        if ( defined $1 && defined $2 && length $1 && length $2 )
        {
            $self->{current}{compiler}->key_value_pair( block_type => $p->{block_type},
                                                        key => $1,
                                                        value => $2
                                                      );
        }

        $self->{current}{lines}++;
    }

    $p->{allow_text} = 0;
    my $nl = $self->match_block_end( $p );
    $self->{current}{lines}++ if $nl;

    $self->{current}{compiler}->end_block( block_type => $p->{block_type} );
}

sub match_block_end
{
    my ($self, $p) = @_;

    my $re = $p->{allow_text} ? qr,\G(.*?){block_type}\E>(\n?),is
                              : qr,\G\s*{block_type}\E>(\n?),is;
    if ( $self->{current}{comp_source} =~ /$re/gc )
    {
        return $p->{allow_text} ? ($1, $2) : $1;
    }
    else
    {
        $self->throw_syntax_error("Invalid <%$p->{block_type}> section line");
    }
}

sub match_named_block
{
    my ($self, $p) = @_;

    if ( $self->{current}{comp_source} =~ /\G<%(def|method)(?:\s+([^\n]+?))?\s*>/igcs )
    {
        my ($type, $name) = (lc $1, $2);

        $self->throw_syntax_error("$type block without a name")
            unless defined $name && length $name;

        $self->{current}{compiler}->start_named_block( block_type => $type,
                                                       name => $name );

        # This will cause ->start to return once it hits the
        # appropriate ending tag.
        local $self->{current}{ending} = qr,\G\n?,i;

        local $self->{current}{"in_$type"} = $name;

        $self->start();

        $self->{current}{compiler}->end_named_block( block_type => $type );

        return 1;
    }
}

# Like [a-zA-Z_] but respects locales
my $flag = qr/[[:alpha:]_]\w*/;
sub escape_flag_regex { $flag }

sub match_substitute
{
    # This routine relies on there *not* to be an opening <%foo> tag
    # present, so match_block() must happen first.
    
    my $self = shift;

    return 0 unless $self->{current}{comp_source} =~ /\G<%/gcs;

    if ( $self->{current}{comp_source} =~
         m{
           \G
           (.+?)                # Substitution body ($1)
           (
            \s*
            (?                   # Closing tag
          }xcigs )
    {
        $self->{current}{lines} += tr/\n// foreach grep defined, ($1, $2);

        $self->{current}{compiler}->substitution( substitution => $1,
                                                  escape => $3 );
        return 1;
    }
    else
    {
        $self->throw_syntax_error("'<%' without matching '%>'");
    }
}

sub match_comp_call
{
    my $self = shift;

    if ( $self->{current}{comp_source} =~ /\G<&(?!\|)/gcs )
    {
        if ( $self->{current}{comp_source} =~ /\G(.*?)&>/gcs )
        {
            my $call = $1;
            $self->{current}{compiler}->component_call( call => $call );
            $self->{current}{lines} += $call =~ tr/\n//;

            return 1;
        }
        else
        {
            $self->throw_syntax_error("'<&' without matching '&>'");
        }
    }
}


sub match_comp_content_call
{
    my $self = shift;

    if ( $self->{current}{comp_source} =~ /\G<&\|/gcs )
    {
        if ( $self->{current}{comp_source} =~ /\G(.*?)&>/gcs )
        {
            my $call = $1;
            $self->{current}{compiler}->component_content_call( call => $call );
            $self->{current}{lines} += $call =~ tr/\n//;

            return 1;
        }
        else
        {
            $self->throw_syntax_error("'<&|' without matching '&>'");
        }
    }
}

sub match_comp_content_call_end
{
    my $self = shift;

    if ( $self->{current}{comp_source} =~ m,\G,gcs )
    {
        my $call = $1 || '';
        $self->{current}{compiler}->component_content_call_end( call_end => $call );
        $self->{current}{lines} += $call =~ tr/\n//;

        return 1;
    }
}

sub match_perl_line
{
    my $self = shift;

    if ( $self->{current}{comp_source} =~ /\G(?<=^)%([^\n]*)(?:\n|\z)/gcm )
    {
        $self->{current}{compiler}->perl_line( line => $1 );
        $self->{current}{lines}++;

        return 1;
    }
}

sub match_text
{
    my $self = shift;
    my $c = $self->{current};

    # Most of these terminator patterns actually belong to the next
    # lexeme in the source, so we use a lookahead if we don't want to
    # consume them.  We use a lookbehind when we want to consume
    # something in the matched text, like the newline before a '%'.
    if ( $c->{comp_source} =~ m{
                                \G
                                (.*?)         # anything, followed by:
                                (
                                 (?<=\n)(?=%) # an eval line - consume the \n
                                 |
                                 (?=text().  In my testing, this was quite a bit
        # slower, though.  -Ken 2002-09-19
        $c->{compiler}->text( text => $1 ) if length $1;
        # Not checking definedness seems to cause extra lines to be
        # counted with Perl 5.00503.  I'm not sure why - dave
        $c->{lines} += tr/\n// foreach grep defined, ($1, $2);

        return 1;
    }
    
    return 0;
}

sub match_end
{
    my $self = shift;

    # $self->{current}{ending} is a qr// 'string'.  No need to escape.  It will
    # also include the needed \G marker
    if ( $self->{current}{comp_source} =~ /($self->{current}{ending})/gcs )
    {
        $self->{current}{lines} += $1 =~ tr/\n//;
        return defined $1 && length $1 ? $1 : 1;
    }
    return 0;
}

# goes from current pos, skips a newline if its the next character,
# and then goes to the next newline.  Alternately, the caller can
# provide a starting position.
sub _next_line
{
    my $self = shift;
    my $pos = shift;

    $pos = ( defined $pos ?
             $pos :
             ( substr( $self->{current}{comp_source}, pos($self->{current}{comp_source}), 1 ) eq "\n" ?
               pos($self->{current}{comp_source}) + 1 :
               pos($self->{current}{comp_source}) ) );

    my $to_eol = ( index( $self->{current}{comp_source}, "\n", $pos ) != -1 ?
                   ( index( $self->{current}{comp_source}, "\n" , $pos ) ) - $pos :
                   length $self->{current}{comp_source} );
    return substr( $self->{current}{comp_source}, $pos, $to_eol );
}

sub line_number
{
    my $self = shift;

    return $self->{current}{lines};
}

sub name
{
    my $self = shift;

    return $self->{current}{name};
}

sub throw_syntax_error
{
    my ($self, $error) = @_;

    HTML::Mason::Exception::Syntax->throw( error => $error,
                                           comp_name => $self->name,
                                           source_line => $self->_next_line,
                                           line_number => $self->line_number );
}

1;

__END__

=head1 NAME

HTML::Mason::Lexer - Generates events based on component source lexing

=head1 SYNOPSIS

  my $lexer = HTML::Mason::Lexer->new;

  $lexer->lex( comp_source => $source, name => $comp_name, compiler => $compiler );

=head1 DESCRIPTION

The Lexer works in tandem with the Compiler to turn Mason component
source into something else, generally Perl code.

As the lexer finds component elements, like a tag or block, it calls
the appropriate event methods in the compiler object it was given.

It has only a few public methods.

You can replace this lexer with one of your own simply by telling the
Compiler to use a different lexer class.  Your lexer class simply
needs to call the appropriate methods in the Component Class's API as
it scans the source.

=head1 METHODS

The lexer has very few public methods.

=over 4

=item new

This method creates a new Lexer object.  This methods takes no
parameters.

=item lex ( comp_source => ..., name => ..., compiler => ... )

This method tells the lexer to start scanning the given component
source.  All of these parameters are required.  The C parameter
will be used in any error messages generated during lexing.  The
C object must be an object that implements the Mason
Component API.

=item line_number

The current line number that the lexer has reached.

=item name

The name of the component currently being lexed.

=item throw_syntax_error ($error)

This throws an C error with the given
error message as well as additional information about the component
source.

This method is used by both the Lexer and the Compiler.

=back

=head1 SUBCLASSING

Any subclass of the lexer should declare itself to be a subclass of
C, even if it plans to override all of its public
methods.

If you want your subclass to work with the existing Compiler classes
in Mason, you must implement the methods listed above.  If you plan to
use a custom Compiler class that you're writing, you can do whatever
you want.

We recommend that any parameters you add to Lexer be read-only,
because the compiler object_id is only computed once on creation
and would not reflect any changes to Lexer parameters.

=cut
HTML-Mason-1.59/lib/HTML/Mason/Request.pm0000644000175000017500000023312713660015140017510 0ustar  autarchautarch# -*- cperl-indent-level: 4; cperl-continued-brace-offset: -4; cperl-continued-statement-offset: 4 -*-

# 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.


#
# A note about the internals:
#
# Because request is the single most intensively used piece of the
# Mason architecture, this module is often the best target for
# optimization.
#
# By far, the two methods called most often are comp() and print().
# We have attempted to optimize the parts of these methods that handle
# the _normal_ path through the code.
#
# Code paths that are followed less frequently (like the path that
# handles the $mods{store} parameter in comp, for example) are
# intentionally not optimized because doing so would clutter the code
# while providing a minimal benefit.
#
# Many of the optimizations consist of ignoring defined interfaces for
# accessing parts of the request object's internal data structure, and
# instead accessing it directly.
#
# We have attempted to comment these various optimizations
# appropriately, so that future hackers understand that we did indeed
# mean to not use the relevant interface in that particular spot.
#

package HTML::Mason::Request;
$HTML::Mason::Request::VERSION = '1.59';
use strict;
use warnings;

use File::Spec;
use HTML::Mason::Cache::BaseCache;
use HTML::Mason::Plugin::Context;
use HTML::Mason::Tools qw(can_weaken read_file compress_path load_pkg pkg_loaded absolute_comp_path);
use HTML::Mason::Utils;
use Log::Any qw($log);
use Class::Container;
use base qw(Class::Container);

# Stack frame constants
use constant STACK_COMP         => 0;
use constant STACK_ARGS         => 1;
use constant STACK_BUFFER       => 2;
use constant STACK_MODS         => 3;
use constant STACK_PATH         => 4;
use constant STACK_BASE_COMP    => 5;
use constant STACK_IN_CALL_SELF => 6;
use constant STACK_BUFFER_IS_FLUSHABLE => 7;
use constant STACK_HIDDEN_BUFFER => 8;

# HTML::Mason::Exceptions always exports rethrow_exception() and isa_mason_exception()
use HTML::Mason::Exceptions( abbr => [qw(error param_error syntax_error
                                         top_level_not_found_error error)] );

use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } );

BEGIN
{
    __PACKAGE__->valid_params
        (
         args =>
         { type => ARRAYREF, default => [],
           descr => "Array of arguments to initial component",
           public => 0 },

         autoflush =>
         { parse => 'boolean', default => 0, type => SCALAR,
           descr => "Whether output should be buffered or sent immediately" },

         comp =>
         { type => SCALAR | OBJECT, optional => 0,
           descr => "Initial component, either an absolute path or a component object",
           public => 0 },

         data_cache_api =>
         { parse => 'string', default => '1.1', type => SCALAR,
           regex => qr/^(?:1\.0|1\.1|chi)$/,
           descr => "Data cache API to use: 1.0, 1.1, or chi" },

         data_cache_defaults =>
         { parse => 'hash_list', type => HASHREF|UNDEF, optional => 1,
           descr => "A hash of default parameters for Cache::Cache or CHI" },

         declined_comps =>
         { type => HASHREF, optional => 1,
           descr => "Hash of components that have been declined in previous parent requests",
           public => 0 },

         dhandler_name =>
         { parse => 'string', default => 'dhandler', type => SCALAR,
           descr => "The filename to use for Mason's 'dhandler' capability" },

         interp =>
         { isa => 'HTML::Mason::Interp',
           descr => "An interpreter for Mason control functions",
           public => 0 },

         error_format =>
         { parse => 'string', type => SCALAR, default => 'text',
           callbacks => { "HTML::Mason::Exception->can( method )'" =>
                          sub { HTML::Mason::Exception->can("as_$_[0]"); } },
           descr => "How error conditions are returned to the caller (brief, text, line or html)" },

         error_mode =>
         { parse => 'string', type => SCALAR, default => 'fatal',
           regex => qr/^(?:output|fatal)$/,
           descr => "How error conditions are manifest (output or fatal)" },

         component_error_handler =>
         { parse => 'code', type => CODEREF|SCALAR, default => \&rethrow_exception,
           descr => "A subroutine reference called on component compilation or runtime errors" },

         max_recurse =>
         { parse => 'string', default => 32, type => SCALAR,
           descr => "The maximum recursion depth for component, inheritance, and request stack" },

         out_method =>
         { parse => 'code' ,type => CODEREF|SCALARREF,
           default => sub { print STDOUT $_[0] },
           descr => "A subroutine or scalar reference through which all output will pass" },

         # Only used when creating subrequests
         parent_request =>
         { isa => __PACKAGE__,
           default => undef,
           public  => 0,
         },

         plugins =>
         { parse => 'list', default => [], type => ARRAYREF,
           descr => 'List of plugin classes or objects to run hooks around components and requests' },

         # Only used when creating subrequests
         request_depth =>
         { type => SCALAR,
           default => 1,
           public  => 0,
         },

        );
}

my @read_write_params;
BEGIN { @read_write_params = qw(
                                autoflush
                                component_error_handler
                                data_cache_api
                                data_cache_defaults
                                dhandler_name
                                error_format
                                error_mode
                                max_recurse
                                out_method
                                ); }

use HTML::Mason::MethodMaker
    ( read_only => [ qw(
                        count
                        dhandler_arg
                        initialized
                        interp
                        parent_request
                        plugin_instances
                        request_depth
                        request_comp
                        ) ],

      read_write => [ map { [ $_ => __PACKAGE__->validation_spec->{$_} ] }
                      @read_write_params ]
    );

sub _properties { @read_write_params }

sub new
{
    my $class = shift;
    my $self = $class->SUPER::new(@_);

    # These are mandatory values for all requests.
    #
    %$self = (%$self,
              dhandler_arg   => undef,
              execd          => 0,
              initialized    => 0,
              stack          => [],
              top_stack      => undef,
              wrapper_chain  => undef,
              wrapper_index  => undef,
              notes          => {},
              );

    $self->{request_comp} = delete($self->{comp});
    $self->{request_args} = delete($self->{args});
    if (UNIVERSAL::isa($self->{request_args}, 'HASH')) {
        $self->{request_args} = [%{$self->{request_args}}];
    }
    $self->{count} = ++$self->{interp}{request_count};
    if (ref($self->{out_method}) eq 'SCALAR') {
        my $bufref = $self->{out_method};
        $self->{out_method} = sub { $$bufref .= $_[0] };
    }
    $self->{use_internal_component_caches} =
        $self->{interp}->use_internal_component_caches;
    $self->_initialize;

    return $self;
}

# in the future this method may do something completely different but
# for now this works just fine.
sub instance {
    return $HTML::Mason::Commands::m; #; this comment fixes a parsing bug in Emacs cperl-mode
}

# Attempt to load each plugin module once per process
my %plugin_loaded;

sub _initialize {
    my ($self) = @_;

    local $SIG{'__DIE__'} = $self->component_error_handler
        if $self->component_error_handler;

    eval {
        # Check the static_source touch file, if it exists, before the
        # first component is loaded.
        #
        $self->interp->check_static_source_touch_file();

        # request_comp can be an absolute path or component object.  If a path,
        # load into object.
        my $request_comp = $self->{request_comp};
        my ($path);
        if (!ref($request_comp)) {
            $request_comp =~ s{/+}{/}g;
            $self->{top_path} = $path = $request_comp;
            $log->debugf("top path is '%s'", $self->{top_path})
                if $log->is_debug;

            my $retry_count = 0;
            search: {
                $request_comp = $self->interp->load($path);

                last search unless $self->use_dhandlers;

                # If path was not found, check for dhandler.
                unless ($request_comp) {
                    if ( $request_comp = $self->interp->find_comp_upwards($path, $self->dhandler_name) ) {
                        my $parent_path = $request_comp->dir_path;
                        ($self->{dhandler_arg} = $self->{top_path}) =~ s{^$parent_path/?}{};
                        $log->debugf("found dhandler '%s', dhandler_arg '%s'", $parent_path, $self->{dhandler_arg})
                            if $log->is_debug;
                    }
                }

                # If the component was declined previously in this
                # request, look for the next dhandler up the
                # tree. 
                if ($request_comp and $self->{declined_comps}->{$request_comp->comp_id}) {
                    $path = $request_comp->dir_path;
                    if ($request_comp->name eq $self->dhandler_name) {
                        if ($path eq '/') {
                            undef $request_comp;
                            last search;  # End search if /dhandler declined
                        } else {
                            $path =~ s:/[^\/]+$::;
                            $path ||= '/';
                        }
                    }
                    if ($retry_count++ > $self->max_recurse) {
                        error "could not find dhandler after " . $self->max_recurse . " tries (infinite loop bug?)";
                    }
                    redo search;
                }
            }

            unless ($self->{request_comp} = $request_comp) {
                top_level_not_found_error "could not find component for initial path '$self->{top_path}' " .
                    "(component roots are: " .
                    join(", ", map { "'" . $_->[1] . "'" } $self->{interp}->comp_root_array) .
                    ")";
            }

        } elsif ( ! UNIVERSAL::isa( $request_comp, 'HTML::Mason::Component' ) ) {
            param_error "comp ($request_comp) must be a component path or a component object";
        }

        # Construct a plugin instance for each plugin class in each request.
        #
        $self->{has_plugins} = 0;
        $self->{plugin_instances} = [];
        foreach my $plugin (@{ delete $self->{plugins} }) {
            $self->{has_plugins} = 1;
            my $plugin_instance = $plugin;
            unless (ref $plugin) {

                # Load information about each plugin class once per
                # process.  Right now the only information we need is
                # whether there is a new() method.
                #
                unless ($plugin_loaded{$plugin}) {
                    # Load plugin package if it isn't already loaded.
                    #
                    {
                        no strict 'refs';
                        unless (keys %{$plugin . "::"}) {
                            eval "use $plugin;";
                            die $@ if $@;
                        }
                    }
                    $plugin_loaded{$plugin} = 1;
                }
                $plugin_instance = $plugin->new();
            }
            push @{$self->{plugin_instances}}, $plugin_instance;
        }
        $self->{plugin_instances_reverse} = [reverse(@{$self->{plugin_instances}})];

        # Check for autoflush and !enable_autoflush
        #
        if ($self->{autoflush} && !$self->interp->compiler->enable_autoflush) {
            die "Cannot use autoflush unless enable_autoflush is set";
        }

    };

    my $err = $@;
    if ($err and !$self->_aborted_or_declined($err)) {
        $self->_handle_error($err);
    } else {
        $self->{initialized} = 1;
    }
}

sub use_dhandlers
{
    my $self = shift;
    return (defined $self->{dhandler_name} and length $self->{dhandler_name});
}

sub alter_superclass
{
    my $self = shift;
    my $new_super = shift;

    my $class = caller;

    my $isa_ref;
    {
        no strict 'refs';
        my @isa = @{ $class . '::ISA' };
        $isa_ref = \@isa;
    }

    # handles multiple inheritance properly and preserve
    # inheritance order
    for ( my $x = 0; $x <= $#{$isa_ref} ; $x++ )
    {
        if ( $isa_ref->[$x]->isa('HTML::Mason::Request') )
        {
            my $old_super = $isa_ref->[$x];

            if ( $old_super ne $new_super )
            {
                $isa_ref->[$x] = $new_super;
            }

            last;
        }
    }

    {
        no strict 'refs';
        @{ $class . '::ISA' } = @{ $isa_ref };
    }

    $class->valid_params( %{ $class->valid_params } );
}

sub exec {
    my ($self) = @_;

    # If the request failed to initialize, the error has already been handled
    # at the bottom of _initialize(); just return.
    return unless $self->initialized();

    local $SIG{'__DIE__'} = $self->component_error_handler
        if $self->component_error_handler;

    # Cheap way to prevent users from executing the same request twice.
    #
    if ($self->{execd}++) {
        error "Can only call exec() once for a given request object. Did you want to use a subrequest?";
    }

    # Check for infinite subrequest loop.
    #
    error "subrequest depth > " . $self->max_recurse . " (infinite subrequest loop?)"
        if $self->request_depth > $self->max_recurse;

    #
    # $m is a dynamically scoped global containing this
    # request. This needs to be defined in the HTML::Mason::Commands
    # package, as well as the component package if that is different.
    #
    local $HTML::Mason::Commands::m = $self;

    # Dynamically scoped global pointing at the top of the request stack.
    #
    $self->{top_stack} = undef;

    # Save context of subroutine for use inside eval.
    my $wantarray = wantarray;
    my @result;

    # Initialize output buffer to interpreter's preallocated buffer
    # before clearing, to reduce memory reallocations.
    #
    $self->{request_buffer} = $self->interp->preallocated_output_buffer;
    $self->{request_buffer} = '';

    $log->debugf("starting request for '%s'", $self->request_comp->title)
        if $log->is_debug;

    eval {
        # Build wrapper chain and index.
        my $request_comp = $self->request_comp;
        my $first_comp;
        {
            my @wrapper_chain = ($request_comp);

            for (my $parent = $request_comp->parent; $parent; $parent = $parent->parent) {
                unshift(@wrapper_chain,$parent);
                error "inheritance chain length > " . $self->max_recurse . " (infinite inheritance loop?)"
                    if (@wrapper_chain > $self->max_recurse);
            }

            $first_comp = $wrapper_chain[0];
            $self->{wrapper_chain} = [@wrapper_chain];
            $self->{wrapper_index} = { map
                                       { $wrapper_chain[$_]->comp_id => $_ }
                                       (0..$#wrapper_chain)
                                     };
        }

        # Get original request_args array reference to avoid copying.
        my $request_args = $self->{request_args};
        {
            local *SELECTED;
            tie *SELECTED, 'Tie::Handle::Mason';

            my $old = select SELECTED;
            my $mods = {base_comp => $request_comp, store => \($self->{request_buffer}), flushable => 1};

            if ($self->{has_plugins}) {
                my $context = bless
                    [$self, $request_args],
                    'HTML::Mason::Plugin::Context::StartRequest';
                eval {
                    foreach my $plugin_instance (@{$self->plugin_instances}) {
                        $plugin_instance->start_request_hook( $context );
                    }
                };
                if ($@) {
                    select $old;
                    rethrow_exception $@;
                }
            }

            if ($wantarray) {
                @result = eval {$self->comp($mods, $first_comp, @$request_args)};
            } elsif (defined($wantarray)) {
                $result[0] = eval {$self->comp($mods, $first_comp, @$request_args)};
            } else {
                eval {$self->comp($mods, $first_comp, @$request_args)};
            }
 
            my $error = $@;

            if ($self->{has_plugins}) {
                # plugins called in reverse order when exiting.
                my $context = bless
                    [$self, $request_args, \$self->{request_buffer}, $wantarray, \@result, \$error],
                    'HTML::Mason::Plugin::Context::EndRequest';
                eval {
                    foreach my $plugin_instance (@{$self->{plugin_instances_reverse}}) {
                        $plugin_instance->end_request_hook( $context );
                    }
                };
                if ($@) {
                    # plugin errors take precedence over component errors
                    $error = $@;
                }
            }
            
            select $old;
            rethrow_exception $error;
        }
    };

    $log->debugf("finishing request for '%s'", $self->request_comp->title)
        if $log->is_debug;

    # Purge code cache if necessary.
    $self->interp->purge_code_cache;

    # Handle errors.
    my $err = $@;
    if ($err and !$self->_aborted_or_declined($err)) {
        $self->_handle_error($err);
        return;
    }

    # If there's anything in the output buffer, send it to out_method.
    # Otherwise skip out_method call to avoid triggering side effects
    # (e.g. HTTP header sending).
    if (length($self->{request_buffer}) > 0) {
        $self->out_method->($self->{request_buffer});
    }

    # Return aborted value or result.
    @result = ($err->aborted_value) if $self->aborted($err);
    @result = ($err->declined_value) if $self->declined($err);
    return $wantarray ? @result : defined($wantarray) ? $result[0] : undef;
}

#
# Display or die with error as dictated by error_mode and error_format.
#
sub _handle_error
{
    my ($self, $err) = @_;

    $self->interp->purge_code_cache;

    rethrow_exception $err if $self->is_subrequest;

    # Set error format for when error is stringified.
    if (UNIVERSAL::can($err, 'format')) {
        $err->format($self->error_format);
    }

    # In fatal mode, die with error. In display mode, output stringified error.
    if ($self->error_mode eq 'fatal') {
        rethrow_exception $err;
    } else {
        if ( UNIVERSAL::isa( $self->out_method, 'CODE' ) ) {
            # This may not be set if an error occurred in
            # _initialize(), for example with a compilation error.
            # But the output method may rely on being able to get at
            # the request object.  This is a nasty code smell but
            # fixing it properly is probably out of scope.
            #
            # Previously this method could only be called from exec().
            #
            # Without this one of the tests in 16-live_cgi.t was
            # failing.
            local $HTML::Mason::Commands::m ||= $self;
            $self->out_method->("$err");
        } else {
            ${ $self->out_method } = "$err";
        }
    }
}

sub subexec
{
    my $self = shift;
    my $comp = shift;

    $self->make_subrequest(comp=>$comp, args=>\@_)->exec;
}

sub make_subrequest
{
    my ($self, %params) = @_;
    my $interp = $self->interp;

    # Coerce a string 'comp' parameter into an absolute path.  Don't
    # create it if it's missing, though - it's required, but for
    # consistency we let exceptions be thrown later.
    $params{comp} = absolute_comp_path($params{comp}, $self->current_comp->dir_path)
        if exists $params{comp} && !ref($params{comp});

    # Give subrequest the same values as parent request for read/write params
    my %defaults = map { ($_, $self->$_()) } $self->_properties;

    unless ( $params{out_method} )
    {
        $defaults{out_method} = sub {
            $self->print($_[0]);
        };
    }

    # Make subrequest, and set parent_request and request_depth appropriately.
    my $subreq =
        $interp->make_request(%defaults, %params,
                              parent_request => $self,
                              request_depth => $self->request_depth + 1);

    return $subreq;
}

sub is_subrequest
{
    my ($self) = @_;

    return $self->parent_request ? 1 : 0;
}

sub clear_and_abort
{
    my $self = shift;

    $self->clear_buffer;
    $self->abort(@_);
}

sub abort
{
    my ($self, $aborted_value) = @_;
    HTML::Mason::Exception::Abort->throw( error => 'Request->abort was called', aborted_value => $aborted_value );
}

#
# Determine whether $err (or $@ by default) is an Abort exception.
#
sub aborted {
    my ($self, $err) = @_;
    $err = $@ if !defined($err);
    return isa_mason_exception( $err, 'Abort' );
}

#
# Determine whether $err (or $@ by default) is an Decline exception.
#
sub declined {
    my ($self, $err) = @_;
    $err = $@ if !defined($err);
    return isa_mason_exception( $err, 'Decline' );
}

sub _aborted_or_declined {
    my ($self, $err) = @_;
    return $self->aborted($err) || $self->declined($err);
}

#
# Return a new cache object specific to this component.
#
sub cache
{
    my ($self, %options) = @_;

    # If using 1.0x cache API, save off options for end of routine.
    my %old_cache_options;
    if ($self->data_cache_api eq '1.0') {
        %old_cache_options = %options;
        %options = ();
    }

    # Combine defaults with options passed in here.
    if ($self->data_cache_defaults) {
        %options = (%{$self->data_cache_defaults}, %options);
    }

    # If using the CHI API, just create and return a CHI handle. Namespace will be escaped by CHI.
    if ($self->data_cache_api eq 'chi') {
        my $chi_root_class = delete($options{chi_root_class}) || 'CHI';
        load_pkg($chi_root_class);
        if (!exists($options{namespace})) {
            $options{namespace} = $self->current_comp->comp_id;
        }
        if (!exists($options{driver}) && !exists($options{driver_class})) {
            $options{driver} = $self->interp->cache_dir ? 'File' : 'Memory';
            $options{global} = 1 if $options{driver} eq 'Memory';            
        }
        $options{root_dir} ||= $self->interp->cache_dir;
        return $chi_root_class->new(%options);
    }

    $options{cache_root} ||= $self->interp->cache_dir;
    $options{namespace}  ||= compress_path($self->current_comp->comp_id);

    # Determine cache_class, adding 'Cache::' in front of user's
    # specification if necessary.
    my $cache_class = $self->interp->cache_dir ? 'Cache::FileCache' : 'Cache::MemoryCache';
    if ($options{cache_class}) {
        $cache_class = $options{cache_class};
        $cache_class = "Cache::$cache_class" unless $cache_class =~ /::/;
        delete($options{cache_class});
    }

    # Now prefix cache class with "HTML::Mason::". This will be a
    # dynamically constructed package that simply inherits from
    # HTML::Mason::Cache::BaseCache and the chosen cache class.
    my $mason_cache_class = "HTML::Mason::$cache_class";
    unless (pkg_loaded($mason_cache_class)) {
        load_pkg('Cache::Cache', '$m->cache requires the Cache::Cache module, available from CPAN.');
        load_pkg($cache_class, 'Fix your Cache::Cache installation or choose another cache class.');
        # need to break up mention of VERSION var or else CPAN/EU::MM can choke when running 'r'
        eval sprintf('package %s; use base qw(HTML::Mason::Cache::BaseCache %s); use vars qw($' . 'VERSION); $' . 'VERSION = 1.0;',
                     $mason_cache_class, $cache_class);
        error "Error constructing mason cache class $mason_cache_class: $@" if $@;
    }

    my $cache = $mason_cache_class->new (\%options)
        or error "could not create cache object";

    # Implement 1.0x cache API or just return cache object.
    if ($self->data_cache_api eq '1.0') {
        return $self->_cache_1_x($cache, %old_cache_options);
    } else {
        return $cache;
    }
}

#
# Implement 1.0x cache API in terms of Cache::Cache.
# Supported: action, busy_lock, expire_at, expire_if, expire_in, expire_next, key, value
# Silently not supported: keep_in_memory, tie_class
#
sub _cache_1_x
{
    my ($self, $cache, %options) = @_;

    my $action = $options{action} || 'retrieve';
    my $key = $options{key} || 'main';
    
    if ($action eq 'retrieve') {
        
        # Validate parameters.
        if (my @invalids = grep(!/^(expire_if|action|key|busy_lock|keep_in_memory|tie_class)$/, keys(%options))) {
            param_error "cache: invalid parameter '$invalids[0]' for action '$action'\n";
        }

        # Handle expire_if.
        if (my $sub = $options{expire_if}) {
            if (my $obj = $cache->get_object($key)) {
                if ($sub->($obj->get_created_at)) {
                    $cache->expire($key);
                }
            }
        }

        # Return the value or undef, handling busy_lock.
        if (my $result = $cache->get($key, ($options{busy_lock} ? (busy_lock=>$options{busy_lock}) : ()))) {
            return $result;
        } else {
            return undef;
        }

    } elsif ($action eq 'store') {

        # Validate parameters   
        if (my @invalids = grep(!/^(expire_(at|next|in)|action|key|value|keep_in_memory|tie_class)$/, keys(%options))) {
            param_error "cache: invalid parameter '$invalids[0]' for action '$action'\n";
        }
        param_error "cache: no store value provided" unless exists($options{value});

        # Determine $expires_in if expire flag given. For the "next"
        # options, we're jumping through hoops to find the *top* of
        # the next hour or day.
        #
        my $expires_in;
        my $time = time;
        if (exists($options{expire_at})) {
            param_error "cache: invalid expire_at value '$options{expire_at}' - must be a numeric time value\n" if $options{expire_at} !~ /^[0-9]+$/;
            $expires_in = $options{expire_at} - $time;
        } elsif (exists($options{expire_next})) {
            my $term = $options{expire_next};
            my ($sec, $min, $hour) = localtime($time);
            if ($term eq 'hour') {
                $expires_in = 60*(59-$min)+(60-$sec);
            } elsif ($term eq 'day') {
                $expires_in = 3600*(23-$hour)+60*(59-$min)+(60-$sec);
            } else {
                param_error "cache: invalid expire_next value '$term' - must be 'hour' or 'day'\n";
            }
        } elsif (exists($options{expire_in})) {
            $expires_in = $options{expire_in};
        }

        # Set and return the value.
        my $value = $options{value};
        $cache->set($key, $value, $expires_in);
        return $value;

    } elsif ($action eq 'expire') {
        my @keys = (ref($key) eq 'ARRAY') ? @$key : ($key);
        foreach my $key (@keys) {
            $cache->expire($key);
        }

    } elsif ($action eq 'keys') {
        return $cache->get_keys;
    }
}

sub cache_self {
    my ($self, %options) = @_;

    return if $self->{top_stack}->[STACK_IN_CALL_SELF]->{'CACHE_SELF'};

    my (%store_options, %retrieve_options);
    my ($expires_in, $key, $cache);
    if ($self->data_cache_api eq '1.0') {
        foreach (qw(key expire_if busy_lock)) {
            $retrieve_options{$_} = $options{$_} if (exists($options{$_}));
        }
        foreach (qw(key expire_at expire_next expire_in)) {
            $store_options{$_} = $options{$_} if (exists($options{$_}));
        }
    } else {
        #
        # key, expires_in/expire_in, expire_if and busy_lock go into
        # the set and get methods as appropriate. All other options
        # are passed into $self->cache.
        #
        foreach (qw(expire_if busy_lock)) {
            $retrieve_options{$_} = delete($options{$_}) if (exists($options{$_}));
        }
        $expires_in = delete $options{expires_in} || delete $options{expire_in} || 'never';
        $key = delete $options{key} || '__mason_cache_self__';
        $cache = $self->cache(%options);
    }

    my ($output, @retval, $error);

    my $cached =
        ( $self->data_cache_api eq '1.0' ?
          $self->cache(%retrieve_options) :
          $cache->get($key, %retrieve_options)
        );

    if ($cached) {
        ($output, my $retval) = @$cached;
        @retval = @$retval;
    } else {
        $self->call_self( \$output, \@retval, \$error, 'CACHE_SELF' );

        # If user aborted or declined, store in cache and print output
        # before repropagating.
        #
        rethrow_exception $error
            unless ($self->_aborted_or_declined($error));

        my $value = [$output, \@retval];
        if ($self->data_cache_api eq '1.0') {
            $self->cache(action=>'store', key=>$key, value=>$value, %store_options);
        } else {
            $cache->set($key, $value, $expires_in);
        }
    }

    #
    # Print the component output.
    #
    $self->print($output);

    #
    # Rethrow abort/decline exception if any.
    #
    rethrow_exception $error;

    #
    # Return the component return value in case the caller is interested,
    # followed by 1 indicating the cache retrieval success.
    #
    return (@retval, 1);
}

sub call_self
{
    my ($self, $output, $retval, $error, $tag) = @_;

    # Keep track of each individual invocation of call_self in the
    # component, via $tag.  $tag is 'CACHE_SELF' or 'FILTER' when used
    # by $m->cache_self and <%filter> sections respectively.
    #
    $tag ||= 'DEFAULT';
    my $top_stack = $self->{top_stack};
    $top_stack->[STACK_IN_CALL_SELF] ||= {};
    return if $top_stack->[STACK_IN_CALL_SELF]->{$tag};
    local $top_stack->[STACK_IN_CALL_SELF]->{$tag} = 1;

    # Determine wantarray based on retval reference
    my $wantarray =
        ( defined $retval ?
          ( UNIVERSAL::isa( $retval, 'ARRAY' ) ? 1 : 0 ) :
          undef
          );

    # If output or retval references were left undefined, just point
    # them to a dummy variable.
    #
    my $dummy;
    $output ||= \$dummy;
    $retval ||= \$dummy;

    # Temporarily put $output in place of the current top buffer.
    local $top_stack->[STACK_BUFFER] = $output;

    # Call the component again, capturing output, return value and
    # error. Don't catch errors unless the error reference was specified.
    #
    my $comp = $top_stack->[STACK_COMP];
    my $args = $top_stack->[STACK_ARGS];
    my @result;
    eval {
        if ($wantarray) {
            @$retval = $comp->run(@$args);
        } elsif (defined $wantarray) {
            $$retval = $comp->run(@$args);
        } else {
            $comp->run(@$args);
        }
    };
    if ($@) {
        if ($error) {
            $$error = $@;
        } else {
            die $@;
        }
    }

    # Return 1, indicating that this invocation of call_self is done.
    #
    return 1;
}

sub call_dynamic {
    my ($m, $key, @args) = @_;
    my $comp = ($m->current_comp->is_subcomp) ? $m->current_comp->owner : $m->current_comp;
    if (!defined($comp->dynamic_subs_request) or $comp->dynamic_subs_request ne $m) {
        $comp->dynamic_subs_init;
        $comp->dynamic_subs_request($m);
    }

    return $comp->run_dynamic_sub($key, @args);
}

sub call_next {
    my ($self,@extra_args) = @_;
    my $comp = $self->fetch_next
        or error "call_next: no next component to invoke";
    return $self->comp({base_comp=>$self->request_comp}, $comp, @{$self->current_args}, @extra_args);
}

sub caller
{
    my ($self) = @_;
    return $self->callers(1);
}

#
# Return a specified component from the stack, or the whole stack as a list.
#
sub callers
{
    my ($self, $levels_back) = @_;
    if (defined($levels_back)) {
        my $frame = $self->_stack_frame($levels_back);
        return unless defined $frame;
        return $frame->[STACK_COMP];
    } else {
        my $depth = $self->depth;
        return map($_->[STACK_COMP], $self->_stack_frames);
    }
}

#
# Return a specified argument list from the stack.
#
sub caller_args
{
    my ($self, $levels_back) = @_;
    param_error "caller_args expects stack level as argument" unless defined $levels_back;

    my $frame = $self->_stack_frame($levels_back);
    return unless $frame;
    my $args = $frame->[STACK_ARGS];
    return wantarray ? @$args : { @$args };
}

sub comp_exists
{
    my ($self, $path) = @_;

    # In order to support SELF, PARENT, REQUEST, subcomponents and
    # methods, it is easiest just to defer to fetch_comp.
    #
    return $self->fetch_comp($path) ? 1 : 0;
}

sub decline
{
    my ($self) = @_;

    $self->clear_buffer;
    my $subreq = $self->make_subrequest
        (comp => $self->{top_path},
         args => $self->{request_args},
         declined_comps => {$self->request_comp->comp_id, 1, %{$self->{declined_comps}}});
    my $retval = $subreq->exec;
    HTML::Mason::Exception::Decline->throw( error => 'Request->decline was called', declined_value => $retval );
}

#
# Return the current number of stack levels. 1 means top level, 0
# means that no component has been called yet.
#
sub depth
{
    return scalar @{ $_[0]->{stack} };
}

#
# Given a component path (absolute or relative), returns a component.
# Handles SELF, PARENT, REQUEST, comp:method, relative->absolute
# conversion, and local subcomponents.
#
# fetch_comp handles caching if use_internal_component_caches is on.
# _fetch_comp does the real work.
#
sub fetch_comp
{
    my ($self, $path, $current_comp, $error, $exists_only) = @_;

    return undef unless defined($path);
    $current_comp ||= $self->{top_stack}->[STACK_COMP];

    return $self->_fetch_comp($path, $current_comp, $error)
        unless $self->{use_internal_component_caches};

    my $fetch_comp_cache = $current_comp->{fetch_comp_cache};
    unless (defined($fetch_comp_cache->{$path})) {

        # Cache the component objects associated with
        # uncanonicalized paths like ../foo/bar.html.  SELF and
        # REQUEST are dynamic and cannot be cached. Weaken the
        # references in this cache so that we don't hang on to the
        # coponent if it disappears from the main code cache.
        #
        # See Interp::_initialize for the definition of
        # use_internal_component_caches and the conditions under
        # which we can create this cache safely.
        #
        if ($path =~ /^(?:SELF|REQUEST)/) {
            return $self->_fetch_comp($path, $current_comp, $error);
        } else {
            $fetch_comp_cache->{$path} =
                $self->_fetch_comp($path, $current_comp, $error);
            Scalar::Util::weaken($fetch_comp_cache->{$path}) if can_weaken;
        }
    }

    return $fetch_comp_cache->{$path};
}

sub _fetch_comp
{
    my ($self, $path, $current_comp, $error) = @_;

    #
    # Handle paths SELF, PARENT, and REQUEST
    #
    if ($path eq 'SELF') {
        return $self->base_comp;
    }
    if ($path eq 'PARENT') {
        my $c = $current_comp->parent;
        $$error = "PARENT designator used from component with no parent" if !$c && defined($error);
        return $c;
    }
    if ($path eq 'REQUEST') {
        return $self->request_comp;
    }

    #
    # Handle paths of the form comp_path:method_name
    #
    if (index($path,':') != -1) {
        my $method_comp;
        my ($owner_path,$method_name) = split(':',$path,2);
        if (my $owner_comp = $self->fetch_comp($owner_path, $current_comp, $error)) {
            if ($owner_comp->_locate_inherited('methods',$method_name,\$method_comp)) {
                return $method_comp;
            } else {
                $$error = "no such method '$method_name' for component " . $owner_comp->title if defined($error);
            }
        } else {
            $$error ||= "could not find component for path '$owner_path'\n" if defined($error);
        }

        return $method_comp;
    }

    #
    # If path does not contain a slash, check for a subcomponent in the
    # current component first.
    #
    if ($path !~ /\//) {
        # Check my subcomponents.
        if (my $subcomp = $current_comp->subcomps($path)) {
            return $subcomp;
        }
        # If I am a subcomponent, also check my owner's subcomponents.
        # This won't work when we go to multiply embedded subcomponents...
        if ($current_comp->is_subcomp and my $subcomp = $current_comp->owner->subcomps($path)) {
            return $subcomp;
        }
    }

    #
    # Otherwise pass the canonicalized absolute path to interp->load.
    #
    $path = absolute_comp_path($path, $current_comp->dir_path);
    my $comp = $self->interp->load($path);

    return $comp;
}

#
# Fetch the index of the next component in wrapper chain. If current
# component is not in chain, search the component stack for the most
# recent one that was.
#
sub _fetch_next_helper {
    my ($self) = @_;
    my $index = $self->{wrapper_index}->{$self->current_comp->comp_id};
    unless (defined($index)) {
        my @callers = $self->callers;
        shift(@callers);
        while (my $comp = shift(@callers) and !defined($index)) {
            $index = $self->{wrapper_index}->{$comp->comp_id};
        }
    }
    return $index;
}

#
# Fetch next component in wrapper chain.
#
sub fetch_next {
    my ($self) = @_;
    my $index = $self->_fetch_next_helper;
    error "fetch_next: cannot find next component in chain"
        unless defined($index);
    return $self->{wrapper_chain}->[$index+1];
}

#
# Fetch remaining components in wrapper chain.
#
sub fetch_next_all {
    my ($self) = @_;
    my $index = $self->_fetch_next_helper;
    error "fetch_next_all: cannot find next component in chain"
        unless defined($index);
    my @wc = @{$self->{wrapper_chain}};
    return @wc[($index+1)..$#wc];
}

sub file
{
    my ($self,$file) = @_;
    my $interp = $self->interp;
    unless ( File::Spec->file_name_is_absolute($file) ) {
        # use owner if current comp is a subcomp
        my $context_comp =
            ( $self->current_comp->is_subcomp ?
              $self->current_comp->owner :
              $self->current_comp );

        if ($context_comp->is_file_based) {
            my $source_dir = $context_comp->source_dir;
            $file = File::Spec->catfile( $source_dir, $file );
        } else {
            $file = File::Spec->catfile( File::Spec->rootdir, $file );
        }
    }
    my $content = read_file($file,1);
    return $content;
}

sub print
{
    my $self = shift;

    # $self->{top_stack} is always defined _except_ in the case of a
    # call to print inside a start-/end-request plugin.
    my $bufref =
        ( defined $self->{top_stack}
          ? $self->{top_stack}->[STACK_BUFFER]
          : \$self->{request_buffer}
        );

    # use 'if defined' for maximum efficiency; grep creates a list.
    for ( @_ ) {
        $$bufref .= $_ if defined;
    }

    $self->flush_buffer if $self->{autoflush};
}

*out = \&print;

#
# Execute the given component
#
sub comp {
    my $self = shift;
    my $log_is_debug = $log->is_debug;

    # Get modifiers: optional hash reference passed in as first argument.
    # Merge multiple hash references to simplify user and internal usage.
    #
    my %mods;
    %mods = (%{shift()}, %mods) while ref($_[0]) eq 'HASH';

    # Get component path or object. If a path, load into object.
    #
    my $path;
    my $comp = shift;
    if (!ref($comp)) {
        die "comp called without component - must pass a path or component object"
            unless defined($comp);
        $path = $comp;
        my $error;
        $comp = $self->fetch_comp($path, undef, \$error)
            or error($error || "could not find component for path '$path'\n");
    }

    # Increment depth and check for maximum recursion. Depth starts at 1.
    #
    my $depth = $self->depth;
    error "$depth levels deep in component stack (infinite recursive call?)\n"
        if $depth >= $self->{max_recurse};

    # Log start of component call.
    #
    $log->debugf("entering component '%s' [depth %d]", $comp->title(), $depth)
        if $log_is_debug;

    # Keep the same output buffer unless store modifier was passed. If we have
    # a filter, put the filter buffer on the stack instead of the regular buffer.
    #
    my $filter_buffer = '';
    my $top_buffer = defined($mods{store}) ? $mods{store} : $self->{top_stack}->[STACK_BUFFER];
    my $stack_buffer = $comp->{has_filter} ? \$filter_buffer : $top_buffer;
    my $flushable = exists $mods{flushable} ? $mods{flushable} : ($self->{top_stack}->[STACK_BUFFER_IS_FLUSHABLE] && ! defined($mods{store})) ;

    # Add new stack frame and point dynamically scoped $self->{top_stack} at it.
    push @{ $self->{stack} },
        [ $comp,           # STACK_COMP
          \@_,             # STACK_ARGS
          $stack_buffer,   # STACK_BUFFER
          \%mods,          # STACK_MODS
          $path,           # STACK_PATH
          undef,           # STACK_BASE_COMP
          undef,           # STACK_IN_CALL_SELF
          $flushable,      # STACK_BUFFER_IS_FLUSHABLE
        ];
    local $self->{top_stack} = $self->{stack}->[-1];

    # Run start_component hooks for each plugin.
    #
    if ($self->{has_plugins}) {
        my $context = bless
            [$self, $comp, \@_],
            'HTML::Mason::Plugin::Context::StartComponent';

        foreach my $plugin_instance (@{$self->{plugin_instances}}) {
            $plugin_instance->start_component_hook( $context );
        }
    }

    # Finally, call the component.
    #
    my $wantarray = wantarray;
    my @result;
    
    eval {
        # By putting an empty block here, we protect against stack
        # corruption when a component calls next or last outside of a
        # loop. See 05-request.t #28 for a test.
        {
            if ($wantarray) {
                @result = $comp->run(@_);
            } elsif (defined $wantarray) {
                $result[0] = $comp->run(@_);
            } else {
                $comp->run(@_);
            }
        }
    };
    my $error = $@;

    # Run component's filter if there is one, and restore true top buffer
    # (e.g. in case a plugin prints something).
    #
    if ($comp->{has_filter}) {
        # We have to check $comp->filter because abort or error may
        # occur before filter gets defined in component. In such cases
        # there should be no output, but should look into this more.
        #
        if (defined($comp->filter)) {
            $$top_buffer .= $comp->filter->($filter_buffer);
        }
        $self->{top_stack}->[STACK_BUFFER] = $top_buffer;
    }

    # Run end_component hooks for each plugin, in reverse order.
    #
    if ($self->{has_plugins}) {
        my $context = bless
            [$self, $comp, \@_, $wantarray, \@result, \$error],
            'HTML::Mason::Plugin::Context::EndComponent';
        
        foreach my $plugin_instance (@{$self->{plugin_instances_reverse}}) {
            $plugin_instance->end_component_hook( $context );
        }
    }

    # This is very important in order to avoid memory leaks, since we
    # stick the arguments on the stack. If we don't pop the stack,
    # they don't get cleaned up until the component exits.
    pop @{ $self->{stack} };

    # Log end of component call.
    #
    $log->debug(sprintf("exiting component '%s' [depth %d]", $comp->title(), $depth))
        if $log_is_debug;

    # Repropagate error if one occurred, otherwise return result.
    rethrow_exception $error if $error;
    return $wantarray ? @result : $result[0];
}

#
# Like comp, but return component output.
#
sub scomp {
    my $self = shift;
    my $buf;
    $self->comp({store => \$buf},@_);
    return $buf;
}

sub has_content {
    my $self = shift;
    return defined($self->{top_stack}->[STACK_MODS]->{content});
}

sub content {
    my $self = shift;
    my $content = $self->{top_stack}->[STACK_MODS]->{content};
    return undef unless defined($content);

    # Run the content routine with the previous stack frame active and
    # with output going to a new buffer.
    #
    my $err;
    my $buffer;
    my $save_frame = pop @{ $self->{stack} };
    {
        local $self->{top_stack} = $self->{stack}[-1];
        local $self->{top_stack}->[STACK_BUFFER] = \$buffer;
        local $self->{top_stack}->[STACK_BUFFER_IS_FLUSHABLE] = 0;
        local $self->{top_stack}->[STACK_HIDDEN_BUFFER] = $save_frame->[STACK_BUFFER];
        eval { $content->(); };
        $err = $@;
    }

    push @{ $self->{stack} }, $save_frame;

    rethrow_exception $err;

    # Return the output from the content routine.
    #
    return $buffer;
}

sub notes {
  my $self = shift;
  return $self->{notes} unless @_;
  
  my $key = shift;
  return $self->{notes}{$key} unless @_;
  
  return $self->{notes}{$key} = shift;
}

sub clear_buffer
{
    my $self = shift;

    foreach my $frame (@{$self->{stack}}) {
        my $bufref = $frame->[STACK_BUFFER];
        $$bufref = '';
        $bufref = $frame->[STACK_HIDDEN_BUFFER];
        $$bufref = '' if $bufref;
    }
}

sub flush_buffer
{
    my $self = shift;

    $self->out_method->($self->{request_buffer})
        if length $self->{request_buffer};
    $self->{request_buffer} = '';

    if ( $self->{top_stack}->[STACK_BUFFER_IS_FLUSHABLE]
         && $self->{top_stack}->[STACK_BUFFER] )
    {
        my $comp = $self->{top_stack}->[STACK_COMP];
        if ( $comp->has_filter()
             && defined $comp->filter() )
        {
            $self->out_method->
                ( $comp->filter->( ${ $self->{top_stack}->[STACK_BUFFER] } ) );
        }
        else
        {
            $self->out_method->( ${ $self->{top_stack}->[STACK_BUFFER] } );
        }
        ${$self->{top_stack}->[STACK_BUFFER]} = '';
    }
}

sub request_args
{
    my ($self) = @_;
    if (wantarray) {
        return @{$self->{request_args}};
    } else {
        return { @{$self->{request_args}} };
    }
}

# For backward compatibility:
*top_args = \&request_args;
*top_comp = \&request_comp;

#
# Subroutine called by every component while in debug mode, convenient
# for breakpointing.
#
sub debug_hook
{
    1;
}


#
# stack handling
#

# Return the stack frame $levels down from the top of the stack.
# If $levels is negative, count from the bottom of the stack.
# 
sub _stack_frame {
    my ($self, $levels) = @_;
    my $depth = $self->depth();
    my $index;
    if ($levels < 0) {
        $index = (-1 * $levels) - 1;
    } else {
        $index = $depth-1 - $levels;
    }
    return if $index < 0 or $index >= $depth;
    return $self->{stack}->[$index];
}

# Return all stack frames, in order from the top of the stack to the
# initial frame.
sub _stack_frames {
    my ($self) = @_;

    my $depth = $self->depth;
    return reverse map { $self->{stack}->[$_] } (0..$depth-1);
}

#
# Accessor methods for top of stack elements.
#
sub current_comp { return $_[0]->{top_stack}->[STACK_COMP] }
sub current_args { return $_[0]->{top_stack}->[STACK_ARGS] }

sub base_comp {
    my ($self) = @_;

    return unless $self->{top_stack};

    unless ( defined $self->{top_stack}->[STACK_BASE_COMP] ) {
        $self->_compute_base_comp_for_frame( $self->depth - 1 );
    }
    return $self->{top_stack}->[STACK_BASE_COMP];
}

#
# Determine the base_comp for a stack frame. See the user
# documentation for base_comp for a description of these rules.
#
sub _compute_base_comp_for_frame {
    my ($self, $frame_num) = @_;
    die "Invalid frame number: $frame_num" if $frame_num < 0;

    my $frame = $self->{stack}->[$frame_num];

    unless (defined($frame->[STACK_BASE_COMP])) {
        my $mods = $frame->[STACK_MODS];
        my $path = $frame->[STACK_PATH];
        my $comp = $frame->[STACK_COMP];
        
        my $base_comp;
        if (exists($mods->{base_comp})) {
            $base_comp = $mods->{base_comp};
        } elsif (!$path ||
                 $path =~ m/^(?:SELF|PARENT|REQUEST)(?:\:..*)?$/ ||
                 ($comp->is_subcomp && !$comp->is_method)) {
            $base_comp = $self->_compute_base_comp_for_frame($frame_num-1);
        } elsif ($path =~ m/(.*):/) {
            my $calling_comp = $self->{stack}->[$frame_num-1]->[STACK_COMP];
            $base_comp = $self->fetch_comp($1, $calling_comp);
        } else {
            $base_comp = $comp;
        }
        $frame->[STACK_BASE_COMP] = $base_comp;
    }
    return $frame->[STACK_BASE_COMP];
}

sub log
{
    my ($self) = @_;
    return $self->current_comp->logger();
}

package Tie::Handle::Mason;
$Tie::Handle::Mason::VERSION = '1.59';
sub TIEHANDLE
{
    my $class = shift;


    return bless {}, $class;
}

sub PRINT
{
    my $self = shift;

    my $old = select STDOUT;
    # Use direct $m access instead of Request->instance() to optimize common case
    $HTML::Mason::Commands::m->print(@_);

    select $old;
}

sub PRINTF
{
    my $self = shift;

    # apparently sprintf(@_) won't work, it needs to be a scalar
    # followed by a list
    $self->PRINT(sprintf(shift, @_));
}

1;

__END__

=head1 NAME

HTML::Mason::Request - Mason Request Class

=head1 SYNOPSIS

    $m->abort (...)
    $m->comp (...)
    etc.

=head1 DESCRIPTION

The Request API is your gateway to all Mason features not provided by
syntactic tags. Mason creates a new Request object for every web
request. Inside a component you access the current request object via
the global C<$m>.  Outside of a component, you can use the class
method C.

=head1 COMPONENT PATHS

The methods Lcomp|HTML::Mason::Request/item_comp>,
Lcomp_exists|HTML::Mason::Request/item_comp_exists>, and
Lfetch_comp|HTML::Mason::Request/item_fetch_comp> take a
component path argument.  Component paths are like URL paths, and
always use a forward slash (/) as the separator, regardless of what
your operating system uses.

=over

=item *

If the path is absolute (starting with a '/'), then the component is
found relative to the component root.

=item *

If the path is relative (no leading '/'), then the component is found
relative to the current component directory.

=item *

If the path matches both a subcomponent and file-based component, the
subcomponent takes precedence.

=back

=head1 PARAMETERS TO THE new() CONSTRUCTOR

=over 4

=item autoflush

True or false, default is false. Indicates whether to flush the output
buffer (C<$m-Eflush_buffer>) after every string is output. Turn on
autoflush if you need to send partial output to the client, for
example in a progress meter.

As of Mason 1.3, autoflush will only work if L has
been set.  Components can be compiled more efficiently if they don't
have to check for autoflush. Before using autoflush you might consider
whether a few manual C<$m-Eflush_buffer> calls would work nearly
as well.

=item data_cache_api

The C<$m-Ecache> API to use:

=over

=item *

'1.1', the default, indicates a C based API.

=item *

'chi' indicates a C based API.

=item *

'1.0' indicates the custom cache API used in Mason 1.0x and
earlier. This compatibility layer is provided as a convenience for
users upgrading from older versions of Mason, but will not be
supported indefinitely.

=back

=item data_cache_defaults

A hash reference of default options to use for the C<$m-Ecache>
command.  For example, to use Cache::Cache's C
implementation by default:

    data_cache_defaults => {cache_class => 'MemoryCache'}

To use the CHI C driver by default:

    data_cache_api      => 'CHI',
    data_cache_defaults => {driver => 'FastMmap'},

These settings are overridden by options given to particular
C<$m-Ecache> calls.

=item dhandler_name

File name used for L. Default
is "dhandler".  If this is set to an empty string ("") then dhandlers
are turned off entirely.

=item error_format

Indicates how errors are formatted. The built-in choices are

=over

=item *

I - just the error message with no trace information

=item *

I - a multi-line text format

=item *

I - a single-line text format, with different pieces of
information separated by tabs (useful for log files)

=item *

I - a fancy html format

=back

The default format under L and
L is either I or I depending
on whether the error mode is I or I, respectively. The
default for standalone mode is I.

The formats correspond to C methods named
as_I. You can define your own format by creating an
appropriately named method; for example, to define an "xml" format,
create a method C patterned after one of
the built-in methods.

=item error_mode

Indicates how errors are returned to the caller.  The choices are
I, meaning die with the error, and I, meaning output
the error just like regular output.

The default under L and
L is I, causing the error to be
displayed in the browser.  The default for standalone mode is
I.

=item component_error_handler

A code reference used to handle errors thrown during component
compilation or runtime. By default, this is a subroutine that turns
non-exception object errors in components into exceptions. If this
parameter is set to a false value, these errors are simply rethrown
as-is.

Turning exceptions into objects can be expensive, since this will
cause the generation of a stack trace for each error. If you are using
strings or unblessed references as exceptions in your code, you may
want to turn this off as a performance boost.

=item max_recurse

The maximum recursion depth for the component stack, for the request
stack, and for the inheritance stack. An error is signalled if the
maximum is exceeded.  Default is 32.

=item out_method

Indicates where to send output. If out_method is a reference to a
scalar, output is appended to the scalar.  If out_method is a
reference to a subroutine, the subroutine is called with each output
string. For example, to send output to a file called "mason.out":

    my $fh = new IO::File ">mason.out";
    ...
    out_method => sub { $fh->print($_[0]) }

By default, out_method prints to standard output. Under
L, standard output is
redirected to C<< $r->print >>.

=item plugins

An array of plugins that will be called at various stages of request
processing.  Please see L for
details.

=back

=head1 ACCESSOR METHODS

All of the above properties have standard accessor methods of the same
name. In general, no arguments retrieves the value, and one argument
sets and returns the value.  For example:

    my $max_recurse_level = $m->max_recurse;
    $m->autoflush(1);

=head1 OTHER METHODS

=over

=item abort ([return value])

=for html 

Ends the current request, finishing the page without returning
through components. The optional argument specifies the return
value from C; in a web environment, this ultimately
becomes the HTTP status code.

C is implemented by throwing an HTML::Mason::Exception::Abort
object and can thus be caught by eval(). The C method is a
shortcut for determining whether a caught error was generated by
C.

If C is called from a component that has a C<< <%filter> >>,
than any output generated up to that point is filtered, I
C is called from a C<< <%shared> >> block.

=item clear_and_abort ([return value])

=for html 

This method is syntactic sugar for calling C and then
C.  If you are aborting the request because of an error, you
will often want to clear the buffer first so that any output generated
up to that point is not sent to the client.

=item aborted ([$err])

=for html 

Returns true or undef indicating whether the specified C<$err>
was generated by C. If no C<$err> was passed, uses C<$@>.

In this code, we catch and process fatal errors while letting C
exceptions pass through:

    eval { code_that_may_fail_or_abort() };
    if ($@) {
        die $@ if $m->aborted;

        # handle fatal errors...

C<$@> can lose its value quickly, so if you are planning to call
$m->aborted more than a few lines after the eval, you should save $@
to a temporary variable.

=item base_comp

=for html 

Returns the current base component.

Here are the rules that determine base_comp as you move from
component to component.

=over

=item * At the beginning of a request, the base component is
initialized to the requested component (C<< $m->request_comp() >>).

=item * When you call a regular component via a path, the base
component changes to the called component.

=item * When you call a component method via a path (/foo/bar:baz),
the base component changes to the method's owner.

=item * The base component does not change when:

=over

=item * a component call is made to a component object

=item * a component call is made to SELF:x or PARENT:x or REQUEST:x

=item * a component call is made to a subcomponent (<%def>)

=back

=back

This may return nothing if the base component is not yet known, for
example inside a plugin's C method, where we
have created a request but it does not yet know anything about the
component being called.

=item cache

=for html 

C<$m-Ecache> returns a new L with a
namespace specific to this component. The parameters to and return value from
C<$m-Ecache> differ depending on which L you are using.

=over

=item If data_cache_api = 1.1 (default)

I specifies the class of cache object to create. It
defaults to C in most cases, or C if the
interpreter has no data directory, and must be a backend subclass of
C. The prefix "Cache::" need not be included.  See the
C package for a full list of backend subclasses.
 
Beyond that, I may include any valid options to the new() method of the
cache class. e.g. for C, valid options include C and
C.

See L for
information about the object returned from C<$m-Ecache>.

=item If data_cache_api = CHI

I specifies the factory class that will be called to
create cache objects. The default is 'CHI'.

I specifies the driver to use, for example C or
C.  The default is C in most cases, or C if
the interpreter has no data directory.

Beyond that, I may include any valid options to the
new() method of the driver. e.g. for the C driver, valid options
include C and C.

=back

=item cache_self ([expires_in => '...'], [key => '...'], [get_options], [cache_options])

=for html 

C<$m-Ecache_self> caches the entire output and return result of a
component.

C either returns undef, or a list containing the
return value of the component followed by '1'. You should return
immediately upon getting the latter result, as this indicates
that you are inside the second invocation of the component.

C takes any of parameters to C<$m-Ecache>
(e.g. I), any of the optional parameters to
C<$cache-Eget> (I, I), and two additional
options:

=over

=item *

I or I: Indicates when the cache expires - it
is passed as the third argument to C<$cache-Eset>. e.g. '10 sec',
'5 min', '2 hours'.

=item *

I: An identifier used to uniquely identify the cache results - it
is passed as the first argument to C<$cache-Eget> and
C<$cache-Eset>.  The default key is '__mason_cache_self__'.

=back

To cache the component's output:

    <%init>
    return if $m->cache_self(expire_in => '10 sec'[, key => 'fookey']);
    ...  ...
    

To cache the component's scalar return value:

    <%init>
    my ($result, $cached) = $m->cache_self(expire_in => '5 min'[, key => 'fookey']);

    return $result if $cached;
    ...  ...
    

To cache the component's list return value:

    <%init>
    my (@retval) = $m->cache_self(expire_in => '3 hours'[, key => 'fookey']);

    return @retval if pop @retval;
    ...  ...
    

We call C on C<@retval> to remove the mandatory '1' at the end of
the list.

If a component has a C<< <%filter> >> block, then the I
output is cached.

Note: users upgrading from 1.0x and earlier can continue to use the
old C<$m-Ecache_self> API by setting L to '1.0'.
This support will be removed at a later date.

See the the L section of the developer's manual section for more details on how to
exercise finer control over caching.

=item caller_args

=for html 

Returns the arguments passed by the component at the specified stack
level. Use a positive argument to count from the current component and
a negative argument to count from the component at the bottom of the
stack. e.g.

    $m->caller_args(0)   # arguments passed to current component
    $m->caller_args(1)   # arguments passed to component that called us
    $m->caller_args(-1)  # arguments passed to first component executed

When called in scalar context, a hash reference is returned.  When
called in list context, a list of arguments (which may be assigned to
a hash) is returned.  Returns undef or an empty list, depending on
context, if the specified stack level does not exist.

=item callers

=for html 

With no arguments, returns the current component stack as a list of
component objects, starting with the current component and ending with
the top-level component. With one numeric argument, returns the
component object at that index in the list. Use a positive argument to
count from the current component and a negative argument to count from
the component at the bottom of the stack. e.g.

    my @comps = $m->callers   # all components
    $m->callers(0)            # current component
    $m->callers(1)            # component that called us
    $m->callers(-1)           # first component executed

Returns undef or an empty list, depending on context, if the specified
stack level does not exist.

=item caller

=for html 

A synonym for C<< $m->callers(1) >>, i.e. the component that called the
currently executing component.

=item call_next ([args...])

=for html 

Calls the next component in the content wrapping chain; usually called
from an autohandler. With no arguments, the original arguments are
passed to the component.  Any arguments specified here serve to
augment and override (in case of conflict) the original
arguments. Works like C<$m-Ecomp> in terms of return value and
scalar/list context.  See the L section of the developer's manual for examples.

=item call_self (output, return, error, tag)

This method allows a component to call itself so that it can filter
both its output and return values.  It is fairly advanced; for most
purposes the C<< <%filter> >> tag will be sufficient and simpler.

C<< $m->call_self >> takes four arguments, all of them optional.

=over

=item output - scalar reference that will be populated with the
component output.

=item return - scalar reference that will be populated with the
component return value.

=item error - scalar reference that will be populated with the error
thrown by the component, if any. If this parameter is not defined,
then call_self will not catch errors.

=item tag - a name for this call_self invocation; can almost always be omitted.

=back

C<< $m->call_self >> acts like a C in the sense that it will
return twice with different values.  When it returns 0, you allow
control to pass through to the rest of your component.  When it
returns 1, that means the component has finished and you can
examine the output, return value and error. (Don't worry, it doesn't
really do a fork! See next section for explanation.)

The following examples would generally appear at the top of a C<<
<%init> >> section.  Here is a no-op C<< $m->call_self >> that leaves
the output and return value untouched:

    <%init>
    my ($output, $retval);
    if ($m->call_self(\$output, \$retval)) {
        $m->print($output);
        return $retval;
    }
    ...

Here is a simple output filter that makes the output all uppercase.
Note that we ignore both the original and the final return value.

    <%init>
    my ($output, $error);
    if ($m->call_self(\$output, undef)) {
        $m->print(uc $output);
        return;
    }
    ...

Here is a piece of code that traps all errors occurring anywhere in a
component or its children, e.g. for the purpose of handling
application-specific exceptions. This is difficult to do with a manual
C because it would have to span multiple code sections and the
main component body.

    <%init>
    my ($output, undef, $error);
    if ($m->call_self(\$output, undef, \$error)) {
        if ($error) {
            # check $error and do something with it
        }
        $m->print($output);
        return;
    }
    ...

=item clear_buffer

=for html 

Clears the Mason output buffer. Any output sent before this line is
discarded. Useful for handling error conditions that can only be
detected in the middle of a request.

clear_buffer is, of course, thwarted by C.

=item comp (comp, args...)

=for html 

Calls the component designated by I with the specified
option/value pairs. I may be a component path or a component
object.

Components work exactly like Perl subroutines in terms of return
values and context. A component can return any type of value, which is
then returned from the C<$m-Ecomp> call.

The <& &> tag provides a convenient shortcut for C<$m-Ecomp>.

As of 1.10, component calls can accept an initial hash reference of
I.  The only currently supported modifier is C, which
stores the component's output in a scalar reference. For example:

  my $buf;
  my $return = $m->comp( { store => \$buf }, '/some/comp', type => 'big' );

This mostly duplicates the behavior of I, but can be useful in
rare cases where you need to capture both a component's output and
return value.

This modifier can be used with the <& &> tag as well, for example:

  <& { store => \$buf }, '/some/comp', size => 'medium' &>

=item comp_exists (comp_path)

=for html 

Returns 1 if I is the path of an existing component, 0
otherwise.  I may be any path accepted by
L or
L, including method or
subcomponent paths.

Depending on implementation,  may try to load the
component referred to by the path, and may throw an error if the
component contains a syntax error.

=item content

=for html 

Evaluates the content (passed between <&| comp &> and  tags) of the 
current component, and returns the resulting text.

Returns undef if there is no content.

=item has_content

=for html 

Returns true if the component was called with content (i.e. with <&|
comp &> and  tags instead of a single <& comp &> tag). This is
generally better than checking the defined'ness of C<< $m->content >>
because it will not try to evaluate the content.

=item count

=for html 

Returns the number of this request, which is unique for a given
request and interpreter.

=item current_args

=for html 

Returns the arguments passed to the current component. When called in
scalar context, a hash reference is returned.  When called in list
context, a list of arguments (which may be assigned to a hash) is
returned.

=item current_comp

=for html 

Returns the current component object.

=item decline

=for html 

Used from a top-level component or dhandler, this method clears the
output buffer, aborts the current request and restarts with the next
applicable dhandler up the tree. If no dhandler is available, a
not-found error occurs.

This method bears no relation to the Apache DECLINED status except in
name.

=item declined ([$err])

=for html 

Returns true or undef indicating whether the specified C<$err> was
generated by C. If no C<$err> was passed, uses C<$@>.

=item depth

=for html 

Returns the current size of the component stack.  The lowest possible
value is 1, which indicates we are in the top-level component.

=item dhandler_arg

=for html 

If the request has been handled by a dhandler, this method returns the
remainder of the URI or C path when the dhandler directory is
removed. Otherwise returns undef.

C may be called from any component in the request, not just
the dhandler.

=item exec (comp, args...)

=for html 

Starts the request by executing the top-level component and
arguments. This is normally called for you on the main request, but
you can use it to execute subrequests.

A request can only be executed once; e.g. it is an error to call this
recursively on the same request.

=item fetch_comp (comp_path)

=for html 

Given a I, returns the corresponding component object or
undef if no such component exists.

=item fetch_next

=for html 

Returns the next component in the content wrapping chain, or undef if
there is no next component. Usually called from an autohandler.  See
the L section of the developer's manual for usage and examples.

=item fetch_next_all

=for html 

Returns a list of the remaining components in the content wrapping
chain. Usually called from an autohandler.  See the L section of the developer's manual
for usage and examples.

=item file (filename)

=for html 

Returns the contents of I as a string. If I is a
relative path, Mason prepends the current component directory.

=item flush_buffer

=for html 

Flushes the Mason output buffer. Under mod_perl, also sends HTTP
headers if they haven't been sent and calls C<< $r->rflush >> to flush
the Apache buffer. Flushing the initial bytes of output can make your
servers appear more responsive.

Attempts to flush the buffers are ignored within the context of a call
to C<< $m->scomp >> or when output is being stored in a scalar
reference, as with the C< { store =E \$out } > component call
modifier.

C<< <%filter> >> blocks will process the output whenever the buffers
are flushed.  If C is on, your data may be filtered in 
small pieces.

=item instance

=for html 

This class method returns the C currently in
use.  If called when no Mason request is active it will return
C.

If called inside a subrequest, it returns the subrequest object.

=item interp

=for html 

Returns the Interp object associated with this request.

=item make_subrequest (comp => path, args => arrayref, other parameters)

=for html 

This method creates a new Request object which inherits its parent's
settable properties, such as L and L.  These
values may be overridden by passing parameters to this method.

The C parameter is required, while all other parameters are
optional.  It may be specified as an absolute path or as a path
relative to the current component.

See the L section of the developer's manual for more information about subrequests.

=item log

=for html 

Returns a C logger with a log category specific to the
current component.  The category for a component "/foo/bar" would be
"HTML::Mason::Component::foo::bar".

=item notes (key, value)

=for html 

The C method provides a place to store application data,
giving developers a way to share data among multiple components.  Any
data stored here persists for the duration of the request, i.e. the
same lifetime as the Request object.

Conceptually, C contains a hash of key-value pairs.
C stores a new entry in this hash.
C returns a previously stored value.  C without
any arguments returns a reference to the entire hash of key-value
pairs.

C is similar to the mod_perl method C<< $r->pnotes() >>.  The
main differences are that this C can be used in a
non-mod_perl environment, and that its lifetime is tied to the
I request object, not the I request object.  In
particular, a Mason subrequest has its own C structure, but
would access the same C<< $r->pnotes() >> structure.

=item out (string)

=for html 

A synonym for C<$m-Eprint>.

=item print (string)

=for html 

Print the given I. Rarely needed, since normally all text is just
placed in the component body and output implicitly. C<$m-Eprint> is useful
if you need to output something in the middle of a Perl block.

In 1.1 and on, C and C<$r-Eprint> are remapped to C<$m-Eprint>,
so they may be used interchangeably. Before 1.1, one should only use
C<$m-Eprint>.

=item request_args

=for html 

Returns the arguments originally passed to the top level component
(see L for
definition).  When called in scalar context, a hash reference is
returned. When called in list context, a list of arguments (which may
be assigned to a hash) is returned.

=item request_comp

=for html 

Returns the component originally called in the request. Without
autohandlers, this is the same as the first component executed.  With
autohandlers, this is the component at the end of the
C<$m-Ecall_next> chain.

=item request_depth

=for html 

Returns the current size of the request/subrequest stack.  The lowest
possible value is 1, which indicates we are in the top-level request.
A value of 2 indicates we are inside a subrequest of the top-level request,
and so on.

=item scomp (comp, args...)

=for html 

Like L, but returns the component output as a string
instead of printing it. (Think sprintf versus printf.) The
component's return value is discarded.

=item subexec (comp, args...)

=for html 

This method creates a new subrequest with the specified top-level
component and arguments, and executes it. This is most often used
to perform an "internal redirect" to a new component such that
autohandlers and dhandlers take effect.

=item time

=for html 

Returns the interpreter's notion of the current time (deprecated).

=back

=head1 APACHE-ONLY METHODS

These additional methods are available when running Mason with mod_perl
and the ApacheHandler.

=over

=item ah

=for html 

Returns the ApacheHandler object associated with this request.

=item apache_req

=for html 

Returns the Apache request object.  This is also available in the
global C<$r>.

=item auto_send_headers

=for html 

True or false, default is true.  Indicates whether Mason should
automatically send HTTP headers before sending content back to the
client. If you set to false, you should call C<$r-Esend_http_header>
manually.

See the L section of the developer's manual for more details about the automatic
header feature.

NOTE: This parameter has no effect under mod_perl-2, since calling
C<$r-Esend_http_header> is no longer needed.

=back

=head1 CGI-ONLY METHODS

This additional method is available when running Mason with the
CGIHandler module.

=over

=item cgi_request

=for html 

Returns the Apache request emulation object, which is available as
C<$r> inside components.

See the L for
more details.

=back

=head1 APACHE- OR CGI-ONLY METHODS

This method is available when Mason is running under either the
ApacheHandler or CGIHandler modules.

=over 4

=item cgi_object

=for html 

Returns the CGI object used to parse any CGI parameters submitted to
the component, assuming that you have not changed the default value of
the ApacheHandler L parameter.  If you are using the
'mod_perl' args method, then calling this method is a fatal error.
See the L and
L documentation for more details.

=item redirect ($url, [$status])

=for html 

Given a url, this generates a proper HTTP redirect for that URL. It
uses C<< $m->clear_and_abort >> to clear out any previous output, and
abort the request.  By default, the status code used is 302, but this
can be overridden by the user.

Since this is implemented using C<< $m->abort >>, it will be trapped
by an C< eval {} > block.  If you are using an C< eval {} > block in
your code to trap errors, you need to make sure to rethrow these
exceptions, like this:

  eval {
      ...
  };

  die $@ if $m->aborted;

  # handle other exceptions

=back

=cut
HTML-Mason-1.59/lib/HTML/Mason/Escapes.pm0000644000175000017500000000551213660015140017436 0ustar  autarchautarch# 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.

#
# A library of escape subroutines to be used for substitution escaping
#

package HTML::Mason::Escapes;
$HTML::Mason::Escapes::VERSION = '1.59';
use strict;
use warnings;

use HTML::Entities ();


my %html_escape = ('&' => '&', '>'=>'>', '<'=>'<', '"'=>'"');
my $html_escape = qr/([&<>"])/;

sub basic_html_escape
{
    return unless defined ${ $_[0] };

    ${ $_[0] } =~ s/$html_escape/$html_escape{$1}/mg;
}

sub html_entities_escape
{
    return unless defined ${ $_[0] };

    HTML::Entities::encode_entities( ${ $_[0] } );
}

sub url_escape
{
    return unless defined ${ $_[0] };

    use bytes;
    ${ $_[0] } =~ s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
}


1;

__END__

=head1 NAME

HTML::Mason::Escapes - Functions to escape text for Mason

=head1 DESCRIPTION

This module contains functions for implementing Mason's L feature.  These
functions may also be called directly.

=over 4

=item html_entities_escape

This function takes a scalar reference and HTML-escapes it using the
C module.  By default, this module assumes that the
string it is escaping is in ISO-8859-1 (pre Perl 5.8.0) or UTF-8 (Perl
5.8.0 onwards).  If this is not the case for your data, you will want
to override this escape to do the right thing for your encoding.  See
the section on L for more details on
how to do this.

=item url_escape

This takes a scalar reference and replaces any text it contains
matching C<[^a-zA-Z0-9_.-]> with the URL-escaped equivalent, a percent
sign (%) followed by the hexadecimal number of that character.

=item basic_html_escape

This function takes a scalar reference and HTML-escapes it, escaping
the following characters: '&', '>', '<', and '"'.

It is provided for those who wish to use it to replace (or supplement)
the existing 'h' escape flag, via the Interpreter's L
method|HTML::Mason::Interp/item_set_escape>.

This function is provided in order to allow people to return the HTML
escaping behavior in 1.0x.  However, this behavior presents a
potential security risk of allowing cross-site scripting attacks.
HTML escaping should always be done based on the character set a page
is in.  Merely escaping the four characters mentioned above is not
sufficient.  The quick summary of why is that for some character sets,
characters other than '<' may be interpreted as a "less than" sign,
meaning that just filtering '<' and '>' will not stop all cross-site
scripting attacks.  See
http://www.megasecurity.org/Info/cross-site_scripting.txt for more
details.

=back

=cut
HTML-Mason-1.59/lib/HTML/Mason/Component/0000755000175000017500000000000013660015140017454 5ustar  autarchautarchHTML-Mason-1.59/lib/HTML/Mason/Component/FileBased.pm0000644000175000017500000000376213660015140021640 0ustar  autarchautarch# 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.

package HTML::Mason::Component::FileBased;
$HTML::Mason::Component::FileBased::VERSION = '1.59';
use strict;
use warnings;

use File::Basename;
use File::Spec;

use HTML::Mason::Component;
use base qw(HTML::Mason::Component);

use HTML::Mason::Exceptions( abbr => ['error'] );

use HTML::Mason::MethodMaker ( read_only => [ qw( path source_file name dir_path ) ] );

sub is_file_based { 1 }
sub persistent { 1 }
sub source_dir {
    my $dir = dirname($_[0]->source_file);
    return File::Spec->canonpath($dir);
}
sub title {
    my ($self) = @_;
    return $self->path . ($self->{source_root_key} ? " [".lc($self->{source_root_key})."]" : "");
    #return $self->path . ($self->{source_root_key} ? " [$self->{source_root_key}]" : "");
}

# Ends up setting $self->{path, source_root_key, source_file} and a few in the parent class
sub assign_runtime_properties {
    my ($self, $interp, $source) = @_;

    $self->{source_file} = $source->friendly_name;
    $self->{source_root_key} = $source->extra->{comp_root};

    # We used to use File::Basename for this but that is broken
    # because URL paths always use '/' as the dir-separator but we
    # could be running on any OS.
    #
    # The regex itself is taken from File::Basename.
    #
    @{$self}{ 'dir_path', 'name'} = $source->comp_path =~ m,^(.*/)?(.*),s;
    $self->{dir_path} =~ s,/$,, unless $self->{dir_path} eq '/';

    $self->SUPER::assign_runtime_properties($interp, $source);
}

1;

__END__

=head1 NAME

HTML::Mason::Component::FileBased - Mason File-Based Component Class

=head1 DESCRIPTION

This is a subclass of
L. Mason uses it to
implement components which are stored in files.

=head1 METHODS

See L for
documentation.

=cut
HTML-Mason-1.59/lib/HTML/Mason/Component/Subcomponent.pm0000644000175000017500000000501613660015140022470 0ustar  autarchautarch# 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.

package HTML::Mason::Component::Subcomponent;
$HTML::Mason::Component::Subcomponent::VERSION = '1.59';
use strict;
use warnings;

use HTML::Mason::Component;

use vars qw(@ISA);

@ISA = qw(HTML::Mason::Component);

use HTML::Mason::MethodMaker ( read_only => [ qw( comp_id is_method name owner path ) ] );

#
# Assign parent, name, and is_method flag when owner component is created.
#
sub assign_subcomponent_properties {
    my $self = shift;
    ($self->{owner}, $self->{name}, $self->{is_method}) = @_;
}

#
# Override path that would be set by parent's version of method.
#
sub assign_runtime_properties {
    my ($self, $interp, $source) = @_;
    $self->SUPER::assign_runtime_properties($interp, $source);
    $self->{comp_id} = sprintf("[%s '%s' of %s]", $self->{is_method} ? 'method' : 'subcomponent',
                               $self->name, $self->owner->comp_id);
    my $owner_path = $self->owner->path;
    $owner_path = q{} unless defined $owner_path;
    $self->{path} =  $owner_path . ":" . $self->name;
}

sub cache_file { return $_[0]->owner->cache_file }
sub load_time { return $_[0]->owner->load_time }
sub compiler_id { return $_[0]->owner->compilation_params }
sub dir_path { return $_[0]->owner->dir_path }
sub is_subcomp { 1 }
sub object_file { return $_[0]->owner->object_file }
sub parent { return $_[0]->owner->parent }
sub persistent { return $_[0]->owner->persistent }
sub title { return $_[0]->owner->title . ":" . $_[0]->name }

1;

__END__

=head1 NAME

HTML::Mason::Component::Subcomponent - Mason Subcomponent Class

=head1 DESCRIPTION

This is a subclass of
L. Mason uses it to
implement both subcomponents (defined by C<< <%def> >>) and methods (defined
by C<< <%method> >>).

A subcomponent/method gets most of its properties from its owner. Note
that the link from the subcomponent to its owner is a weak reference
(to prevent circular references), so if you grab a subcomponent/method
object, you should also grab and hold a reference to its owner. If the
owner goes out of scope, the subcomponent/method object will become unusable.

=head1 METHODS

=over 4

=item is_method

Returns 1 if this is a method (declared by C<< <%method> >>), 0 if it is a
subcomponent (defined by c<< <%def> >>).

=item owner

Returns the component object within which this subcomponent or method
was defined.

=back

=cut
HTML-Mason-1.59/lib/HTML/Mason/Resolver/0000755000175000017500000000000013660015140017313 5ustar  autarchautarchHTML-Mason-1.59/lib/HTML/Mason/Resolver/Null.pm0000644000175000017500000000306013660015140020562 0ustar  autarchautarch# 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.

package HTML::Mason::Resolver::Null;
$HTML::Mason::Resolver::Null::VERSION = '1.59';
use strict;
use warnings;

use HTML::Mason::Resolver;
use base qw(HTML::Mason::Resolver);

sub get_info {
    return;
}

sub get_source {
    return;
}

sub comp_class {
    return 'HTML::Mason::Component';
}

sub glob_path {
    return;
}

1;

__END__

=head1 NAME

HTML::Mason::Resolver::Null - a do-nothing resolver

=head1 SYNOPSIS

  my $resolver = HTML::Mason::Resolver::Null->new;

=head1 DESCRIPTION

This HTML::Mason::Resolver subclass is useful if you want to create
components via the C<< HTML::Mason::Interp->make_component >> method
and you never plan to interact with the filesystem.

Basically, it provides all of the necessary resolver methods but none
of them do anything.

This means that if you use this method things like C<< $interp->exec >>
will simply not work at all.

However, if you just want to make a component with an interpreter and
execute that component it can be useful.  For example:

  my $interp = HTML::Mason::Interp->new( resolver_class => 'HTML::Mason::Resolver::Null',
                                         data_dir => '/tmp' );

  my $comp = $interp->make_component( comp_source => <<'EOF' );
% my $var = 'World';
Hello, <% $var %>!
EOF

  my $buffer;
  my $request = $interp->make_request( out_method => \$buffer, comp => $comp );
  $request->exec;

  print $buffer;

=cut
HTML-Mason-1.59/lib/HTML/Mason/Resolver/File.pm0000644000175000017500000000721413660015140020534 0ustar  autarchautarch# 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.

package HTML::Mason::Resolver::File;
$HTML::Mason::Resolver::File::VERSION = '1.59';
use strict;
use warnings;

use Cwd;

use File::Glob;
use File::Spec;
use HTML::Mason::Tools qw(read_file_ref paths_eq);
use Params::Validate qw(:all);

use HTML::Mason::ComponentSource;
use HTML::Mason::Resolver;
use base qw(HTML::Mason::Resolver);

use HTML::Mason::Exceptions (abbr => ['param_error']);

sub get_info {
    my ($self, $path, $comp_root_key, $comp_root_path) = @_;

    # Note that canonpath has the property of not collapsing a series
    # of /../../ dirs in an unsafe way. This means that if the
    # component path is /../../../../etc/passwd, we're still safe. I
    # don't know if this was intentional, but it's certainly a good
    # thing, and something we want to preserve if the code ever
    # changes.
    my $srcfile = File::Spec->canonpath( File::Spec->catfile( $comp_root_path, $path ) );
    return unless -f $srcfile;
    my $modified = (stat _)[9];
    my $base = $comp_root_key eq 'MAIN' ? '' : "/$comp_root_key";
    $comp_root_key = undef if $comp_root_key eq 'MAIN';

    return
      HTML::Mason::ComponentSource->new
          ( friendly_name => $srcfile,
            comp_id => "$base$path",
            last_modified => $modified,
            comp_path => $path,
            comp_class => 'HTML::Mason::Component::FileBased',
            extra => { comp_root => $comp_root_key },
            source_callback => sub { read_file_ref($srcfile) },
          );
}

#
# Return all existing url_paths matching the given glob pattern underneath the given root.
# glob_path is required for using the "preloads" parameter.
#
sub glob_path {
    my ($self, $pattern, $comp_root_path) = @_;

    my @files = File::Glob::bsd_glob($comp_root_path . $pattern);
    my $root_length = length $comp_root_path;
    my @paths;
    foreach my $file (@files) {
        next unless -f $file;
        if (substr($file, 0, $root_length) eq $comp_root_path) {
            push(@paths, substr($file, $root_length));
        }
    }
    return @paths;
}

#
# Given an apache request object and a list of component root pairs,
# return the associated component path or undef if none exists. This
# is called for top-level web requests that resolve to a particular
# file.
# apache_request_to_comp_path is required for running Mason under mod_perl.
#
sub apache_request_to_comp_path {
    my ($self, $r, @comp_root_array) = @_;

    my $file = $r->filename;
    $file .= $r->path_info unless -f $file;

    # Clear up any weirdness here so that paths_eq compares two
    # 'canonical' paths (canonpath is called on comp roots when
    # resolver object is created.  Seems to be needed on Win32 (see
    # bug #356).
    $file = File::Spec->canonpath($file);

    foreach my $root (map $_->[1], @comp_root_array) {
        if (paths_eq($root, substr($file, 0, length($root)))) {
            my $path = substr($file, length $root);
            $path = length $path ? join '/', File::Spec->splitdir($path) : '/';
            chop $path if $path ne '/' && substr($path, -1) eq '/';

            return $path;
        }
    }
    return undef;
}


1;

__END__

=head1 NAME

HTML::Mason::Resolver::File - Component path resolver for file-based components

=head1 SYNOPSIS

  my $resolver = HTML::Mason::Resolver::File->new();

  my $info = $resolver->get_info('/some/comp.html');

=head1 DESCRIPTION

This HTML::Mason::Resolver subclass is used when components are stored
on the filesystem, which is the norm for most Mason-based applications.

=cut
HTML-Mason-1.59/lib/HTML/Mason/Subclassing.pod0000644000175000017500000002344113660015140020477 0ustar  autarchautarch=pod

=head1 NAME

HTML::Mason::Subclassing - Documentation on Subclassing Internal Mason classes

=head1 DESCRIPTION

This is the deep voodoo guide, for folks who want to create their own
custom subclasses for parts of Mason, such as the Request or Interp
objects.

=head1 Class::Container

A number of modules in Mason are subclasses of C.
This module was originally part of the Mason core as
C, but Ken Williams decided to release it separately on CPAN.

It was created to encapsulate some common behaviors for Mason objects
such as parameter validation and the creation of "contained" objects.

Basically, any Mason object which takes parameters to its constructor
B inherit from this module.  Of course, since all of the classes
that you might consider subclassing already inherit from
C, you won't need to inherit from it directly.
However, you may need to use some of its methods.

So before you go further we highly recommend familiarizing yourself
with C and its methods.  Also feel free to look at
some of the Mason core modules to see how C is used
within Mason itself.

=head1 SUBCLASSABLE CLASSES

The following classes have been designed with subclassing in mind:

=over 4

=item * HTML::Mason::Request

This object is your old friend C<$m>.  The request contains
information about the current request context, and provides methods
for calling other components.

=item * HTML::Mason::Resolver

The resolver's job is to translate a component paths into an actual
component.  Mason comes with a single Resolver subclass,
C, which is used to translate component
paths into filesystem paths.

=item * HTML::Mason::ComponentSource

An object of this class represents a component's source.  These
objects are instantiated by the resolver when it finds a component
matching a given path.

=item * HTML::Mason::Lexer

The lexer is responsible for parsing a component.  Creating a new
lexer would allow you to change Mason's component syntax.

=item * HTML::Mason::Compiler

The compiler takes the parsed chunks from the lexer and gives them
meaning.  The default compiler, C,
turns a Mason component into a Mason "object file", which contains
actual Perl code.

=item * HTML::Mason::ApacheHandler

The ApacheHandler class is the bridge between the mod_perl world and
Mason, primarily Mason's Interp class.

It also provides its own C and
C subclasses which implement some mod_perl
specific behaviors and features.

=item * HTML::Mason::Interp

The Interp is the core of Mason, and is primarily responsible for
making all the other objects do their jobs.

=back

=head1 CONSTRUCTORS

If you choose to override the constructor, which is always C with
Mason objects, that you make sure to call the superclass's constructor
and that you use the object returned by it.  A good boilerplate for an
overridden constructor looks something like this:

  sub new
  {
      my $class = shift;

      my $self = $class->SUPER::new(@_);

      $self->_do_some_init;

      return $self;
  }

=head1 Request

=head2 What to Subclass?

One important thing to know about this class is that it is actually
several classes.  The first, C, is used when
ApacheHandler is not loaded.  The other,
C, is loaded by ApacheHandler and
used to provide some mod_perl specific features.  Similar, the
CGIHandler class provides its own request subclass,
C.

It is impossible to know which one of these to subclass at compile
time, since it is possible that your subclass will be loaded before
either ApacheHandler or CGIHandler.

To handle this, simply call the C method in your
constructor, like this:

  sub new
  {
      my $class = shift;

      $class->alter_superclass( $HTML::Mason::ApacheHandler::VERSION ?
                                'HTML::Mason::Request::ApacheHandler' :
                                $HTML::Mason::CGIHandler::VERSION ?
                                'HTML::Mason::Request::CGI' :
                                'HTML::Mason::Request' );

      my $self = $class->SUPER::new(@_);

      ...

      return $self;
  }

It is quite important that you do this as these handler-specific
subclasses provide important functionality.  The C
method is implemented in the
L|HTML::Mason::Request> base class, and will
do the right thing even in cases of multiple inheritance.  It also
cooperates with C to make sure that it sees changes
to the inheritance hierarchy.

=head2 The exec() method

The C method is called in order to execute a request, and is the
method that you are most likely to want to override.

However, if you do override it we suggest that you make sure to call
the parent class's C method to implement the actual component
execution and there is no need for you to re-implement them.

Since the C method is scalar/list context-sensitive, your
C method will need to preserve that.  Here is a boilerplate:

  sub exec
  {
      my $self = shift;

      ... # do something cool

      my @r;
      if (wantarray)
      {
          @r = $self->SUPER::exec(@_);
      }
      else
      {
          $r[0] = $self->SUPER::exec(@_);
      }

      ... # maybe do some cleanup

      return wantarray ? @r : $r[0];
  }

=head2 Subrequests

Your custom request class will also be used to implement subrequests,
which are implemented by calling C just like any other method.
If you only want to do certain things in C for the first
request, you can simply check the value of C<< $self->is_subrequest >>.

=head2 Examples

See the C module on CPAN.

=head1 Resolver and ComponentSource

The resolver takes a component path and figures out what component
that path corresponds to.

All resolver classes must implement two methods, C and
C.  The first takes a component path and returns a new
C object.  This object contains
information about the component, such as its last modified time and
its source.  See the
L|HTML::Mason::ComponentSource>
documentation for more details.

You may choose to provide your own ComponentSource subclass as well,
if your resolver implementation can take advantage of it.

The C method is responsible for translating a component
path like F into a list of component paths that match that
glob pattern.

=head1 Lexer

The rationale for providing your own lexer would be to extend or
replace Mason's syntax.

The lexer is called by the compiler via its C method.  The
arguments it receives are the component name, source, and the compiler
object.  See the L documentation
for details on what methods the lexer can call.

=head1 Compiler

See the L documentation for
details on what methods a subclass of this class needs to provide.

If you simply want to tweak Mason's existing behavior, you will
probably want to subclass C, which is
the default Compiler class.  For example, if you wanted to do
something like make attributes dynamic, you could override the
C<_flags_or_attr()> method in ToObject.

If you want to drastically change the behavior, you can subclass
C instead.  An example of this would be
creating a compiler that generates C or C as
output.

=head1 ApacheHandler

The methods that you are most likely to want to subclass are
documented in the L|HTML::Mason::ApacheHandler>
documentation.

Providing an ApacheHandler subclass gives you a chance to do your own
client parameter parsing, as well as the capability of providing a
different way of handling requests.

=head1 CGIHandler

Like the ApacheHandler, you could subclass this module in order to
provide your own argument processing or to step in and provide a
different way to handle requests.

=head1 USING SUBCLASSES

When using your custom subclasses, we recommend that you take
advantage of Mason's ability to construct subclassed object on the
fly.

For example, if you're subclassed the Interp object, you can still let
the ApacheHandler object create the Interp object for you, as long as
you give it the appropriate L parameter.  This is
important because Mason may internally set up certain defaults for
contained objects.  For example, the ApacheHandler, by default, will
tell the Interp object to use the
C Request subclass.  If you
create an Interp object manually and you want to use that Interp
object with ApacheHandler, you'll have to specify the same Request
class.

For example:

  my $interp =
      My::Interp->new
          ( request_class  => 'HTML::Mason::Request::ApacheHandler',
            my_new_interp_param => 42,
          );

  my $ah = HTML::Mason::ApacheHandler->new( interp => $interp );

It is far easier to simply do this:

  my $ah =
      HTML::Mason::ApacheHandler->new
          ( interp_class => 'My::Interp',
            my_new_interp_param => 42,
          );

Your new parameter, C, will still be passed to
the C constructor, but this also gives ApacheHandler a
chance to set various parameters for the Interp object.  Of course,
you can still override these defaults explicitly:

  my $ah =
      HTML::Mason::ApacheHandler->new
          ( interp_class => 'My::Interp',
            resolver_class => 'My::Resolver'.
            my_new_interp_param => 42,
          );

If you need access to the interp object's methods directly, it will be
always be available via C<< $ah->interp >>.

=cut
HTML-Mason-1.59/lib/HTML/Mason/Admin.pod0000644000175000017500000011565013660015140017256 0ustar  autarchautarch=head1 NAME

HTML::Mason::Admin - Mason Administrator's Manual

=head1 DESCRIPTION

This manual is written for the sysadmin/webmaster in charge of
installing, configuring, or tuning a Mason system.  The bulk of the
documentation assumes that you are using mod_perl.  See L
for more details. For more details on mod_perl, visit
the mod_perl website at http://perl.apache.org/.

=head1 SITE CONFIGURATION METHODS

Mason includes a module specifically designed to integrate Mason and
mod_perl (1 and 2), C.  By telling
mod_perl to hand content requests to this module, you can use Mason to
generate web pages.  There are two ways to configure Mason under
mod_perl.

=over 4

=item * Basic

Mason provides reasonable default behavior under mod_perl, so using
Mason can be as simple as adding two directives to your Apache
configuration file.  Throughout this document, we will assume that
your Apache configuration file is called F.  By adding
more configuration parameters to this file you can implement more
complex behaviors.

=item * Advanced

If the basic method does not provide enough flexibility for you, you
can wrap Mason in a custom mod_perl handler.  The wrapper code you
write can create its own Mason objects, or it can take advantage of
F configuration parameters and let Mason create the
objects it needs by itself.

=back

We recommend that you start with the basic method and work your way
forward as the need for flexibility arises.

Mason is very flexible, and you can replace parts of it by creating
your own classes.  This documentation assumes that you are simply
using the classes provided in the Mason distribution.  Subclassing is
covered in the L document.  The
two topics are orthogonal, as you can mix the configuration techniques
discussed here with your own custom subclasses.

=head1 BASIC CONFIGURATION VIA httpd.conf DIRECTIVES

The absolutely most minimal configuration looks like this:

    PerlModule HTML::Mason::ApacheHandler

    
      SetHandler   perl-script
      PerlHandler  HTML::Mason::ApacheHandler
    

This configuration tells Apache to serve all URLs through Mason (see
the next section for a more realistic strategy).  We use the
PerlModule line to tell mod_perl to load Mason once at startup time,
saving time and memory.  This example does not set any Mason
configuration parameters, so Mason uses its default values.

If this is your first time installing and using Mason, we recommend
that you use the above configuration in a test webserver to start
with.  This will let you play with Mason under mod_perl with a minimum
of fuss.  Once you've gotten this working, then come back and read the
rest of the document for further possibilities.

=head2 Controlling Access via Filename Extension

As it turns out, serving every URL through Mason is a bad idea for two
reasons:

=over

=item 1.

Mason should be prevented from handling images, tarballs, and other
binary files. Not only will performance suffer, but binary files may
inadvertently contain a Mason character sequence such as "<%". These
files should be instead served by Apache's default content handler.

=item 2.

Mason should be prevented from serving private (non-top-level) Mason
components to users. For example, if you used a utility component for
performing arbitrary sql queries, you wouldn't want external users to
be able to access it via a URL. Requests for private components should
simply result in a 404 NOT_FOUND.

=back

The easiest way to distinguish between different types of files is
with filename extensions. While many naming schemes are possible, we
suggest using "normal" extensions for top-level components and
adding an "m" prefix for private components. For example,

                             Top-level       Private

   Component outputs HTML    .html           .mhtml
   Component outputs text    .txt            .mtxt
   Component executes Perl   .pl             .mpl

This scheme minimizes the chance of confusing browsers about content
type, scales well for new classes of content (e.g. .js/.mjs for
javascript), and makes transparent the fact that you are using Mason
versus some other package.

Here is a configuration that enforces this naming scheme:

    PerlModule HTML::Mason::ApacheHandler

    
      SetHandler perl-script
      PerlHandler HTML::Mason::ApacheHandler
    

    
      SetHandler perl-script
      PerlInitHandler Apache::Constants::NOT_FOUND
    

The first block causes URLs ending in .html, .txt, or .pl to be served
through Mason. The second block causes requests to private components
to return 404 NOT_FOUND, preventing unscrupulous users from even
knowing which private components exist. Any other file extensions
(e.g. .gif, .tgz) will be served by Apache's default content handler.

You might prefer C to C. However, be aware
that C will work best in conjunction with Mason's
L.

=head2 Configuration Parameters

Mason allows you to flexibly configure its behavior via F
configuration parameters.

These configuration parameters are set via mod_perl's C
and C directives.  Though these parameters are all strings
in your F file, Mason treats different directives as
containing different types of values:

=over 4

=item * string

The variable's value is simply taken literally and used.  The string
should be surrounded by quotes if the it contains whitespace.  The
quotes will be automatically removed by Apache before Mason sees the
variable.

=item * boolean

The variable's value is used as a boolean, and is subject to Perl's
rules on truth/falseness.  It is recommended that you use 0 (false) or
1 (true) for these arguments.

=item * code

The string is treated as a piece of code and C'ed.  This is used
for parameters that expect subroutine references.  For example, an
anonymous subroutine might look like:

 PerlSetVar  MasonOutMode  "sub { ... }"

A named subroutine reference would look like this:

 PerlSetVar  MasonOutMode  "\&Some::Module::handle_output"

=item * list

To set a list parameter, use C for the values, like this:

 PerlAddVar  MasonPreloads  /foo/bar/baz.comp
 PerlAddVar  MasonPreloads  /foo/bar/quux.comp

=item * hash_list

Just like a list parameter, use C for the values.
However, in the case of a hash_list, each element should be a
key/value pair separated by "=>":

 PerlAddVar  MasonDataCacheDefaults  "cache_class => MemoryCache"
 PerlAddVar  MasonDataCacheDefaults  "namespace => foo"

Take note that the right hand side of the each pair should I be
quoted.

=back

See L for a full list
of parameters, and their associated types.

=head1 GENERAL SERVER CONFIGURATION

=head2 Component Root

The component root (L) marks the top of your component
hierarchy.  When running Mason with the ApacheHandler or CGIHandler
modules, this defaults to your document root.

The component root defines how component paths are translated into
real file paths. If your component root is F, a
component path of F translates to the file
F.

One cannot call a component outside the component root. If Apache
passes a file through Mason that is outside the component root (say,
as the result of an Alias) you will get a 404 and a warning in the
logs.

You may also specify multiple component roots in the spirit of Perl's
C<@INC>. Each root is assigned a key that identifies the root
mnemonically. For example, in F:

    PerlAddVar  MasonCompRoot  "private => /usr/home/joe/comps"
    PerlAddVar  MasonCompRoot  "main => /usr/local/www/htdocs"

This specifies two component roots, a main component tree and a
private tree which overrides certain components.  The order is
respected ala C<@INC>, so I is searched first and I

second.

The component root keys must be unique in a case-insensitive
comparison. The keys are used in several ways. They help to
distinguish component caches and object files between different
component roots, and they appear in the C of a component.

=head2 Data Directory

The data directory (L) is a writable directory that Mason
uses for various features and optimizations. By default, it is a
directory called "mason" under your Apache server root.  Because Mason
will not use a I data directory under a top-level directory,
you will need to change this on certain systems that assign a
high-level server root such as F or F.

Mason will create the directory on startup, if necessary, and set its
permissions according to the web server User/Group.

=head2 External Modules

Components will often need access to external Perl modules. There are
several ways to load them.

=over

=item *

The httpd PerlModule directive:

    PerlModule CGI
    PerlModule LWP

=item *

In the C<< <%once> >> section of the component(s) that use the module.

    <%once>
    use CGI ':standard';
    use LWP;
    

=back

Each method has its own trade-offs:

The first method ensures that the module will be loaded by the Apache
parent process at startup time, saving time and memory.  The second
method, in contrast, will cause the modules to be loaded by each
server child. On the other hand this could save memory if the
component and module are rarely used. See the mod_perl guide's tuning
section and Vivek Khera's mod_perl tuning guide for more details on
this issue.

The second method uses the modules from inside the package used by
components (C), meaning that exported method
names and other symbols will be usable from components.  The first
method, in contrast, will import symbols into the C
 package. The
significance of this depends on whether the modules export symbols and
whether you want to use them from components.

If you want to preload the modules in your F file, and
still have them export symbols into the C
namespace, you can do this:

  
  { package HTML::Mason::Commands;
    use CGI;
    use LWP;
  }
  

A Perl section will also work for including local library paths:

  
  use lib '/path/to/local/lib';
  

=head2 Allowing Directory Requests

By default Mason will decline requests for directories, leaving Apache
to serve up a directory index or a FORBIDDEN as appropriate.
Unfortunately this rule applies even if there is a dhandler in the
directory: F does not get a chance to
handle a request for F.

If you would like Mason to handle directory requests, set
L to 0.  The dhandler that catches a directory request
is responsible for setting a reasonable content type via
C<< $r->content_type() >>.

=head2 Configuring Virtual Sites

These examples extend the single site configurations given so far.

=head3 Multiple sites, one component root

If you want to share some components between your sites, arrange your
F so that all DocumentRoots live under a single component
space:

    # Web site #1
    
      DocumentRoot  /usr/local/www/htdocs/site1
      
        SetHandler   perl-script
        PerlHandler  HTML::Mason::ApacheHandler
      
    

    # Web site #2
    
      DocumentRoot  /usr/local/www/htdocs/site2
      
        SetHandler   perl-script
        PerlHandler  HTML::Mason::ApacheHandler
      
    

    # Mason configuration
    PerlSetVar  MasonCompRoot  /usr/local/www/htdocs
    PerlSetVar  MasonDataDir   /usr/local/mason
    PerlModule  HTML::Mason::ApacheHandler

The directory structure for this scenario might look like:

    /usr/local/www/htdocs/  # component root
        +- shared/          # shared components
        +- site1/           # DocumentRoot for first site
        +- site2/           # DocumentRoot for second site

Incoming URLs for each site can only request components in their
respective DocumentRoots, while components internally can call other
components anywhere in the component space. The F directory
is a private directory for use by components, inaccessible from the
Web.

=head3 Multiple sites, multiple component roots

If your sites need to have completely distinct component hierarchies,
e.g. if you are providing Mason ISP services for multiple users, then
the component root must change depending on the site requested.

    
      DocumentRoot  /usr/local/www/htdocs/site1

      # Mason configuration
      PerlSetVar  MasonCompRoot    /usr/local/www/htdocs/site1
      PerlSetVar  MasonDataDir     /usr/local/mason/site1

      
        SetHandler   perl-script
        PerlHandler  HTML::Mason::ApacheHandler
      
    

    # Web site #2
    
      DocumentRoot  /usr/local/www/htdocs/site2

      # Mason configuration
      PerlSetVar  MasonCompRoot    /usr/local/www/htdocs/site2
      PerlSetVar  MasonDataDir     /usr/local/mason/site2

      
        SetHandler   perl-script
        PerlHandler  HTML::Mason::ApacheHandler
      
    

=head1 ADVANCED CONFIGURATION

As mentioned previously, it is possible to write a custom mod_perl
content handler that wraps around Mason and provides basically
unlimited flexibility when handling requests.  In this section, we
show some basic wrappers and re-implement some of the functionality
previously discussed, such as declining image requests and protecting
private components.

In addition, we discuss some of the possibilities that become
available when you create a custom wrapper around Mason's request
handling mechanism.  This wrapper generally consists of two parts.
The initialization portion, run at server startup, will load any
needed modules and create objects.  The other portion is the
C subroutine, which handles web page requests.

=head2 Writing a Wrapper

To create a wrapper, you simply need to define a C
subroutine in the package of your choice, and tell mod_perl to use it
as a content handler.  The file that defines the C
subroutine can be a module, or you can simply load a simple file that
contains this subroutine definition.  The latter solution was, for a
long time, the I way to configure Mason, and the file used was
traditionally called F.

Nowadays, we recommend that you create a custom module in the
appropriate namespace and define your C subroutine there.
The advantage to this approach is that it uses well-known techniques
for creating and installing modules, but it does require a bit more
work than simply dropping a script file into the Apache configuration
directory.  But because the process is better defined, it may "feel"
more solid to some folks than the script approach.

The F directory of the Mason distribution contains a couple
sample modules that define C subroutines.  Let's assume
that your module, like the example, defines a C in the
package C.  In this case, your Apache configuration
would look like this:

  PerlModule  MyApp::Mason

  
    SetHandler   perl-script
    PerlHandler  MyApp::Mason
  

You may still see references to a F file in the Mason
users list archives, as well as the FAQ.  These references will
generally be applicable to any custom code wrapping Mason.

=head3 Wrappers and PerlSetVar-style configuration

Sometimes people attempt to write a wrapper I configure Mason
with C directives in their Apache configuration file.
B.  When you give mod_perl this configuration:

  PerlHandler HTML::Mason::ApacheHandler

it will dispatch directly to the C<<
HTML::Mason::ApacheHandler->handler() >> method, without ever
executing your wrapper code.  However, you can mix the two methods.
See L

=head2 Wrapping with a  block

You can also put your wrapper code in a C<<  >> block as part of
your F file.  The result is no different than loading a
file via the C directive.

=head2 The Wrapper Code

Regardless of how you load your wrapper code, it will always work the
same way.  The C subroutine should expect to receive the
Apache request object representing the current request.  This request
object is used by the ApacheHandler module to determine what component
is being called.

Let's look at the guts of some wrapper code.  Here's a first version:

  package MyApp::Mason;

  use strict;
  use HTML::Mason::ApacheHandler;

  my $ah =
      HTML::Mason::ApacheHandler->new
          ( comp_root => '/path/to/comp/root',
            data_dir  => '/path/to/data/dir' );

  sub handler {
      my ($r) = @_;

      return $ah->handle_request($r);
  }

This wrapper is fully functional, but it doesn't actually do anything
you couldn't do more easily by configuring Mason via the F
file.  However, it does serve as a good skeleton to which additional
functionality can easily be added.

=head2 External Modules Revisited

Since you are loading an arbitrary piece of code to define your
wrapper, you can easily load other modules needed for your application
at the same time.  For example, you might simple add these lines to
the wrapper code above:

  {
      package HTML::Mason::Commands;

      use MIME::Base64;
  }

Explicitly setting the package to C makes sure
that any symbols that the loaded modules export (constants,
subroutines, etc.) get exported into the namespace under which
components run.  Of course, if you've changed the component namespace,
make sure to change the package name here as well.

Alternatively, you might consider creating a separate piece of code to
load the modules you need.  For example, you might create a module
called C:

  {
      package HTML::Mason::Commands;

      use Apache::Constants qw(:common);
      use Apache::URI;
      use File::Temp;
  }

  1;

This can be loaded via a C directive in the F
file, or in the wrapper code itself via C.

=head3 Example: Controlling access with component attributes

An example of something you can only do with wrapper code is deciding
at run-time whether a component can be accessed at the top-level based
on a complex property of the component.  For example, here's a piece
of code that uses the current user and a component's C
attribute to control access:

  sub handler {
      my ($r) = @_;

      my $req = $ah->prepare_request($r);

      my $comp = $req->request_comp;

      # this is done via magic hand-waving ...
      my $user = get_user_from_cookie();

      # remember, attributes are inherited so this could come from a
      # component higher up the inheritance chain
      my $required_access = $comp->attr('access_level');

      return NOT_FOUND
          if $user->access_level < $required_access;

      return $req->exec;
  }

=head2 Wrappers with Virtual Hosts

If you had several virtual hosts, each of which had a separate
component root, you'd need to create a separate ApacheHandler object
for each host, one for each host.  Here's some sample code for that:

    my %ah;
    foreach my $site ( qw( site1 site2 site3 ) ) {
        $ah{$site} =
            HTML::Mason::ApacheHandler->new
                ( comp_root => "/usr/local/www/$site",
                  data_dir => "/usr/local/mason/$site" );
    }

    sub handler {
        my ($r) = @_;

        my $site = $r->dir_config('SiteName');

        return DECLINED unless exists $ah{$site};

        return $ah{$site}->handle_request($r);
    }

This code assumes that you set the C variable via a
C directive in each C block, like this:

  
    PerlSetVar  SiteName  site1

    
      SetHandler   perl-script
      PerlHandler  MyApp::Mason
    
  

=head3 Creating apachehandler objects on the fly

You might also consider creating ApacheHandler objects on the fly,
like this:

    my %ah;
    sub handler {
        my ($r) = @_;
        my $site = $r->dir_config('SiteName');

        return DECLINED unless $site;

        unless exists($ah{$site}) {
            $ah{$site} = HTML::Mason::ApacheHandler->new( ... );
        }

        $ah{$site}->handle_request($r);
    }

This is more flexible but you lose the memory savings of creating all
your objects during server startup.

=head3 Other uses for a wrapper

If you have some code which must I run after a request, then
the only way to guarantee that this happens is to wrap the C<< $ah->handle_request() >>
call in an C block, and then run the
needed code after the request returns.  You can then handle errors
however you like.

=head2 Mixing httpd.conf Configuration with a Wrapper

You can take advantage of Mason's F configuration system
while at the same time providing your own wrapper code.  The key to
doing this is I creating your own ApacheHandler object.  Instead,
you call the C<< HTML::Mason::ApacheHandler->handler() >> class method
from your C subroutine.  Here's a complete wrapper that
does this:

  package MyApp::Mason;

  use strict;
  use HTML::Mason::ApacheHandler;

  sub handler {
      my ($r) = @_;

      return HTML::Mason::ApacheHandler->handler($r);
  }

The C<< HTML::Mason::ApacheHandler->handler >> method will create an
ApacheHandler object based on the configuration directives it finds in
your F file.  Obviously, this wrapper is again a skeleton,
but you could mix and match this wrapper code with any of the code
shown above.

Alternately you could subclass the C
class, and override the C method it provides.  See the
L documentation for more
details.  Of course, you could even create a subclass I write a
wrapper that called it.

=head1 DEVELOPMENT

This section describes how to set up common developer features.

=head2 Global Variables

Global variables can make programs harder to read, maintain, and
debug, and this is no less true for Mason components.  Due to the
persistent mod_perl environment, globals require extra initialization
and cleanup care.

That said, there are times when it is very useful to make a value
available to all Mason components: a DBI database handle, a hash of
user session information, the server root for forming absolute URLs.

Because Mason by default parses components in C mode, you'll
need to declare a global if you don't want to access it with an
explicit package name. The easiest way to declare a global is with
the L parameter.

Since all components run in the same package, you'll be able to set
the global in one component and access it in all the others.

Autohandlers are common places to assign values to globals.  Use the
C<< <%once> >> section if the global only needs to be
initialized at load time, or the C<< <%init> >> section if it
needs to be initialized every request.

=head2 Sessions

Mason does not have a built-in session mechanism, but you can use the
C module, available from CPAN, to
add a session to every request.  It can also automatically set and
read cookies containing the session id.

=head2 Data Caching

Data caching is implemented with DeWitt Clinton's C
module.  For full understanding of this section you should read the
documentation for C as well as for relevant subclasses
(e.g. C).

=over 4

=item Cache files

By default, C is the subclass used for data caching,
although this may be overridden by the developer. C
creates a separate subdirectory for every component that uses caching,
and one file some number of levels underneath that subdirectory for
each cached item.  The root of the cache tree is
L/C. The name of the cache subdirectory for a component
is determined by the function C.

=item Default constructor options

Ordinarily, when C<< $m->cache >> is called, Mason passes to the cache
constructor the C, and C options, along with
any other options given in the C<< $m->cache >> method.

You may specify other default constructor options with the
L parameter. For example,

    PerlSetVar  MasonDataCacheDefaults  "cache_class => SizeAwareFileCache"
    PerlAddVar  MasonDataCacheDefaults  "cache_depth => 2"
    PerlAddVar  MasonDataCacheDefaults  "default_expires_in => 1 hour"

Any options passed to individual C<< $m->cache >> calls override these
defaults.

=item Disabling data caching

If for some reason you want to disable data caching entirely, set the
default C to "NullCache".  This subclass faithfully
implements the cache API but never stores data.

=back

=head1 PERFORMANCE

This section explains Mason's various performance enhancements and how
to administer them. One of the best ways to maximize performance on
your production server is run in L mode; see the third
subsection below.

=head2 Code Cache

When Mason loads a component, it places it in a memory cache. By
default, the cache has no limit, but you can specify a maximum number
of components to cache with the L parameter. In
this case, Mason will free up space as needed by discarding
components. The discard algorithm is least frequently used (LFU), with
a periodic decay to gradually eliminate old frequency information. In
a nutshell, the components called most often in recent history should
remain in the cache.

Previous versions of Mason attempted to estimate the size of each
component, but this proved so inaccurate as to be virtually useless
for cache policy. The max size is now specified purely in number of
components.

Mason can use certain optimizations with an unlimited cache,
especially in conjunction with L, so don't limit the
cache unless experience shows that your servers are growing too
large. Many dynamic sites can be served comfortably with all
components in memory.

You can prepopulate the cache with components that you know will be
accessed often; see L.
Note that preloaded components possess no special status in the cache
and can be discarded like any others.

Naturally, a cache entry is invalidated if the corresponding component
source file changes.

To turn off code caching completely, set L to 0.

=head2 Object Files

The in-memory code cache is only useful on a per-process basis.  Each
process must build and maintain its own cache. Shared memory caches
are conceivable in the future, but even those will not survive between
web server restarts.

As a secondary, longer-term cache mechanism, Mason stores a compiled
form of each component in an object file under L/obj. Any
server process can eval the object file and save time on parsing the
component source file.  The object file is recreated whenever the
source file changes.

The object file pathname is formed from three parts:

=over

=item * the compiler C -
this prevents different versions of Mason or compilers from using the same
object file, such as after an upgrade

=item * the component path

=item * L, by default ".obj"

=back

Besides improving performance, object files can be useful for
debugging.  If you feel the need to see what your source has been
translated into, you can peek inside an object file to see exactly how
Mason converted a given component to a Perl object. This was crucial
for pre-1.10 Mason, in which error line numbers were based on the
object file rather than the source file.

If for some reason you don't want Mason to create object files, set
L to 0.

=head2 Static Source Mode

In L mode, Mason assumes that the component hierarchy
is unchanging and thus does not check source timestamps when using an
in-memory cached component or object file. This significantly reduces
filesystem stats and other overhead. We've seen speedups by a factor
of two or three as a result of this mode, though of course YMMV.

When in L mode, you must remove object files and call
$interp->flush_code_cache in order for the server to recognize
component changes. The easiest way to arrange this is to point
L to a file that can be touched whenever
components change.

We highly recommend running in this mode in production if you can
manage it. Many of Mason's future optimizations will be designed for
this mode. On development servers, of course, it makes sense to keep
this off so that components are reloaded automatically.

=head2 Disabling Autoflush

To support the dynamic L feature, Mason has to check for
autoflush mode after printing every piece of text.  If you can commit
to not using autoflush, setting L to 0 will allow
Mason to compile components more efficiently. Consider whether a few
well-placed C<< $m->flush_buffer >> calls would be just as good as
L.

=head2 Write a handler subroutine

Writing your own C subroutine which uses an ApacheHandler
object (or objects) created during server startup is slightly faster
(around 5% or so) than configuring mason via your F file
and letting Mason create its own ApacheHandler objects internally.

=head2 Preloading Components

You can tell Mason to preload a set of components in the parent
process, rather than loading them on demand, using the L
parameter.  Each child server will start with those components loaded
in the memory cache. The trade-offs are:

=over

=item time

a small one-time startup cost, but children save time by not
having to load the components

=item memory

a fatter initial server, but the memory for preloaded components are
shared by all children.  This is similar to the advantage of using
modules only in the parent process.

=back

Try to preload components that are used frequently and do not change
often.  (If a preloaded component changes, all the children will have
to reload it from scratch.)

=head2 Preallocating the Output Buffer

You can set L to set the size of the
preallocated output buffer for each request. This can reduce the
number of reallocations Perl performs as components output text.

=head1 ERROR REPORTING AND EXCEPTIONS

When an error occurs, Mason can respond by:

=over

=item *

showing a detailed error message in the browser in HTML.

=item *

die'ing, which sends a 500 status to the browser and lets the error
message go to the error logs.

=back

The first behavior is ideal for development, where you want immediate
feedback on the error.  The second behavior is usually desired for
production so that users are not exposed to messy error messages.  You
choose the behavior by setting L to "output" or "fatal"
respectively.

Error formatting is controlled by the L parameter.  When
showing errors in the browser, Mason defaults to the "html" format.
When the L is set to "fatal", the default format is
"line", which puts the entire error message on one line in a format
suitable for web server error logs.  Mason also offers other formats,
which are covered in the L
documentation.

Finally, you can use Apache's C directive to specify a
custom error handler for 500 errors.  In this case, you'd set the
L to "fatal".  The URL specified by the C
directive could point to a Mason component.

=head2 Exceptions Under the Hood

The way that Mason really reports errors is through the use of
exception objects, which are implemented with the C
module from CPAN, and some custom code in the
L module.

If, during the execution of a component, execution stops because some
code calls C, then Mason will catch this exception.  If the
exception being thrown is just a string, then it will be converted to
an C object.  If the exception being thrown is
an object with a C method, then this method will be called.
Otherwise, Mason simply leaves the exception untouched and calls
C again.

=head3 Calling a Component to Handle Errors

Returning to the topic of wrapper code that we covered earlier, what
if you wanted to handle all request errors by calling an error
handling component?  There is no way to do this without wrapper code.
Here's an example C subroutine that does this:

    sub handler {
        my ($r) = @_;

        my $return = eval { $ah->handle_request($r) };

        if ( my $err = $@ )
        {
            $r->pnotes( error => $err );
            $r->filename( $r->document_root . '/error/500.html' );

            return $ah->handle_request($r);
        }

        return $return;
    }

First, we wrap our call to C<< $ah->handle_request() >> in an
C block.  If an error occurs, we store it in the request
object using the C<< $r->pnotes() >> method.  Then we change the
filename property of the Apache request object to point to our
error-handling component and call the C<< $ah->handle_request() >>
method again, passing it the altered request object.  We could have
put the exception in C<< $r->args >>, but we want to leave this
untouched so that the error-handling component can see the original
arguments.

Here's what that component error-handling component might look like:

 
 
 Error
 

 

 

 Looks like our application broke.  Whatever you did, don't do it again!
 


 

 If you have further questions, please feel free to contact us at support@example.com.
 


 
Click here to continue.


 
 

 <%init>
  my $error = $r->pnotes('error');

  my $error_text = "Page is " . $r->parsed_uri->unparse . "\n\n";

  $error_text .= UNIVERSAL::can( $error, 'as_text' ) ? $error->as_text : $error;

  $r->log_error($error_text);

  my $mail =
      MIME::Lite->new
          ( From => 'error-handler@example.com',
            To   => 'rt@example.com',
            Subject => 'Application error',
            Data => $error_text,
          );

  $r->register_cleanup( sub { $mail->send } );
 

 <%flags>
  inherit => undef
 

This component does several things.  First of all, it logs the
complete error to the Apache error logs, along with the complete URL,
including query string, that was requested.  The C<< $r->parsed_uri() >>
method that we use above is only available if the C
module has been loaded.

The component also sends an email containing the error, in this case
to an RT installation, so that the error is logged in a bug tracking
system.  Finally, it displays a less technical error message to the
user.

For this to work properly, you must set L to "fatal", so
that Mason doesn't just display its own HTML error page.

=head1 RUNNING OUTSIDE OF MOD_PERL

Although Mason is most commonly used in conjunction with mod_perl, the
APIs are flexible enough to use in any environment. Below we describe
the two most common alternative environments, CGI and standalone
scripts.

=head2 Using Mason from a CGI Script

The easiest way to use Mason via a CGI script is with the L module.

Here is a skeleton CGI script that calls a component and sends the
output to the browser.

    #!/usr/bin/perl
    use HTML::Mason::CGIHandler;

    my $h = HTML::Mason::CGIHandler->new
     (
      data_dir  => '/home/jethro/code/mason_data',
     );

    $h->handle_request;

The relevant portions of the F file look like:

    DocumentRoot /path/to/comp/root
    ScriptAlias /cgi-bin/ /path/to/cgi-bin/

    
       Action html-mason /cgi-bin/mason_handler.cgi
       AddHandler html-mason .html
    
    
        RemoveHandler .html
    
    
        Order allow,deny
        Deny from all
    

This simply causes Apache to call the mason_handler.cgi script every
time a URL ending in ".html" under the component root is requested.

To exclude certain directories from being under Mason control, you can
use something like the following:

    
        RemoveHandler .html
    

This script uses the L to do
most of the heavy lifting.  See that class's documentation for more
details.

=head2 Using Mason from a Standalone Script

Mason can be used as a pure text templating solution -- like
Text::Template and its brethren, but with more power (and of course
more complexity).

Here is a bare-bones script that calls a component file and sends
the result to standard output:

    #!/usr/bin/perl
    use HTML::Mason;
    use strict;

    my $interp = HTML::Mason::Interp->new ();
    $interp->exec(, ...);

Because no component root was specified, the root is set to your
current working directory.  If you have a well defined and contained
component tree, you'll probably want to specify a component root.

Because no data directory was specified, object files will not be
created and data caching will not work in the default manner. If
performance is an issue, you will want to specify a data directory.

Here's a slightly fuller script that specifies a component root and
data directory, and captures the result in a variable rather than
sending to standard output:

    #!/usr/bin/perl
    use HTML::Mason;
    use strict;

    my $outbuf;
    my $interp = HTML::Mason::Interp->new
        (comp_root  => '/path/to/comp_root',
         data_dir   => '/path/to/data_dir',
         out_method => \$outbuf
        );
    $interp->exec(, ...);

    # Do something with $outbuf

=cut
HTML-Mason-1.59/lib/HTML/Mason/Tools.pm0000644000175000017500000002267413660015140017163 0ustar  autarchautarch# 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.

#
# Miscellaneous tools used by the other Mason modules.  Some of these
# admittedly exist in better versions on CPAN but we rewrite them so
# as to minimize external package requirements.
#

package HTML::Mason::Tools;
$HTML::Mason::Tools::VERSION = '1.59';
use strict;
use warnings;

use Cwd;
use File::Spec;
use HTML::Mason::Exceptions( abbr => [qw(system_error param_error error)] );

require Exporter;

use vars qw(@ISA @EXPORT_OK);

@ISA = qw(Exporter);
@EXPORT_OK = qw(can_weaken read_file read_file_ref url_escape paths_eq compress_path mason_canonpath taint_is_on load_pkg pkg_loaded absolute_comp_path checksum);

# Is weaken available? Even under 5.6+, it might not be available on systems w/o a compiler.
#
BEGIN
{
    require Scalar::Util;

    my $can_weaken = defined &Scalar::Util::weaken ? 1 : 0;

    sub can_weaken () { $can_weaken }
}

# read_file($file, $binmode)
# Return contents of file. If $binmode is 1, read in binary mode.
#
sub read_file
{
    my $fh = _get_reading_handle(@_);
    return do {local $/; scalar <$fh>};
}


# This routine is just like read_file, except more memory-efficient
# and better for large files.  Probably not quite as fast.
#
# Using read_file_ref(), I have verified (in 5.6.1, anyway) that
# reading a file consumes only about as much memory as the size of the
# file.  Using read_file() uses 2x the size of the file.
#
# Don't go using read() willy-nilly, though, it's usually not worth
# the potential bugs.  It's easy to mess up the logic.

sub read_file_ref
{
    my $fh = _get_reading_handle(@_);
    my ($buffer, $retval) = ('');
    while (1) {
        # Important to read in chunks - 16KB is a good compromise
        # between not bloating memory usage and not calling read many
        # times for small files
        $retval = read $fh, $buffer, 1024 * 16, length($buffer);
        system_error "read_file_ref: Couldn't read from '$_[0]': $!"
            unless defined $retval;
        last if !$retval;
    }
    return \$buffer;
}

sub _get_reading_handle {
    my ($file,$binmode) = @_;
    error "read_file: '$file' does not exist" unless -e $file;
    error "read_file: '$file' is a directory" if (-d _);
    open my $fh, "< $file"
        or system_error "read_file: could not open file '$file' for reading: $!";
    binmode $fh if $binmode;
    return $fh;
}

#
# Determines whether two paths are equal, taking into account
# case-insensitivity in Windows O/S.
#
sub paths_eq {
    return File::Spec->case_tolerant ? (lc($_[0]) eq lc($_[1])) : $_[0] eq $_[1];
}

#
# Compress a component path into a single, filesystem-friendly
# string. Uses URL-like escaping with + instead of %.
#
sub compress_path
{
    my ($path) = @_;
    for ($path) {
        s@^/@@;
        s/([^\w\.\-\~])/sprintf('+%02x', ord $1)/eg;
    }
    return $path;
}

#
# Return the absolute version of a component path. Handles . and ..
# Second argument is directory path to resolve relative paths against.
#
sub absolute_comp_path
{
    my ($comp_path, $dir_path) = @_;

    $comp_path = "$dir_path/$comp_path" if $comp_path !~ m@^/@;
    return mason_canonpath($comp_path);
}


#
# Makes a few fixes to File::Spec::canonpath. Will go away if/when they
# accept our patch.
#
sub mason_canonpath {
    # Just like File::Spec::canonpath, but we're having trouble
    # getting a patch through to them.
    my $path = shift;
    $path =~ s|/+|/|g;                                 # xx////yy  -> xx/yy
    $path =~ s|(?:/\.)+/|/|g;                          # xx/././yy -> xx/yy
    {
        $path =~ s|^(?:\./)+||s unless $path eq "./";  # ./xx      -> xx
        $path =~ s|^/(?:\.\./)+|/|s;                   # /../../xx -> xx
        $path =~ s|/\Z(?!\n)|| unless $path eq "/";    # xx/       -> xx
        $path =~ s|/[^/]+/\.\.$|| && redo;             # /xx/..    -> /
        $path =~ s|[^/]+/\.\./|| && redo;              # /xx/../yy -> /yy
    }
    return $path;
}

#
# Determine if package is installed without loading it, by checking
# the INC path.
#
sub pkg_installed
{
    my ($pkg) = @_;

    (my $pkgfile = "$pkg.pm") =~ s{::}{/}g;
    return grep(-f "$_/$pkgfile",@INC);
}

#
# Determined if package is loaded by checking for its version.
#
sub pkg_loaded
{
    my ($pkg) = @_;

    my $varname = "${pkg}::VERSION";
    no strict 'refs';
    return $$varname ? 1 : 0;
}

#
# Load package $pkg if not already loaded. Return 1 if file was found
# and loaded successfully. When file is not found: if optional second
# argument $nf_error is provided, die with that error message,
# otherwise return 0. Errors while loading the package are always
# passed through as fatal errors.
#
sub load_pkg {
    my ($pkg, $nf_error) = @_;

    my $file = File::Spec->catfile( split /::/, $pkg );
    $file .= '.pm';
    return 1 if exists $INC{$file};

    eval "use $pkg";

    if ($@) {
        if ($@ =~ /^Can\'t locate (.*) in \@INC/) {
            if (defined($nf_error)) {
                error sprintf("Can't locate %s in \@INC. %s\n(\@INC contains: %s)",
                              $1, $nf_error, join(" ", @INC));
            } else {
                undef $@;
                return 0;
            }
        } else {
            error $@;
        }
    }
    return 1;
}

# This code seems to be very fragile!  Please don't check in changes
# unless you've tested it with Perl 5.00503, 5.6.1, and 5.8.0, or at
# least tell Dave to run the tests.
my $TaintIsOn;
sub taint_is_on
{
    return $TaintIsOn if defined $TaintIsOn;
    return $TaintIsOn = _taint_is_on();
}

sub _taint_is_on
{
    if ( $] >= 5.008 )
    {
        # We have to eval a string because this variable name causes
        # earlier Perls to not compile at all.
        return eval '${^TAINT}' ? 1 : 0;
    }
    else
    {
        local $^W;
        eval { "+$0$^X" && eval 1 };
        return $@ ? 1 : 0;
    }
}

sub coerce_to_array
{
    my ($val, $name) = @_;

    return ($val) unless ref $val;

    if ( UNIVERSAL::isa( $val, 'ARRAY' ) )
    {
        return @$val;
    }
    elsif ( UNIVERSAL::isa( $val, 'HASH' ) )
    {
        return %$val;
    }

    param_error "Cannot coerce $val to an array for '$name' parameter";
}

sub coerce_to_hash
{
    my ($val, $name) = @_;

    param_error "Cannot convert a single value to a hash for '$name' parameter"
        unless ref $val;

    if ( UNIVERSAL::isa( $val, 'ARRAY' ) )
    {
        return @$val;
    }
    elsif ( UNIVERSAL::isa( $val, 'HASH' ) )
    {
        return %$val;
    }

    param_error "Cannot coerce $val to a hash";
}

# Adler32 algorithm
sub checksum {
    my ($str) = @_;
    
    my $s1 = 1;
    my $s2 = 1;
    for my $c (unpack("C*", $str)) {
        $s1 = ($s1 + $c ) % 65521;
        $s2 = ($s2 + $s1) % 65521;
    }
    return ($s2 << 16) + $s1;
}

1;

__END__

=head1 NAME

HTML::Mason::Tools - Function library used internally in Mason

=head1 DESCRIPTION

This module contains exportable functions that are intended to be used
by other Mason modules.

The documentation here is primarily intended to be used by Mason core
developers.

Others who choose to use these functions do so at their own risk, as
they may change from release to release.  You have been warned.

=head1 FUNCTIONS

=over

=item read_file

This function takes a file name and an optional argument indicating
whether or not to open the final in binary mode.  It will return the
entire contents of the file as a scalar.

=item paths_eq

Given to paths, this function indicates whether they represent the
same location on the filesystem.  It does not account for symlinks.

=item compress_path

This turns a component path into a filesystem-friendly path by
escaping potentially meaningful characters.

=item absolute_comp_path

Given a component path and a directory path, this function returns the
absolute component path, prepending the directory path if needed.

=item mason_canonpath

This function cleans up a component path and returns its canonical
version.  It is largely the same as File::Spec::Unix::canonpath, with
a few additional cleanups.

=item pkg_installed

Given a module name, this function returns true or false to indicate
whether or not a corresponding F<.pm> file exists.

=item pkg_loaded

Given a module name, this function returns true or false to indicate
whether or not the module has been loaded into memory.

=item load_pkg

Given a module name, this function attempts to load it.  It takes an
additional boolean parameter indicating whether or not to throw an
exception if the module cannot be found.  By default, if the module
cannot be found, this function simply returns false.

All errors generate exceptions no matter what.

If the module is loaded successfully, this function returns true.

=item taint_is_on

Returns a boolean value indicating whether taint mode is on or not.

=item coerce_to_array

Given a scalar, which may be a reference, this function attempts to
return an array.  It throws an HTML::Mason::Exception::Params
exception if this can't be done.

This function is called from the generated component code as part of a
component's argument handling.

=item coerce_to_hash

Given a scalar, which may be a reference, this function attempts to
return a hash.  It throws an HTML::Mason::Exception::Params exception
if this can't be done.

This function is called from the generated component code as part of a
component's argument handling.

=item checksum

Computes a simple checksum of a string. Used for Compiler::object_id.

=back

=cut
HTML-Mason-1.59/lib/HTML/Mason.pm0000644000175000017500000002244213660015140016054 0ustar  autarchautarchpackage 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.
$HTML::Mason::VERSION = '1.59';
use 5.006;

use HTML::Mason::Interp;

sub version
{
    return $HTML::Mason::VERSION;
}

1;

# ABSTRACT: High-performance, dynamic web site authoring system

__END__

=pod

=encoding UTF-8

=head1 NAME

HTML::Mason - High-performance, dynamic web site authoring system

=head1 VERSION

version 1.59

=head1 SYNOPSIS

    PerlModule HTML::Mason::ApacheHandler

    
        SetHandler perl-script
        PerlHandler HTML::Mason::ApacheHandler
    

=head1 DESCRIPTION

Mason is a tool for building, serving and managing large web
sites. Its features make it an ideal backend for high load sites
serving dynamic content, such as online newspapers or database driven
e-commerce sites.

Actually, Mason can be used to generate any sort of text, whether for
a web site or not.  But it was originally built for web sites and
since that's why most people are interested in it, that is the focus
of this documentation.

Mason's various pieces revolve around the notion of "components''. A
component is a mix of HTML, Perl, and special Mason commands, one
component per file. So-called "top-level" components represent entire
web-pages, while smaller components typically return HTML snippets for
embedding in top-level components. This object-like architecture
greatly simplifies site maintenance: change a shared component, and
you instantly changed all dependent pages that refer to it across a
site (or across many virtual sites).

Mason's component syntax lets designers separate a web page into
programmatic and design elements. This means the esoteric Perl bits
can be hidden near the bottom of a component, preloading simple
variables for use above in the HTML. In our own experience, this frees
content managers (i.e., non-programmers) to work on the layout without
getting mired in programming details. Techies, however, still enjoy
the full power of Perl.

Mason works by intercepting innocent-looking requests (say,
http://www.yoursite.com/index.html) and mapping them to requests for
Mason components.  Mason then compiles the component, runs it, and
feeds the output back to the client.

Consider this simple Mason component:

    % my $noun = 'World';
    Hello <% $noun %>!
    How are ya?

The output of this component is:

    Hello World!
    How are ya?

In this component you see a mix of standard HTML and Mason
elements. The bare '%' prefixing the first line tells Mason that this
is a line of Perl code. One line below, the embedded S%
... %E> tag gets replaced with the return value of its contents,
evaluated as a Perl expression.

Beyond this trivial example, components can also embed serious chunks
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 MAINTENANCE HELP NEEDED

I (Dave Rolsky) am no longer using HTML::Mason and I would love to find some
co-maintainers to help. Specifically, I'd like people to review issues and
PRs, create new PRs, and ultimately take on the task of uploading new releases
to CPAN. If you're interested the best way to start is to fix one or more of
the issues in the L.

=head1 WAIT - HAVE YOU SEEN MASON 2?

Version 1 of Mason (this distribution) -- 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 -- was released in February of 2011. It offers
a new syntax as well as a number of other features. See
L
for details of the differences between the two.

=head1 INSTALLATION

Mason has been tested under Linux, FreeBSD, Solaris, HPUX, and
Win32. As an all-Perl solution, it should work on any machine that has
working versions of Perl 5.00503+, mod_perl, and the required CPAN
modules.

Mason has a standard MakeMaker-driven installation. See the README
file for details.

=head1 CONFIGURING MASON

This section assumes that you are able to install and configure a
mod_perl server. Relevant documentation is available at
http://www.apache.org (Apache) and http://perl.apache.org
(mod_perl). The mod_perl mailing list, archive, and guide are also
great resources.

The simplest configuration of Mason requires a few lines in your
httpd.conf:

    PerlModule HTML::Mason::ApacheHandler

    
        SetHandler perl-script
        PerlHandler HTML::Mason::ApacheHandler
    

The PerlModule directive simply ensures that the Mason code is loaded
in the parent process before forking, which can save some memory when
running mod_perl.

The  section routes all requests to the Mason handler, which
is a simple way to try out Mason. A more refined setup is discussed
in the L 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
haven't broken anything. If all goes well you should see the same page
as before. If not, recheck your Apache config files and also tail your
server's error log.

If you are getting "404 Not Found" errors even when the files clearly
exist, Mason may be having trouble with your document root. One
situation that will unfortunately confuse Mason is if your document
root goes through a symbolic link. Try expressing your document root
in terms of the true filesystem path.

Next, try adding the tag <% 2+2 %> at the top of some HTML file. If you
reload this page and see a "4", Mason is working!

=head1 DOCUMENTATION ROADMAP

Once Mason is on its feet, the next step is to write a component or
two. The L is a
complete tutorial for writing, using, and debugging components. A
reference companion to the Developer's Manual is the Request API
documentation, L.

Whoever is responsible for setting up and tuning Mason should read the
L, though developers
will also benefit from reading it as well. This document covers more
advanced configuration scenarios and performance optimization. The
reference companion to the Administrator's manual is the
L, which describes all the
parameters you can use to configure Mason.

Most of this documentation assumes that you're running Mason on top of
mod_perl, since that is the most common configuration.  If you would
like to run Mason via a CGI script, refer to the
L documentation.
If you are using Mason from a standalone program, refer to
the L section of the administrator's manual.

There is also a book about Mason, I, 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.

=head1 GETTING HELP AND SOURCES

Questions and feedback are welcome, and should be directed to the Mason
mailing list. You must be subscribed to post.

    https://lists.sourceforge.net/lists/listinfo/mason-users

You can also visit us at C<#mason> on L.

Bugs and feature requests will be tracked at RT:

    http://rt.cpan.org/NoAuth/Bugs.html?Dist=HTML-Mason
    bug-html-mason@rt.cpan.org

=head1 SUPPORT

Bugs may be submitted at L.

I am also usually active on IRC as 'autarch' on C.

=head1 SOURCE

The source code repository for HTML-Mason can be found at L.

=head1 AUTHORS

=over 4

=item *

Jonathan Swartz 

=item *

Dave Rolsky 

=item *

Ken Williams 

=back

=head1 CONTRIBUTORS

=for stopwords Ævar Arnfjörð Bjarmason Alex Balhatchet Vandiver Florian Schlichting John Williams Kent Fredric Kevin Falcone Patrick Kane Ricardo Signes Shlomi Fish

=over 4

=item *

Ævar Arnfjörð Bjarmason 

=item *

Alex Balhatchet 

=item *

Alex Vandiver 

=item *

Florian Schlichting 

=item *

John Williams 

=item *

Kent Fredric 

=item *

Kevin Falcone 

=item *

Patrick Kane 

=item *

Ricardo Signes 

=item *

Shlomi Fish 

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 1998 - 2020 by Jonathan Swartz.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

The full text of the license can be found in the
F file included with this distribution.

=cut
HTML-Mason-1.59/xt/0000755000175000017500000000000013660015140013556 5ustar  autarchautarchHTML-Mason-1.59/xt/release/0000755000175000017500000000000013660015140015176 5ustar  autarchautarchHTML-Mason-1.59/xt/release/meta-json.t0000644000175000017500000000006413660015140017260 0ustar  autarchautarch#!perl

use Test::CPAN::Meta::JSON;
meta_json_ok();
HTML-Mason-1.59/xt/author/0000755000175000017500000000000013660015140015060 5ustar  autarchautarchHTML-Mason-1.59/xt/author/pod-spell.t0000644000175000017500000000555613660015140017157 0ustar  autarchautarchuse strict;
use warnings;
use Test::More;

# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007005
use Test::Spelling 0.12;
use Pod::Wordlist;


add_stopwords();
all_pod_files_spelling_ok( qw( bin lib ) );
__DATA__
AUTOHANDLERS
Admin
Adminstrator
Alex
Apache
ApacheHandler
ApacheModPerl
ApacheReload
Arnfjörð
Autohandlers
Balhatchet
BaseCache
Bekman
Bjarmason
CGI
CGIHandler
Cache
Compiler
Component
ComponentSource
ContactUs
Context
DROLSKY
DROLSKY's
DSO
Dave
DeWitt
Devel
DocumentRoot
DocumentRoots
Escapes
Exceptions
FAQ
FakeApache
Falcone
FastCGI
File
FileBased
FilesMatch
Fish
Florian
Follett
ForceFileDownload
Fredric
GIF
Georgiou
HPUX
HTML
HUP
Handler
HandlingDirectoriesWithDhandlers
Interp
John
Jonathan
Kane
Ken
Kent
Kevin
Khera
Kiriakos
Kirwan
Kumar
LFU
Lexer
LogLevel
MSIE
MailingLists
Mallah
Mason
MasonAllowGlobals
MasonApacheStatusTitle
MasonArgsMethod
MasonAutoSendHeaders
MasonAutoflush
MasonAutohandlerName
MasonBufferPreallocateSize
MasonCodeCacheMaxSize
MasonCompClass
MasonCompRoot
MasonCompilerClass
MasonComponentErrorHandler
MasonDataCacheApi
MasonDataCacheDefaults
MasonDataDir
MasonDeclineDirs
MasonDefaultEscapeFlags
MasonDefineArgsHash
MasonDhandlerName
MasonDynamicCompRoot
MasonEnableAutoflush
MasonErrorFormat
MasonErrorMode
MasonEscapeFlags
MasonIgnoreWarningsExpr
MasonInPackage
MasonInterpClass
MasonLexerClass
MasonMaxRecurse
MasonNamedComponentSubs
MasonObjectFileExtension
MasonOutMethod
MasonPlugins
MasonPostamble
MasonPostprocessPerl
MasonPostprocessText
MasonPreamble
MasonPreloads
MasonPreprocess
MasonRequestClass
MasonResolverClass
MasonStaticSource
MasonStaticSourceTouchFile
MasonSubcompClass
MasonUseObjectFiles
MasonUseSourceLineNumbers
MasonUseStrict
MasonUseWarnings
MethodMaker
Null
NullCache
O'Reilly
PRs
Params
Parser
Patrick
PayPal
PerlFreshRestart
PerlHandler
PerlModule
PerlSetVar
Plugin
Preallocating
Preloading
RPMs
Rajesh
RedHat
ReloadAll
Request
Resolver
Ricardo
Rolsky
Rolsky's
SUBCLASSABLE
SYNOPIS
Schlichting
Shlomi
Signes
Solaris
SpeedyCGI
Stas
Subclassing
Subcomponent
Subcomponents
Subrequests
Swartz
TIEHASH
Tests
ToObject
Tools
USR
UserDir
Utils
Vandiver
Vivek
Williams
ala
alex
apachectl
apachehandler
attr
autarch
autohandler
autohandlers
avarab
bgcolor
bin
breakpoint'able
certian
checksum
conf
convert0
corrup
defined'ness
dhandler
dhandlers
drolsky
dynamicImage
falcone
faq
fh
fido
filenaming
foobarbaz
fsfs
gif
gifs
htaccess
html
interp
isNetscape
ized
izing
jpegs
jwilliams
kaoru
ken
kentnl
lexed
lib
libapreq
libexpat
mason
mc
mcomp
mhtml
modus
mpl
mtxt
nh
onwards
optimizations
overrideable
perlsub
postprocess
predeclaring
preload
preloaded
preloading
preloads
prepopulate
preprocess
profiler
rdist
reallocations
reparsed
reuseability
rjbs
scomp
se
serializable
shlomif
sql
srm
subcomponent
subcomponents
subcomps
subexec
subrequest
subrequests
swartz
taglibs
tgz
tmp
todo
un
undeclarable
unweakened
updateable
uring
use'd
xml
Ævar
HTML-Mason-1.59/xt/author/no-tabs.t0000644000175000017500000000505413660015140016614 0ustar  autarchautarchuse strict;
use warnings;

# this test was generated with Dist::Zilla::Plugin::Test::NoTabs 0.15

use Test::More 0.88;
use Test::NoTabs;

my @files = (
    'bin/convert0.6.README',
    'bin/convert0.6.pl',
    'bin/convert0.8.README',
    'bin/convert0.8.pl',
    'bin/mason.pl',
    'lib/HTML/Mason.pm',
    'lib/HTML/Mason/Admin.pod',
    'lib/HTML/Mason/Apache/Request.pm',
    'lib/HTML/Mason/ApacheHandler.pm',
    'lib/HTML/Mason/CGIHandler.pm',
    'lib/HTML/Mason/Cache/BaseCache.pm',
    'lib/HTML/Mason/Compiler.pm',
    'lib/HTML/Mason/Compiler/ToObject.pm',
    'lib/HTML/Mason/Component.pm',
    'lib/HTML/Mason/Component/FileBased.pm',
    'lib/HTML/Mason/Component/Subcomponent.pm',
    'lib/HTML/Mason/ComponentSource.pm',
    'lib/HTML/Mason/Devel.pod',
    'lib/HTML/Mason/Escapes.pm',
    'lib/HTML/Mason/Exceptions.pm',
    'lib/HTML/Mason/FAQ.pod',
    'lib/HTML/Mason/FakeApache.pm',
    'lib/HTML/Mason/Handler.pm',
    'lib/HTML/Mason/Interp.pm',
    'lib/HTML/Mason/Lexer.pm',
    'lib/HTML/Mason/MethodMaker.pm',
    'lib/HTML/Mason/Params.pod',
    'lib/HTML/Mason/Parser.pm',
    'lib/HTML/Mason/Plugin.pm',
    'lib/HTML/Mason/Plugin/Context.pm',
    'lib/HTML/Mason/Request.pm',
    'lib/HTML/Mason/Resolver.pm',
    'lib/HTML/Mason/Resolver/File.pm',
    'lib/HTML/Mason/Resolver/Null.pm',
    'lib/HTML/Mason/Subclassing.pod',
    'lib/HTML/Mason/Tests.pm',
    'lib/HTML/Mason/Tools.pm',
    'lib/HTML/Mason/Utils.pm',
    't/00-report-prereqs.dd',
    't/00-report-prereqs.t',
    't/01-syntax.t',
    't/01a-comp-calls.t',
    't/02-sections.t',
    't/02a-filter.t',
    't/04-misc.t',
    't/05-request.t',
    't/05a-stack-corruption.t',
    't/06-compiler.t',
    't/06a-compiler_obj.t',
    't/06b-compiler-named-subs.t',
    't/06c-compiler-spaces-path.t',
    't/07-interp.t',
    't/07a-interp-mcr.t',
    't/07b-interp-static-source.t',
    't/09-component.t',
    't/09a-comp_content.t',
    't/10-cache.t',
    't/10a-cache-1.0x.t',
    't/10b-cache-chi.t',
    't/11-inherit.t',
    't/12-taint.t',
    't/13-errors.t',
    't/14-cgi.t',
    't/14a-fake_apache.t',
    't/15-subclass.t',
    't/17-print.t',
    't/18-leak.t',
    't/19-subrequest.t',
    't/20-plugins.t',
    't/21-escapes.t',
    't/22-path-security.t',
    't/23-leak2.t',
    't/24-tools.t',
    't/25-flush-in-content.t',
    't/25-log.t',
    't/lib/Apache/test.pm',
    't/lib/BadModule.pm',
    't/lib/LoadTest.pm',
    't/lib/Mason/ApacheTest.pm',
    't/run_one_test',
    't/run_tests',
    't/single_test.pl',
    't/taint.comp'
);

notabs_ok($_) foreach @files;
done_testing;
HTML-Mason-1.59/xt/author/mojibake.t0000644000175000017500000000015113660015140017023 0ustar  autarchautarch#!perl

use strict;
use warnings qw(all);

use Test::More;
use Test::Mojibake;

all_files_encoding_ok();
HTML-Mason-1.59/xt/author/test-version.t0000644000175000017500000000063713660015140017715 0ustar  autarchautarchuse strict;
use warnings;
use Test::More;

# generated by Dist::Zilla::Plugin::Test::Version 1.09
use Test::Version;

my @imports = qw( version_all_ok );

my $params = {
    is_strict      => 1,
    has_version    => 1,
    multiple       => 0,

};

push @imports, $params
    if version->parse( $Test::Version::VERSION ) >= version->parse('1.002');

Test::Version->import(@imports);

version_all_ok;
done_testing;
HTML-Mason-1.59/xt/author/pod-syntax.t0000644000175000017500000000025213660015140017352 0ustar  autarchautarch#!perl
# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests.
use strict; use warnings;
use Test::More;
use Test::Pod 1.41;

all_pod_files_ok();
HTML-Mason-1.59/weaver.ini0000644000175000017500000000025413660015140015116 0ustar  autarchautarch[@CorePrep]
[Generic / NAME]
[Version]
[Generic / SYNOPSIS]
[Generic / DESCRIPTION]
[Leftovers]
[=inc::Pod::Weaver::Section::SeeAlsoMason]
[Authors]
[Contributors]
[Legal]
HTML-Mason-1.59/cpanfile0000644000175000017500000000273613660015140014637 0ustar  autarchautarch# This file is generated by Dist::Zilla::Plugin::CPANFile v6.014
# Do not edit this file directly. To change prereqs, edit the `dist.ini` file.

requires "CGI" => "2.46";
requires "Cache::Cache" => "1.00";
requires "Class::Container" => "0.07";
requires "Exception::Class" => "1.15";
requires "File::Spec" => "0.8";
requires "HTML::Entities" => "0";
requires "Log::Any" => "0.08";
requires "Params::Validate" => "0.70";
requires "Scalar::Util" => "1.01";

on 'test' => sub {
  requires "ExtUtils::MakeMaker" => "0";
  requires "File::Spec" => "0.8";
  requires "Test::Deep" => "0";
  requires "Test::More" => "0.96";
};

on 'test' => sub {
  recommends "CPAN::Meta" => "2.120900";
};

on 'configure' => sub {
  requires "ExtUtils::MakeMaker" => "0";
};

on 'configure' => sub {
  suggests "JSON::PP" => "2.27300";
};

on 'develop' => sub {
  requires "CHI" => "0.21";
  requires "Code::TidyAll" => "0.56";
  requires "Code::TidyAll::Plugin::SortLines::Naturally" => "0.000003";
  requires "Code::TidyAll::Plugin::Test::Vars" => "0.02";
  requires "Parallel::ForkManager" => "1.19";
  requires "Perl::Critic" => "1.126";
  requires "Perl::Tidy" => "20160302";
  requires "Test::CPAN::Meta::JSON" => "0.16";
  requires "Test::Memory::Cycle" => "0";
  requires "Test::Mojibake" => "0";
  requires "Test::More" => "0.88";
  requires "Test::NoTabs" => "0";
  requires "Test::Pod" => "1.41";
  requires "Test::Spelling" => "0.12";
  requires "Test::Vars" => "0.009";
  requires "Test::Version" => "2.05";
};
HTML-Mason-1.59/t/0000755000175000017500000000000013660015140013366 5ustar  autarchautarchHTML-Mason-1.59/t/13-errors.t0000644000175000017500000003565713660015140015330 0ustar  autarchautarchuse strict;
use warnings;

use Cwd qw(realpath);
use File::Basename;
use File::Spec;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);

my $root_dir = realpath(dirname(dirname($0)));
my $tests = make_tests();
$tests->run;

# Using this as an error_format with error_mode='output' causes just
# the error string to be output
sub HTML::Mason::Exception::as_munged
{
    my $err = shift->error;
    
    return $err =~ /^(.+?) at/ ? $1 : $err;
}

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'errors',
                                                      description => 'Test that errors are generated properly' );

#------------------------------------------------------------

    $group->add_support( path => '/support/error_helper',
                         component => <<'EOF',
<%init>
eval { $m->comp('error1')  };
$m->comp('error2');

EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/error1',
                         component => <<'EOF',
% die "terrible error";
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/error2',
                         component => <<'EOF',
% die "horrible error";
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'bad_args',
                      description => 'Make sure a bad args line is caught properly',
                      component => <<'EOF',
<%args>
foo

EOF
                      expect_error => qr|Invalid <%args> section line|
                    );

#------------------------------------------------------------

    $group->add_test( name => 'backtrace',
                      description => 'Make sure trace for second error is accurate when first error is caught by eval',
                      component => <<'EOF',
<%init>
$m->comp('support/error_helper');

EOF
                      expect_error => q|horrible error.*|
                    );

#------------------------------------------------------------

    # This fails as root because the file will always be readable, but
    # we can't know that it will fail until we're inside the test.  So
    # we'll just run this test for developers, not end users.
    if ( $ENV{MASON_MAINTAINER} )
    {
        $group->add_support( path => '/support/unreadable',
                             component => <<'EOF',
unreadable
EOF
                           );

        my $file = File::Spec->catfile( $group->comp_root, 'errors', 'support', 'unreadable' );

        $group->add_test( name => 'cannot_read_source',
                          description => 'Make sure that Mason throws a useful error when it cannot read a source file',
                          component => <<"EOF",
<%init>
chmod 0222, '$file'
    or die "Cannot chmod file for " . '$file' . ": \$!";
\$m->comp('support/unreadable');

EOF
                          expect_error => q|Permission denied|
                        );
    }

#------------------------------------------------------------

    $group->add_support( path => '/support/zero_size',
                         component => '',
                       );

#------------------------------------------------------------

    $group->add_test( name => 'read_zero_size',
                      description => 'Make sure that Mason handles a zero length source file correctly',
                      component => <<'EOF',
zero[<& support/zero_size &>]zero
EOF
                      expect => <<'EOF'
zero[]zero
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'bad_source_callback',
                      description => 'Make sure that a bad source_callback for a ComponentSource object reports a useful error',
                      interp_params => { resolver_class => 'My::Resolver' },
                      component => <<'EOF',
does not matter
EOF
                      expect_error => qr/Undefined subroutine.*will_explode/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'bad_escape_flag',
                      description => 'Make sure that an invalid escape flag is reported properly',
                      component => <<'EOF',
<% 1234 | abc %>
EOF
                      expect_error => qr/Invalid escape flag: abc/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'error_mode_output',
                      description => 'Make sure that existing output is cleared when an error occurs in error_mode=output',
                      interp_params => { error_format => 'munged',
                                         error_mode => 'output',
                                       },
                      component => <<'EOF',
Should not appear in output!
% $m->comp( '/errors/support/error1' );
EOF
                      expect => <<'EOF',
terrible error
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'error_in_subrequest',
                      description => 'Make sure that an error in a subrequest is propogated back to the main request',
                      interp_params => { error_format => 'munged',
                                         error_mode => 'output',
                                       },
                      component => <<'EOF',
Should not appear in output!
% $m->subexec( '/errors/support/error1' );
EOF
                      expect => <<'EOF',
terrible error
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'check_error_format',
                      description => 'Make sure setting error_format => "html" works',
                      interp_params => { error_format => 'html',
                                         error_mode => 'output',
                                       },
                      component => <<'EOF',
% die("Horrible death");
EOF
                      expect => qr{^\s+.*Horrible death}is,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'check_exec_not_found',
                      description => 'Request to non-existent component',
                      component => <<'EOF',
% $m->subexec("/does/not/exist");
EOF
                      expect_error => qr{could not find component for initial path}is,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'check_exec_not_found_html_format',
                      description => 'Request to non-existent component in html format',
                      interp_params => { error_format => 'html',
                                         error_mode => 'output',
                                       },
                      component => <<'EOF',
% $m->subexec("/does/not/exist");
EOF
                      expect => qr{^\s+.*could not find component for initial path}is,
                      );

#------------------------------------------------------------

    $group->add_test( name => 'check_comp_not_found',
                      description => 'Component call to non-existent component',
                      component => <<'EOF',
% $m->comp("/does/not/exist");
EOF
                      expect_error => qr{could not find component for path}is,
                      );

#------------------------------------------------------------

    $group->add_test( name => 'change_error_format',
                      description => 'Make sure setting $m->error_format($foo) works on the fly',
                      interp_params => { error_format => 'html',
                                         error_mode => 'output',
                                       },
                      component => <<'EOF',
% $m->error_format('text');
% die("Horrible death");
EOF
                      expect => qr{^Horrible death},
                    );

#------------------------------------------------------------

    $group->add_test( name => 'check_error_format_brief',
                      description => 'Make sure setting error_format => "brief" works',
                      interp_params => { error_format => 'brief',
                                         error_mode => 'output',
                                       },
                      component => <<'EOF',
% die("Horrible death");
EOF
                      expect => qr{^Horrible death at .*check_error_format_brief line \d+\.$}s,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'object_exception',
                      description => "Make sure Mason doesn't co-opt non Exception::Class exception objects",
                      component => <<'EOF',
% eval { die bless { foo => 'bar' }, 'FooException' };
<% ref $@ %>
EOF
                      expect => <<'EOF',
FooException
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'subcomponent_redefined',
                      description => "Make sure Mason doesn't allow redefinition of subcomponent",
                      component => <<'EOF',
<%def foo>
foo

<%def foo>
foo

EOF
                      expect_error => qr/Duplicate definition of subcomponent/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'method_redefined',
                      description => "Make sure Mason doesn't allow redefinition of method",
                      component => <<'EOF',
<%method foo>
foo

<%method foo>
foo

EOF
                      expect_error => qr/Duplicate definition of method/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'method_subcomp_conflict',
                      description => "Make sure Mason doesn't allow a subcomponent and method to have the same name",
                      component => <<'EOF',
<%method foo>
foo

<%def foo>
foo

EOF
                      expect_error => qr/with the same name/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'subcomp_bad_name',
                      description => "Make sure Mason doesn't allow a subcomponent with a bad name",
                      component => <<'EOF',
<%def abc+def>
foo

EOF
                      expect_error => qr/Invalid def name/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'content_comp_wrong_error',
                      description => "Make sure syntax error inside <&|>  tags is thrown correctly",
                      component => <<'EOF',
<&| ttt &>
<%

<%def ttt>

EOF
                      expect_error => qr/'<%' without matching '%>'/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'top_level_compilation_error',
                      description => "Make sure top-level compiler errors work in output mode",
                      interp_params => {
                                         error_format => 'text',
                                         error_mode => 'output',
                                       },
                      component => <<'EOF',
% my $x = 
EOF
                        # match "Error during compilation" followed by 
                        # exactly one occurance of "Stack:"
                        # (Mason should stop after the first error)
                      expect => qr/Error during compilation((?!Stack:).)*Stack:((?!Stack:).)*$/s,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'component_error_handler_false',
                      description => 'Test error-handling with component_error_handler set to false',
                      interp_params => { component_error_handler => 0 },
                      component => <<'EOF',
% die 'a string error';
EOF
                      expect_error => qr/a string error/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'component_error_Handler_no_upgrade',
                      description => 'Test that errors do not become object with component_error_handler set to false',
                      interp_params => { component_error_handler => 0 },
                      component => <<'EOF',
% eval { die 'a string error' };
exception: <% ref $@ ? ref $@ : 'not a ref' %>
EOF
                      expect => <<'EOF',
exception: not a ref
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'component_error_handler_false_fatal_mode',
                      description => 'Test error-handling with component_error_handler set to false and error_mode set to fatal',
                      interp_params => { component_error_handler => 0,
                                         error_mode => 'fatal',
                                       },
                      component => <<'EOF',
% die 'a string error';
EOF
                      expect_error => qr/a string error/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'component_error_handler_uc_message',
                      description => 'Test error-handling with component_error_handler set to a subroutine that upper-cases all text',
                      interp_params => { component_error_handler => sub { die map { uc } @_ } },
                      component => <<'EOF',
% die 'a string error';
EOF
                      expect_error => qr/A STRING ERROR/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'use_bad_module',
                      description => 'Use a module with an error',
                      component => <<'EOF',
<%init>
use lib qw(t/lib); use BadModule;

hi!
EOF
                      expect_error => qr/syntax error/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'require_bad_module_in_once',
                      description => 'Require a module with an error in a once block',
                      component => <<'EOF',
<%once>
require "./t/lib/BadModule.pm";

hi!
EOF
                      expect_error => qr/syntax error/,
                    );

#------------------------------------------------------------

    return $group;
}

package My::Resolver;

use base 'HTML::Mason::Resolver::File';

sub get_info
{
    my $self = shift;

    if ( my $source = $self->SUPER::get_info(@_) )
    {
        $source->{source_callback} = sub { will_explode() };

        return $source;
    }
}
HTML-Mason-1.59/t/06a-compiler_obj.t0000644000175000017500000000121513660015140016602 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason;
use Test;
plan tests => 4;

ok 1;  # Loaded

# We use the Interp class as a front-end to the compiler, but we're
# really testing the compiler here.  We could change this to eliminate
# the Interp stuff, probably.

my $interp = HTML::Mason::Interp->new;
ok $interp;

# Make sure the compiler can recover properly after a syntax error
eval {$interp->make_component( comp_source => <<'EOF' )};
  <&| syntax_error, in => "this" &>
    component
  
EOF
ok $@, qr{ending tag};

eval {$interp->make_component( comp_source => <<'EOF' )};
  <&| syntax_error, in => "this" &>
    component
  
EOF
ok $@, '';

HTML-Mason-1.59/t/06c-compiler-spaces-path.t0000644000175000017500000000100513660015140020155 0ustar  autarchautarchuse strict;
use warnings;

use Config;
use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests {
    my $group = HTML::Mason::Tests->tests_class->new(
        name        => 'has space',
        description => 'compiler test for paths with spaces'
    );

    $group->add_test(
        name        => 'whatever',
        description => 'error in component in path with spaces',
        component   => <<'EOF',
% $foo = 1;
EOF
        expect_error => qr/.+line 1/,
    );

    return $group;
}
HTML-Mason-1.59/t/01a-comp-calls.t0000644000175000017500000002226613660015140016174 0ustar  autarchautarchuse strict;
use warnings;

use File::Basename;
use HTML::Mason::Tests;

my $outside_comp_root_test_file;
my $tests = make_tests();
$tests->run;

sub make_tests
{

    my $group = HTML::Mason::Tests->tests_class->new( name => 'comp-calls',
                                                      description => 'Component call syntax' );
    $outside_comp_root_test_file = dirname($group->comp_root) . "/.outside_comp";

#------------------------------------------------------------

    $group->add_support( path => '/support/amper_test',
                         component => <<'EOF',
amper_test.

% if (%ARGS) {
Arguments:

%   foreach my $key (sort keys %ARGS) {
<% $key %>: <% $ARGS{$key} %>

%   }
% }
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'ampersand',
                      description => 'tests all variations of component call path syntax',
                      component => <<'EOF',
<&support/amper_test&>
<& support/amper_test &>
<&  support/amper_test, &>
<& support/amper_test
&>
<&
support/amper_test &>
<&
support/amper_test
&>
EOF
                      expect => <<'EOF',
amper_test.


amper_test.


amper_test.


amper_test.


amper_test.


amper_test.


EOF
                 );

#------------------------------------------------------------

    $group->add_test( name => 'ampersand_with_args',
                      description => 'tests variations of component calls with arguments',
                      component => <<'EOF',
<& /comp-calls/support/amper_test, message=>'Hello World!'  &>
<& support/amper_test, message=>'Hello World!',
   to=>'Joe' &>
<& "support/amper_test" &>
% my $dir = "support";
% my %args = (a=>17, b=>32);
<& $dir . "/amper_test", %args &>
EOF
                      expect => <<'EOF',
amper_test.

Arguments:

message: Hello World!


amper_test.

Arguments:

message: Hello World!

to: Joe


amper_test.


amper_test.

Arguments:

a: 17

b: 32


EOF
                 );

#------------------------------------------------------------

    $group->add_support( path => '/support/funny_-+=@~~~._name',
                         component => <<'EOF',
foo is <% $ARGS{foo} %>
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'ampersand_with_funny_name',
                      description => 'component with non-alphabetic characters',
                      component => <<'EOF',
<& support/funny_-+=@~~~._name, foo => 5 &>
EOF
                      expect => <<'EOF',
foo is 5
EOF
                 );

#------------------------------------------------------------

    # This only tests for paths passed through Request::fetch_comp,
    # not Interp::load.  Not sure how zealously we want to
    # canonicalize.
    #
    $group->add_test( name => 'canonicalize_paths',
                      description => 'test that various paths are canonicalized to the same component',
                      component => <<'EOF',
<%perl>
my $path1 = '///comp-calls/support//amper_test';
my $comp1 = $m->fetch_comp($path1)
  or die "could not fetch comp1";
my $path2 = './support/./././amper_test';
my $comp2 = $m->fetch_comp($path2)
  or die "could not fetch comp2";
my $path3 = './support/../support/../support/././amper_test';
my $comp3 = $m->fetch_comp($path3)
  or die "could not fetch comp3";
unless ($comp1 == $comp2 && $comp2 == $comp3) {
    die sprintf
        (
         "different component objects for same canonical path:\n  %s (%s -> %s)\n  %s (%s -> %s)\n  %s (%s -> %s)",
         $comp1, $path1, $comp1->path,
         $comp2, $path2, $comp2->path,
         $comp3, $path3, $comp3->path,
         );
}
$m->comp($comp1);
$m->comp($comp2);
$m->comp($comp3);

EOF
                      expect => <<'EOF',
amper_test.

amper_test.

amper_test.

EOF
                 );

#------------------------------------------------------------

    $group->add_test( name => 'fetch_comp_no_arg',
                      description => 'fetch_comp with blank or undefined argument returns undef',
                      component => <<'EOF',
fetch_comp(undef) = <% defined($m->fetch_comp(undef)) ? 'defined' : 'undefined' %>
fetch_comp("") = <% defined($m->fetch_comp("")) ? 'defined' : 'undefined' %>
EOF
                      expect => <<'EOF',
fetch_comp(undef) = undefined
fetch_comp("") = undefined
EOF
                 );

#------------------------------------------------------------

    $group->add_test( name => 'outside_comp_root_prepare',
                      description => 'test that file exists in dist/t for next two tests',
                      pre_code => sub { local *F; open(F, ">$outside_comp_root_test_file"); print F "hi"; },
                      component => "test file '$outside_comp_root_test_file' <% -e '$outside_comp_root_test_file' ? 'exists' : 'does not exist' %>",
                      expect => "test file '$outside_comp_root_test_file' exists",
                 );

#------------------------------------------------------------

    $group->add_test( name => 'outside_comp_root_absolute',
                      description => 'cannot call components outside comp root with absolute path',
                      component => <<'EOF',
<& /../.outside_comp &>
EOF
                      expect_error => qr{could not find component for path '/../.outside_comp'},
                 );

#------------------------------------------------------------

    $group->add_test( name => 'outside_comp_root_relative',
                      description => 'cannot call components outside comp root with relative path',
                      component => <<'EOF',
<& ../../.outside_comp &>
EOF
                      expect_error => qr{could not find component for path '../../.outside_comp'},
                 );

#------------------------------------------------------------

    # put /../ in add_support path to put component right under comp root
    $group->add_support( path => '/../outside_comp_root_from_top',
                         component => <<'EOF',
<& ../.outside_comp &>
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'outside_comp_root_relative_from_top',
                      description => 'cannot call components outside comp root with relative path from component at top of root',
                      component => <<'EOF',
<& /outside_comp_root_from_top &>
EOF
                      expect_error => qr{could not find component for path '../.outside_comp'},
                 );

#------------------------------------------------------------

    $group->add_test( name => 'parent_designator_with_no_parent',
                      description => 'using PARENT from component with no parent',
                      component => <<'EOF',
<%flags>
inherit=>undef


<& PARENT:foo &>
EOF
                      expect_error => qr/PARENT designator used from component with no parent/,
                 );

#------------------------------------------------------------

    $group->add_test( name => 'no_such_method',
                      description => 'calling nonexistent method on existing component',
                      component => <<'EOF',
<& support/amper_test:bar &>
EOF
                      expect_error => qr/no such method 'bar' for component/,
                 );

#------------------------------------------------------------

    $group->add_test( name => 'fetch_comp_no_errors',
                      description => 'fetch_comp should not throw any errors',
                      component => <<'EOF',
% foreach my $path (qw(foo support/amper_test:bar PARENT)) {
<% $m->fetch_comp($path) ? 'defined' : 'undefined' %>
% }
EOF
                      expect => <<'EOF',
undefined
undefined
undefined
EOF
                 );

#------------------------------------------------------------

    $group->add_support( path => '/support/methods',
                         component => <<'EOF',
<%method foo>
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'comp_exists',
                      description => 'test comp_exists with various types of paths',
                      component => <<'EOF',
<%perl>
my @paths = qw(
   support/methods
   support/methods:foo
   support/methods:bar
   .foo
   .bar
   SELF
   SELF:foo
   PARENT
   PARENT:foo
   REQUEST
   REQUEST:foo
);


<%def .foo>

% foreach my $path (@paths) {
<% $path %>: <% $m->comp_exists($path) %>
% }
EOF
                      expect => <<'EOF',


support/methods: 1
support/methods:foo: 1
support/methods:bar: 0
.foo: 1
.bar: 0
SELF: 1
SELF:foo: 0
PARENT: 0
PARENT:foo: 0
REQUEST: 1
REQUEST:foo: 0
EOF
                 );

#------------------------------------------------------------

    $group->add_test( name => 'comp_exists_no_arg',
                      description => 'comp_exists with blank or undefined argument returns 0',
                      component => <<'EOF',
comp_exists(undef) = <% $m->comp_exists(undef) %>
comp_exists("") = <% $m->comp_exists("") %>
EOF
                      expect => <<'EOF',
comp_exists(undef) = 0
comp_exists("") = 0
EOF
                 );

    return $group;
}
HTML-Mason-1.59/t/11-inherit.t0000644000175000017500000004047513660015140015446 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'inherit',
                                                      description => 'Test inheritance' );


#------------------------------------------------------------

    $group->add_support( path => 'autohandler',
                         component => <<'EOF',
<%method m1>m1 from level 1
<%method m12>m12 from level 1
<%method m13>m13 from level 1
<%method m123>m123 from level 1

<%attr>
a1=>'a1 from level 1'
a12=>'a12 from level 1'
a13=>'a13 from level 1'
a123=>'a123 from level 1'


<& { base_comp => $m->base_comp }, 'variants' &>

% $m->call_next;

EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => 'report_parent',
                         component => <<'EOF',
% my $comp = $m->callers(1);
My name is <% $comp->path %> and <% $comp->parent ? "my parent is ".$comp->parent->path : "I have no parent" %>.
EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => 'variants',
                         component => <<'EOF',
% my @variants = qw(1 2 3 12 13 23 123);

Methods (called from <% $m->callers(1)->title %>)
% foreach my $v (@variants) {
%   if ($self->method_exists("m$v")) {
m<% $v %>: <& "SELF:m$v" &>
%   } else {
m<% $v %>: does not exist
%   }
% }

Attributes (referenced from <% $m->callers(1)->title %>)
% foreach my $v (@variants) {
%   if ($self->attr_exists("a$v")) {
a<% $v %>: <% $self->attr("a$v") %>
%   } else {
a<% $v %>: does not exist
%   }
% }

<%init>
my $self = $m->base_comp;

EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => 'subdir/call_next_helper',
                         component => <<'EOF',
<%init>
# Making sure we can call_next from a helper component
$m->call_next;

EOF
                       );
#------------------------------------------------------------

    $group->add_support( path => 'subdir/autohandler',
                         component => <<'EOF',
<%method m2>m2 from level 2
<%method m12>m12 from level 2
<%method m23>m23 from level 2
<%method m123>m123 from level 2

<%attr>
a2=>'a2 from level 2'
a12=>'a12 from level 2'
a23=>'a23 from level 2'
a123=>'a123 from level 2'


<& { base_comp => $m->base_comp }, '../variants' &>

<& call_next_helper &>

<%init>
my $self = $m->base_comp;

EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'bypass',
                      description => 'test inheritance that skips one autohandler',
                      path => 'subdir/bypass',
                      call_path => 'subdir/bypass',
                      component => <<'EOF',
<%method m3>m3 from level 3
<%method m13>m13 from level 3
<%method m23>m23 from level 3
<%method m123>m123 from level 3

<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'


<& { base_comp => $m->base_comp }, '../variants' &>
<& ../report_parent &>

<%flags>
inherit=>'../autohandler'

EOF
                      expect => <<'EOF',



Methods (called from /inherit/autohandler)
m1: m1 from level 1
m2: does not exist
m3: m3 from level 3
m12: m12 from level 1
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3

Attributes (referenced from /inherit/autohandler)
a1: a1 from level 1
a2: does not exist
a3: a3 from level 3
a12: a12 from level 1
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3






Methods (called from /inherit/subdir/bypass)
m1: m1 from level 1
m2: does not exist
m3: m3 from level 3
m12: m12 from level 1
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3

Attributes (referenced from /inherit/subdir/bypass)
a1: a1 from level 1
a2: does not exist
a3: a3 from level 3
a12: a12 from level 1
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3


My name is /inherit/subdir/bypass and my parent is /inherit/autohandler.




EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'ignore',
                      description => 'turning off inheritance',
                      path => 'subdir/ignore',
                      call_path => 'subdir/ignore',
                      component => <<'EOF',
<%method m3>m3 from level 3
<%method m13>m13 from level 3
<%method m23>m23 from level 3
<%method m123>m123 from level 3

<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'


%# base_comp currently does not change when a comp ref is used
% my $variants = $m->fetch_comp('../variants'); 
<& $variants &>

<& ../report_parent &>

<%flags>
inherit=>undef

EOF
                      expect => <<'EOF',



Methods (called from /inherit/subdir/ignore)
m1: does not exist
m2: does not exist
m3: m3 from level 3
m12: does not exist
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3

Attributes (referenced from /inherit/subdir/ignore)
a1: does not exist
a2: does not exist
a3: a3 from level 3
a12: does not exist
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3



My name is /inherit/subdir/ignore and I have no parent.


EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'normal',
                      description => 'normal inheritance path',
                      path => 'subdir/normal',
                      call_path => 'subdir/normal',
                      component => <<'EOF',
<%method m3>m3 from level 3
<%method m13>m13 from level 3
<%method m23>m23 from level 3
<%method m123>m123 from level 3

<%attr>
a3=>'a3 from level 3'
a13=>'a13 from level 3'
a23=>'a23 from level 3'
a123=>'a123 from level 3'


<& { base_comp => $m->base_comp }, '../variants' &>
<& ../report_parent &>
EOF
                      expect => <<'EOF',



Methods (called from /inherit/autohandler)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3

Attributes (referenced from /inherit/autohandler)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3






Methods (called from /inherit/subdir/autohandler)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3

Attributes (referenced from /inherit/subdir/autohandler)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3






Methods (called from /inherit/subdir/normal)
m1: m1 from level 1
m2: m2 from level 2
m3: m3 from level 3
m12: m12 from level 2
m13: m13 from level 3
m23: m23 from level 3
m123: m123 from level 3

Attributes (referenced from /inherit/subdir/normal)
a1: a1 from level 1
a2: a2 from level 2
a3: a3 from level 3
a12: a12 from level 2
a13: a13 from level 3
a23: a23 from level 3
a123: a123 from level 3


My name is /inherit/subdir/normal and my parent is /inherit/subdir/autohandler.





EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => '/base/autohandler',
                         component => <<'EOF',
<%flags>
inherit => undef

<%attr>
a => 'base autohandler'

<%method x>
This is X in base autohandler
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& .util &>

<%method y>
This is method Y in base autohandler
base_comp is <% $m->base_comp->name %>

<%def .util>
This is subcomponent .util
base_comp is <% $m->base_comp->name %>
<& SELF:y &>

% $m->call_next;
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/util/autohandler',
                         component => <<'EOF',
<%flags>
inherit => undef

<%attr>
a => 'util autohandler'

<%method x>
This is X in util autohandler
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x , why => 'infinite loop if PARENT does not work ' &>

<%method exec>
This is autohandler:exec
exec was really called for <% $m->base_comp->name %>
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>

% $m->call_next;
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/util/util',
                         component => <<'EOF',
<%method x>
This is method X in UTIL

<%attr>
a => 'util'

This is UTIL
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& PARENT:x &>
EOF
                       );

#------------------------------------------------------------

    $group->add_test(   name => 'base_comp',
                        path => '/base/base',
                        call_path => '/base/base',
                        description => 'base_comp test',
                        component => <<'EOF',
<%method x>
This is method X in BASE

<%attr>
a => 'base'

This is BASE
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& ../util/util &>
<& PARENT:x &>
EOF
                      expect => <<'EOF',
This is BASE
attribute A is base

This is method X in BASE

This is UTIL
attribute A is util

This is method X in UTIL


This is X in util autohandler
attribute A is util

This is method X in UTIL




This is X in base autohandler
attribute A is base

This is method X in BASE


This is subcomponent .util
base_comp is base

This is method Y in base autohandler
base_comp is base
EOF
                       );

#------------------------------------------------------------

    $group->add_test(   name => 'base_comp_method',
                        path => '/base/meth',
                        call_path => '/base/meth',
                        description => 'base_comp method inheritance test',
                        component => <<'EOF',
<%method x>
This is method X in METH

<%attr>
a => 'meth'

This is METH
attribute A is <% $m->base_comp->attr('a') %>
<& SELF:x &>
<& ../util/util:exec &>
EOF
                      expect => <<'EOF',
This is METH
attribute A is meth

This is method X in METH


This is autohandler:exec
exec was really called for util
attribute A is util

This is method X in UTIL
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/base2/autohandler',
                         component => <<'EOF',
<%flags>
inherit => undef

This is autohandler A
<& sub/sibling &>
% $m->call_next;
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/base2/sub/autohandler',
                         component => <<'EOF',
This is autohandler B
<& SELF:m &>
% $m->call_next;
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/base2/sub/sibling',
                         component => <<'EOF',
This is SIBLING
<& PARENT &>
<%method m>
This is method M in SIBLING

EOF
                       );

#------------------------------------------------------------

    $group->add_test(   name => 'double_parent',
                        path => '/base2/sub/child',
                        call_path => '/base2/sub/child',
                        description => 'test that parent does not confuse children',
                        component => <<'EOF',
This is CHILD
<%method m>
This is method M in CHILD

EOF
                      expect => <<'EOF',
This is autohandler A
This is SIBLING
This is autohandler B

This is method M in SIBLING

This is CHILD


This is autohandler B

This is method M in CHILD

This is CHILD



EOF
                       );

#------------------------------------------------------------

    $group->add_test(   name => 'subcomponent',
                        path => '/base2/subcomp',
                        call_path => '/base2/subcomp',
                        description => 'test subcomponents',
                        component => <<'EOF',
<%flags>
inherit => undef

<%def .sub>
This is a subcomponent
<& SELF:x &>

<%method x>
This is method X

This is the component
<& .sub &>
EOF
                      expect => <<'EOF',
This is the component

This is a subcomponent

This is method X

EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/base3/autohandler',
                         component => <<'EOF',
<%flags>
inherit => undef

<%method x>
This is X in base autohandler

<& .foo &>
<%def .foo>
% $m->call_next;

EOF
                       );

#------------------------------------------------------------

    # Remarks: this used to work in older versions of Mason.  It's not
    # *quite* surprising that it fails, because the call to <& .foo &>
    # is a "normal" call and thus changes base_comp.  But since .foo
    # can't actually function usefully as a base_comp (as far as I
    # know), it would be possible to not change base_comp while
    # calling subcomponents.  Currently base_comp changes to the
    # autohandler in this situation, which seems odd.
    #
    # Current workaround is <& {base_comp => $m->request_comp}, $m->fetch_next, $m->caller_args(1) &>
    #
    #   -Ken

    $group->add_test(   name => 'call_next_in_def',
                        path => '/base3/call_next_in_def',
                        call_path => '/base3/call_next_in_def',
                        description => 'Test call_next() inside a subcomponent',
                        component => <<'EOF',
<%method x>
This is method X in BASE

This is BASE
base_comp is <% $m->base_comp->name %>
<& SELF:x &>
EOF
                      expect => <<'EOF',

This is BASE
base_comp is call_next_in_def

This is method X in BASE
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/subcompbase/parent',
                         component => <<'EOF',
<& _foo &>

<%def _foo>
<& SELF:bar &>


<%method bar>
This is parent's bar.


<%flags>
inherit => undef

EOF
                       );

#------------------------------------------------------------

    $group->add_test(   name => 'subcomponent_inheritance',
                        path => '/subcompbase/child',
                        call_path => '/subcompbase/child',
                        description => 'test base_comp with subcomponents',
                        component => <<'EOF',
<%flags>
inherit => 'parent'


<%method bar>
This is child's bar.

EOF
                      expect => <<'EOF',


This is child's bar.
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/request_test/autohandler',
                         component => <<'EOF',
<& SELF:x &>\
<& REQUEST:x &>\
next\
% $m->call_next;
<%method x>
x in autohandler

<%flags>
inherit => undef

EOF
                       );

    $group->add_support( path => '/request_test/other_comp',
                         component => <<'EOF',
<& REQUEST:x &>\
<& SELF:x &>\
<%method x>x in other comp

<%flags>
inherit => undef

EOF
                       );

    $group->add_test( name => 'request_tests',
                      path => '/request_test/request_test',
                      call_path => '/request_test/request_test',
                      description => 'Test that REQUEST: works',
                      component => <<'EOF',
<& PARENT:x &>\
<& other_comp &>\
<%method x>x in requested comp

EOF
                      expect => <<'EOF',
x in requested comp
x in requested comp
next
x in autohandler
x in requested comp
x in other comp
EOF
                    );

#------------------------------------------------------------

    return $group;
}

HTML-Mason-1.59/t/24-tools.t0000644000175000017500000000033513660015140015137 0ustar  autarchautarchuse strict;
use warnings;

use lib 't/lib';

use Test::More tests => 1;


use HTML::Mason::Tools ();

eval { HTML::Mason::Tools::load_pkg( 'LoadTest', 'Required package.' ) };
like( $@, qr/Can't locate Does.Not.Exist/ );
HTML-Mason-1.59/t/22-path-security.t0000644000175000017500000000066313660015140016602 0ustar  autarchautarchuse strict;
use warnings;

use Test::More;

BEGIN
{
    unless ( -f '/etc/passwd' )
    {
        plan skip_all => 'This test requires that /etc/passwd exist.';
    }
}

plan tests => 1;

use HTML::Mason::Resolver::File;


my $resolver = HTML::Mason::Resolver::File->new();

my $source = $resolver->get_info( '/../../../../../../etc/passwd', 'MAIN', '/var/cache' );

ok( ! $source, 'Cannot get at /etc/passwd with bogus comp path' );

HTML-Mason-1.59/t/25-flush-in-content.t0000644000175000017500000000216513660015140017200 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests {
    my $group = HTML::Mason::Tests->tests_class->new(
        name        => 'flush-in-content',
        description => 'recursive calls with $m->content'
    );

    #------------------------------------------------------------

    $group->add_support(
        path      => '/widget',
        component => <<'EOF',

\
<% $content |n %>\

\
<%init>
my $content = $m->content;

EOF
    );

    #------------------------------------------------------------

    $group->add_support(
        path      => '/block',
        component => <<'EOF',
\
% $m->flush_buffer;
EOF
    );

    #------------------------------------------------------------

    $group->add_test(
        name => 'flush-in-deep-content',
        description =>
            'make sure flush does not flush when we are in $m->content()',
        component => <<'EOF',
<&| widget &><&| widget &><& block &>
EOF
        expect => <<'EOF',


EOF
    );

    return $group;
}

HTML-Mason-1.59/t/25-log.t0000644000175000017500000000410313660015140014556 0ustar  autarchautarchuse strict;
use warnings;
use Test::More tests => 1;
use Log::Any::Test;
use Log::Any qw($log);
use Test::Deep;
use File::Temp qw(tempdir);
use File::Path;
use HTML::Mason::Interp;

sub write_file {
    my ( $file, $content ) = @_;
    open( my $fh, ">$file" );
    $fh->print($content);
}

my $comp_root = tempdir( 'mason-log-t-XXXX', TMPDIR => 1, CLEANUP => 1 );
mkpath( "$comp_root/bar", 0, 0775 );

my $interp = HTML::Mason::Interp->new( comp_root => $comp_root );
write_file( "$comp_root/foo", "% \$m->log->debug('in foo');\n<& /bar/baz &>" );
write_file( "$comp_root/bar/baz", "% \$m->log->error('in bar/baz')" );
$interp->exec('/foo');

cmp_deeply(
    $log->msgs,
    [
        {
            category => 'HTML::Mason::Request',
            level    => 'debug',
            message  => 'top path is \'/foo\''
        },
        {
            category => 'HTML::Mason::Request',
            level    => 'debug',
            message  => 'starting request for \'/foo\''
        },
        {
            category => 'HTML::Mason::Request',
            level    => 'debug',
            message  => 'entering component \'/foo\' [depth 0]'
        },
        {
            category => 'HTML::Mason::Component::foo',
            level    => 'debug',
            message  => 'in foo'
        },
        {
            category => 'HTML::Mason::Request',
            level    => 'debug',
            message  => 'entering component \'/bar/baz\' [depth 1]'
        },
        {
            category => 'HTML::Mason::Component::bar::baz',
            level    => 'error',
            message  => 'in bar/baz'
        },
        {
            category => 'HTML::Mason::Request',
            level    => 'debug',
            message  => 'exiting component \'/bar/baz\' [depth 1]'
        },
        {
            category => 'HTML::Mason::Request',
            level    => 'debug',
            message  => 'exiting component \'/foo\' [depth 0]'
        },
        {
            category => 'HTML::Mason::Request',
            level    => 'debug',
            message  => 'finishing request for \'/foo\''
        }
    ]
);
HTML-Mason-1.59/t/00-report-prereqs.dd0000644000175000017500000000531013660015140017105 0ustar  autarchautarchdo { my $x = {
       'configure' => {
                        'requires' => {
                                        'ExtUtils::MakeMaker' => '0'
                                      },
                        'suggests' => {
                                        'JSON::PP' => '2.27300'
                                      }
                      },
       'develop' => {
                      'requires' => {
                                      'CHI' => '0.21',
                                      'Code::TidyAll' => '0.56',
                                      'Code::TidyAll::Plugin::SortLines::Naturally' => '0.000003',
                                      'Code::TidyAll::Plugin::Test::Vars' => '0.02',
                                      'Parallel::ForkManager' => '1.19',
                                      'Perl::Critic' => '1.126',
                                      'Perl::Tidy' => '20160302',
                                      'Test::CPAN::Meta::JSON' => '0.16',
                                      'Test::Memory::Cycle' => '0',
                                      'Test::Mojibake' => '0',
                                      'Test::More' => '0.88',
                                      'Test::NoTabs' => '0',
                                      'Test::Pod' => '1.41',
                                      'Test::Spelling' => '0.12',
                                      'Test::Vars' => '0.009',
                                      'Test::Version' => '2.05'
                                    }
                    },
       'runtime' => {
                      'requires' => {
                                      'CGI' => '2.46',
                                      'Cache::Cache' => '1.00',
                                      'Class::Container' => '0.07',
                                      'Exception::Class' => '1.15',
                                      'File::Spec' => '0.8',
                                      'HTML::Entities' => '0',
                                      'Log::Any' => '0.08',
                                      'Params::Validate' => '0.70',
                                      'Scalar::Util' => '1.01'
                                    }
                    },
       'test' => {
                   'recommends' => {
                                     'CPAN::Meta' => '2.120900'
                                   },
                   'requires' => {
                                   'ExtUtils::MakeMaker' => '0',
                                   'File::Spec' => '0.8',
                                   'Test::Deep' => '0',
                                   'Test::More' => '0.96'
                                 }
                 }
     };
  $x;
 }HTML-Mason-1.59/t/09a-comp_content.t0000644000175000017500000003201413660015140016632 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'filters',
                                                      description => 'Filter Component' );


#------------------------------------------------------------

    $group->add_support( path => 'filter_test/filter',
                         component => <<'EOF',
<%once>
my %words = (1,'one',2,'two',3,'three',4,'four',5,'five');

<%perl>
my $c = $m->content;
$c = '' unless defined $c;  # avoid uninitialized value warnings
$c =~ s/^\s+//;
$c =~ s/\s+$//;
if ($words{$c}) {
        $m->print($words{$c});
} else {
        $m->print("content returned '".$c."'");
}

EOF
                       );

#------------------------------------------------------------

$group->add_support( path => 'filter_test/repeat',
                 component => <<'EOF',
<%args>
$var
@list

<%perl>
for (@list) {
        $$var = $_;
        $m->print($m->content);
}

EOF
               );

#------------------------------------------------------------

    $group->add_support( path => 'filter_test/repeat2',
                         component => <<'EOF',
<%args>
@list

% foreach (@list) {
<% $m->content %>
% }
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => 'filter_test/null',
                         component => <<'EOF',
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => 'filter_test/echo',
                         component => <<'EOF',
% $m->print($m->content);
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => 'filter_test/double',
                         component => <<'EOF',
<&| filter &>1
<&| filter &><% $m->content %>
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'repeat',
                      path => 'filter_test/test1',
                      call_path => 'filter_test/test1',
                      description => 'Tests a filter which outputs the content multiple times, with different values',
                      component => <<'EOF',
% my $a;

    
<&| repeat , var => \$a, list => [1,2,3,4,5] &>

  • <% $a %>




EOF
                      expect => <<'EOF',

    


  • 1


  • 2


  • 3


  • 4


  • 5




EOF
                     );

#------------------------------------------------------------

    $group->add_test( name => 'filter',
                      path => 'filter_test/test2',
                      call_path => 'filter_test/test2',
                      description => 'Tests a filter changes the contents',
                      component => <<'EOF',
<&| filter &>1


<&| filter &>2


<&| filter &>hi


end
EOF
                      expect => <<'EOF',
one


two


content returned 'hi'


end
EOF
                     );

#------------------------------------------------------------

    $group->add_test( name => 'nested',
                      path => 'filter_test/test3',
                      call_path => 'filter_test/test3',
                      description => 'Tests nested filters',
                      component => <<'EOF',
% my $i;
<&| repeat , var => \$i , list => [5,4,3,2,1] &>
<&| filter &> <% $i %>  


done!
EOF
                      expect => <<'EOF',

five 


four 


three 


two 


one 


done!
EOF
                     );

#------------------------------------------------------------

    $group->add_test( name => 'contentless',
                      path => 'filter_test/test4',
                      call_path => 'filter_test/test4',
                      description => 'test a filter with no content',
                      component => <<'EOF',
nothing <& filter &> here
EOF
                      expect => <<'EOF',
nothing content returned '' here
EOF
                     );

#------------------------------------------------------------

    $group->add_test( name => 'default_content',
                      path => 'filter_test/test5',
                      call_path => 'filter_test/test5',
                      description => 'test a filter which does not access content',
                      component => <<'EOF',
outside <&| null &> inside  outside
EOF
                      expect => <<'EOF',
outside  outside
EOF
                     );

#------------------------------------------------------------

    $group->add_test(   name => 'current_component',
                        path => 'filter_test/test6',
                        call_path => 'filter_test/test6',
                        call_args => {arg=>1},
                        description => 'test $m->current_comp inside filter content',
                        component => <<'EOF',
<% $m->current_comp->name %>
<&| echo &>
<% $m->current_comp->name %>
<&| echo &>
<% $m->current_comp->name %>
<% join(", ", $m->caller_args(0)) %>


EOF
                        expect => <<'EOF',
test6

test6

test6
arg, 1
EOF
                );

#------------------------------------------------------------

    $group->add_test(   name => 'various_tags',
                        path => 'filter_test/test7',
                        call_path => 'filter_test/test7',
                        description => 'test various tags in content',
                        component => <<'EOF',
<%method lala>
component call

<&| filter &>
% $m->print("this is a perl line ");
<% "substitution tag" %>
<& SELF:lala &>
<%perl>
$m->print("perl tag");


EOF
                        expect => <<'EOF',
content returned 'this is a perl line substitution tag

component call

perl tag'
EOF
                );

#------------------------------------------------------------

    $group->add_test(   name => 'filter_with_filter',
                        path => 'filter_test/test8',
                        call_path => 'filter_test/test8',
                        description => 'test interaction with filter section',
                        component => <<'EOF',
<&| filter &>hi ho
<%filter>
s/content returned/simon says/

EOF
                        expect => <<'EOF',
simon says 'hi ho'
EOF
                );

#------------------------------------------------------------

    $group->add_test(   name => 'top_level_content',
                        description => 'test $m->content at top level is empty',
                        component => <<'EOF',
top level content is '<% $m->content %>'
EOF
                        expect => <<'EOF',
top level content is ''
EOF
                );

#------------------------------------------------------------

    $group->add_test(   name => 'filter_content',
                        path => 'filter_test/test10',
                        call_path => 'filter_test/test10',
                        description => 'test filtering $m->content',
                        component => <<'EOF',
top
<&| double &>guts
EOF
                        expect => <<'EOF',
top
one
content returned 'guts'
EOF
                );

#------------------------------------------------------------

    $group->add_test(   name => 'subcomponent_filter',
                        description => 'test method as filter',
                        component => <<'EOF',
<%def sad>
<% $m->content %>? I can't help it!

<%method happy>
<% $m->content %>, be happy!

<&| SELF:happy &>don't worry
<&| sad &>why worry
EOF
                        expect => <<'EOF',

don't worry, be happy!


why worry? I can't help it!
EOF
                );

#------------------------------------------------------------

    $group->add_test( name => 'dollar_underscore',
                      description => 'Test using $_ in a filter',
                      component => <<'EOF',
<&| filter_test/repeat2, list => [1,2,3] &>$_ is <% $_ %>
EOF
                      expect => <<'EOF',
$_ is 1
$_ is 2
$_ is 3
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'multi_filter',
                      description => 'Test order of multiple filters',
                      component => <<'EOF',
<&| .lc &>\
<&| .uc &>\
MixeD CAse\
\
\
<%def .uc>\
<% uc $m->content %>\

<%def .lc>\
<% lc $m->content %>\

EOF
                      expect => <<'EOF',
mixed case
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'clear_in_filter',
                      description => 'Test clear_buffer in a filtered call',
                      component => <<'EOF',
clear me
<&| .lc &>\
MIXED case
% $m->clear_buffer;
mixed CASE

<%def .lc>\
in .lc
<% lc $m->content %>\

EOF
                      expect => <<'EOF',
mixed case
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'clear_in_filter2',
                      description => 'More clear_buffer in a filtered call',
                      component => <<'EOF',
clear me
<&| .lc &>\
MIXED case
<& .clear &>\
mixed CASE

<%def .lc>\
in .lc
<% lc $m->content %>\
\
<%def .clear>\
% $m->clear_buffer;

EOF
                      expect => <<'EOF',
mixed case
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_in_filter',
                      description => 'Test flush_buffer in a filtered call',
                      component => <<'EOF',
<&| .lc &>\
Should do nothing
% $m->flush_buffer;
so both should appear

<%def .lc>\
<% lc $m->content %>\

EOF
                      expect => <<'EOF',
should do nothing
so both should appear
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'has_content',
                      description => 'Test $m->has_content',
                      component => <<'EOF',
<& .show_content &>\
-----
<&| .show_content &>\
This is the content

<%def .show_content>\
% if ($m->has_content) {
My content is: 
<% $m->content %>
% } else { 
I have no content.
% }

EOF
                      expect => <<'EOF',
I have no content.
-----
My content is: 
This is the content
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'ending_tag_match',
                      description => 'Test ',
                      component => <<'EOF',
<&|.outer &>\
<&| .inner, dummy=>1 &>\
This is the content


<%def .inner>\
% $m->print("inner: ".$m->content);

<%def .outer>\
% $m->print("outer: ".$m->content);

EOF
                      expect => <<'EOF',
outer: inner: This is the content
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'ending_tag_nomatch',
                      description => 'Test bad  match',
                      component => <<'EOF',
<&|.outer &>\
<&| .inner&>\
This is the content


<%def .inner>\
% $m->print("inner: ".$m->content);

<%def .outer>\
% $m->print("outer: ".$m->content);

EOF
                      expect_error => 'Component name in ending tag \(\.outer\) does not match component name in beginning tag \(\.inner\)',
                    );

#------------------------------------------------------------

    $group->add_test( name => 'ending_tag_expr',
                      description => 'Test expr in <& expr> not matched',
                      component => <<'EOF',
<&| ".outer" &>\
<&| ".inner" &>\
This is the content


<%def .inner>\
% $m->print("inner: ".$m->content);

<%def .outer>\
% $m->print("outer: ".$m->content);

EOF
                      expect_error => 'Cannot match an expression as a component name',
                    );

#------------------------------------------------------------

    $group->add_test( name => 'ending_tag_expr2',
                      description => 'Test expr in  not allowed',
                      component => <<'EOF',
<&| ".outer" &>\
<&| ".inner" &>\
This is the content


<%def .inner>\
% $m->print("inner: ".$m->content);

<%def .outer>\
% $m->print("outer: ".$m->content);

EOF
                      expect_error => 'Cannot use an expression inside component with content ending tag',
                    );

#------------------------------------------------------------

    $group->add_test( name => 'multiline_open_close',
                      description => 'Tests multiline opening and closing blocks for component with content call tags',
                      component => <<'EOF',
<&|
Wrap
&>\
Hello\
\
<%def Wrap>\
[Wrap start]
<% $m->content %>
[Wrap end]\

EOF
                      expect => <<'EOF',
[Wrap start]
Hello
[Wrap end]
EOF
                    );

#------------------------------------------------------------

    return $group;
}


HTML-Mason-1.59/t/05a-stack-corruption.t0000644000175000017500000000271513660015140017452 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'stack_corruption',
                                                      description => 'tests for stack corruption',
                                                    );


    # The key to this test is that it first calls a component that in
    # turn has a comp-with-content call. That comp-with-content call
    # then calls $m->content (this is important).
    #
    # After that, _further_ component calls reveal stack corruption.
    $group->add_support( path => '/support/comp',
                         component => <<'EOF',
<&| .subcomp1 &>
<& .subcomp2 &>


<%def .subcomp1>
% $m->content;


<%def .subcomp2>
content

EOF
                       );

    $group->add_support( path => '/support/comp2',
                         component => <<'EOF',

EOF
                       );

    $group->add_test( name => 'stack_corruption',
                      description => 'test for stack corruption with comp-with-content call',
                      component => <<'EOF',
<& support/comp &>

<& support/comp2 &>

<& .callers &>

<%def .callers>
Stack at this point:
% for my $f ( $m->callers ) {
<% defined $f ? $f->path : 'undef' %>
% }

EOF
                      expect => qr{/stack_corruption/stack_corruption:.callers\n(?!undef)},
                    );

    return $group;
}
HTML-Mason-1.59/t/taint.comp0000644000175000017500000000032013660015140015360 0ustar  autarchautarch<%perl>
$m->print('part2');

<%args>
$foo => 1
$bar

hey there
% my $x = 1;
<%perl>
$m->print($x++) while $x < 100;


<%def .foo>
lalalalalala


<%method foo>
foobar

HTML-Mason-1.59/t/run_one_test0000755000175000017500000000004713660015140016021 0ustar  autarchautarch#!/bin/bash
/usr/bin/perl -I../lib $*

HTML-Mason-1.59/t/02a-filter.t0000644000175000017500000002012713660015140015422 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group =
         HTML::Mason::Tests->tests_class->new( name => 'filter',
                                               description => 'Tests <%filter> specific problems' );

#------------------------------------------------------------

    $group->add_test( name => 'filter_and_shared',
                      description =>
                      'make sure <%filter> can see variables from <%shared>',
                      component => <<'EOF',
I am X
<%shared>
my $change_to = 'Y';

<%filter>
s/X/$change_to/;

EOF
                      expect => <<'EOF',
I am Y
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'filter_and_ARGS',
                      description =>
                      'make sure <%filter> can see variables %ARGS',
                      call_args => { change_to => 'Y' },
                      component => <<'EOF',
I am X
<%filter>
s/X/$ARGS{change_to}/;

EOF
                      expect => <<'EOF',
I am Y
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'filter_and_ARGS_assign',
                      description =>
                      'make sure <%filter> can see changes to %ARGS',
                      component => <<'EOF',
I am X
<%init>
$ARGS{change_to} = 'Y';

<%filter>
s/X/$ARGS{change_to}/;

EOF
                      expect => <<'EOF',
I am Y
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'filter_and_args_section',
                      description =>
                      'make sure <%filter> can see variables from <%args> section',
                      component => <<'EOF',
I am X
<%args>
$change_to => 'Y'

<%filter>
s/X/$change_to/;

EOF
                      expect => <<'EOF',
I am Y
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'filter_and_args_error',
                      description =>
                      'args error should not present a problem for <%filter>',
                      component => <<'EOF',
<%args>
$required


foo

<%filter>
s/foo/bar/g;

EOF
                      expect_error => qr/no value sent for required parameter/,
                    );

#------------------------------------------------------------

    $group->add_support( path => '/support/has_filter',
                         component => <<'EOF',
lower case
<%filter>
$_ = uc $_;

EOF
                       );

    $group->add_test( name => 'filter_and_clear',
                      description => 'make sure <%filter> does not break $m->clear_buffer',
                      component => <<'EOF',
I should not show up.
<& support/has_filter &>
% $m->clear_buffer;
I should show up.
EOF
                      expect => <<'EOF',
I should show up.
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'filters_in_subcomps',
                      description => 'test <%filter> sections in subcomps only',
                      component => <<'EOF',
Main Component
<& .sub1 &>
<& .sub2 &>

<%def .sub1>
Sub 1
<%filter>
s/Sub/Subcomponent/;



<%def .sub2>
Subcomp 2
<%filter>
s/Subcomp/Subcomponent/;



EOF
                      expect => <<'EOF',
Main Component

Subcomponent 1


Subcomponent 2
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'filters_in_comp_and_subcomps',
                      description => 'test <%filter> sections in both main comp and subcomps',
                      component => <<'EOF',
Main Component (lowercase)
<& .sub1 &>
<& .sub2 &>

<%def .sub1>
Sub 1
<%filter>
s/Sub/Subcomponent/;



<%def .sub2>
Subcomp 2
<%filter>
s/Subcomp/Subcomponent/;



<%filter>
$_ = lc($_);


EOF
                      expect => <<'EOF',
main component (lowercase)

subcomponent 1


subcomponent 2
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'filter_and_flush',
                      description => 'test that filter still occurs in presence of flush',
                      component => <<'EOF',
hello
% $m->flush_buffer;
goodbye
<%filter>
tr/a-z/A-Z/

EOF
                      expect => <<'EOF',
HELLO
GOODBYE
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'clear_filter_comp',
                         component => <<'EOF',
Bar
% $m->clear_buffer;
Baz
EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'clear_in_comp_called_with_filter',
                      description => 'Test that clear_buffer clears _all_ buffers, even inside a filter',
                      component => <<'EOF',
Foo
<& clear_filter_comp &>\
<%filter>
s/^/-/gm;

EOF
                      expect => <<'EOF',
-Baz
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'some_comp',
                         component => <<'EOF',
Some stuff
EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'comp_call_in_filter',
                      description => 'Test that calling another component from a filter section works',
                      component => <<'EOF',
Stuff
<%filter>
$_ .= $m->scomp( 'some_comp' );
$_ = lc $_;

EOF
                      expect => <<'EOF',
stuff
some stuff
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => '/auto_filter_die/dies',
                         component => <<'EOF',
% die "foo death";
EOF
                       );


    $group->add_support( path => '/auto_filter_die/autohandler',
                         component => <<'EOF',
autohandler
% $m->call_next;
EOF
                       );


    $group->add_test( name => 'auto_filter_die/abort_comp_call_in_filter_with_autohandler',
                      description => 'Test that calling another component that dies from a filter section in a component wrapped by an autohandler produces a proper error',
                      component => <<'EOF',
Stuff
<%filter>
$m->comp( 'dies' );

EOF
                      expect_error => qr/foo death/,
                    );

#------------------------------------------------------------

    $group->add_support( path => '/support/abort_in_filter',
                         component => <<'EOF',
Will not be seen
<%filter>
$m->abort;
$_ = lc $_;

EOF
                       );

    $group->add_test( name => 'abort_in_filter',
                      description => 'Test that abort in a filter causes no output',
                      component => <<'EOF',
Before the abort
<& support/abort_in_filter &>
After the abort - not seen
EOF
                      expect => <<'EOF',
Before the abort
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => '/support/abort_in_shared_with_filter',
                         component => <<'EOF',
<%shared>
$m->abort('dead');


<%filter>
$_ = lc $_;

EOF
                       );

    $group->add_test( name => 'abort_in_shared_with_filter',
                      description => 'Test that abort in a shared block works when component has a filter block',
                      component => <<'EOF',
<% $out %>
<%init>
eval { $m->comp( 'support/abort_in_shared_with_filter' ) };
my $e = $@;

my $out = 'no error';
if ($e)
{
    $out = $m->aborted($e) ? $e->aborted_value : "error: $e";
}

EOF
                      expect => <<'EOF',
dead
EOF
                    );

#------------------------------------------------------------

        return $group;
}

HTML-Mason-1.59/t/12-taint.t0000644000175000017500000000671313660015140015121 0ustar  autarchautarch#!/usr/bin/perl -T
use strict;
use warnings;

BEGIN {
  # See 'perlrun' and 'perlsec' man pages
  # and http://marc.theaimsgroup.com/?l=mason-devel&m=105469927404246&w=2
  $ENV{PATH} = '/bin:/usr/bin';
  delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
}

# Cwd has to be loaded after sanitizing %ENV
use Cwd;
use File::Spec;
use Test;

BEGIN
{
    my $curdir = File::Spec->curdir;

    my $libs = 'use lib qw( ';
    $libs .=
        ( join ' ',
          File::Spec->catdir( $curdir, 'blib', 'lib' ),
          File::Spec->catdir( $curdir, 't', 'lib' )
        );

    if ($ENV{PERL5LIB})
    {
        $libs .= ' ';
        $libs .= join ' ', (split /:|;/, $ENV{PERL5LIB});
    }
    $libs .= ' );';

    ($libs) = $libs =~ /(.*)/;

    # explicitly use these because otherwise taint mode causes them to
    # be ignored
    eval $libs;
}

use HTML::Mason::Interp;
use HTML::Mason::Compiler::ToObject;
use HTML::Mason::Tools qw(read_file taint_is_on);

# Clear alarms, and skip test if alarm not implemented
my $alarm_works = eval {alarm 0; 1} || 0;
plan tests => 8 + $alarm_works;

# These tests depend on taint mode being on
ok taint_is_on();

if ($alarm_works)
{
    my $compiler = HTML::Mason::Compiler::ToObject->new;

    my $alarm;
    $SIG{ALRM} = sub { $alarm = 1; die "alarm"; };

    my $source = read_file( File::Spec->catfile( File::Spec->curdir, 't', 'taint.comp' ) );
    my $comp;
    eval { alarm 5;
           local $^W;
           $comp =
               $compiler->compile
                   ( comp_source => $source,
                     name => 't/taint.comp',
                     comp_path => '/taint.comp',
                   );
       };

    my $error = ( $alarm ? "entered endless while loop" :
                  $@ ? "gave error during test: $@" :
                  !defined($comp) ? "returned an undefined value from compiling" :
                  '' );
    ok $error, '';
}

# Make these values untainted
my ($comp_root) = File::Spec->catdir( getcwd(), 'mason_tests', 'comps' ) =~ /(.*)/;
my ($data_dir)  = File::Spec->catdir( getcwd(), 'mason_tests', 'data'  ) =~ /(.*)/;
ok !is_tainted($comp_root);
ok !is_tainted($data_dir);

my $interp = HTML::Mason::Interp->new( comp_root => $comp_root,
                                       data_dir => $data_dir,
                                     );

$data_dir = File::Spec->catdir( getcwd(), 'mason_tests', 'data' );

# This source is tainted, as is anything with return val from getcwd()
my $comp2 = HTML::Mason::ComponentSource->new
    ( friendly_name => 't/taint.comp',
      comp_path => '/t/taint.comp',
      source_callback => sub {
          read_file( File::Spec->catfile( File::Spec->curdir, 't', 'taint.comp' ) );
      },
    );
ok $comp2;
ok is_tainted($comp2->comp_source);

# Make sure we can write tainted data to disk
eval { $interp->compiler->compile_to_file
           ( file => File::Spec->catfile( $data_dir, 'taint_write_test' ),
             source => $comp2,
           ); };
ok $@, '', "Can write a tainted object to disk";


my $cwd = getcwd(); # tainted
$cwd = "$0$^X" unless is_tainted($cwd);

# This isn't a part of the documented interface, but we test it here anyway.
my $code = "# MASON COMPILER ID: ". $interp->compiler->object_id ."\nmy \$x = '$cwd';"; # also tainted
ok is_tainted($code);

eval { $interp->eval_object_code( object_code => \$code ) };
ok $@, '', "Unable to eval a tainted object file";

###########################################################
sub is_tainted {
    return not eval { "+@_" && eval 1 };
}
HTML-Mason-1.59/t/09-component.t0000644000175000017500000002420113660015140016002 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'component',
                                                      description => 'Component object functionality' );


#------------------------------------------------------------

    $group->add_test( name => 'comp_obj',
                      path => 'comp_obj_test/comp_obj',
                      call_path => 'comp_obj_test/comp_obj',
                      description => 'Tests several component object methods',
                      component => <<'EOF',
<%def .subcomp>
% my $adj = 'happy';
I am a <% $adj %> subcomp.
<%args>
$crucial
$useless=>17



<%method meth>
% my $adj = 'sad';
I am a <% $adj %> method.
<%args>
$crucial
$useless=>17



% my $anon = $m->interp->make_component(comp_source=>join("\n",'% my $adj = "flummoxed";','I am a <% $adj %> anonymous component.'),name=>'anonymous');

<% '-' x 60 %>

File-based:
<& /shared/display_comp_obj, comp=>$m->current_comp &>

<% '-' x 60 %>

Subcomponent:
<& /shared/display_comp_obj, comp=>$m->fetch_comp('.subcomp')  &>

<% '-' x 60 %>

Method:
<& /shared/display_comp_obj, comp=>$m->fetch_comp('SELF:meth')  &>

<% '-' x 60 %>

Anonymous component:
<& $anon &>
<& $anon &>
<& /shared/display_comp_obj, comp=>$anon &>

<%args>
@animals=>('lions','tigers')

EOF
                      expect => <<'EOF',



------------------------------------------------------------

File-based:
Declared args:
@animals=>('lions','tigers')

I am not a subcomponent.
I am not a method.
I am file-based.
My short name is comp_obj.
My directory is /component/comp_obj_test.
I have 1 subcomponent(s).
Including one called .subcomp.
My title is /component/comp_obj_test/comp_obj.

My path is /component/comp_obj_test/comp_obj.
My comp_id is /component/comp_obj_test/comp_obj.


------------------------------------------------------------

Subcomponent:
Declared args:
$crucial
$useless=>17

I am a subcomponent.
I am not a method.
I am not file-based.
My short name is .subcomp.
My parent component is /component/comp_obj_test/comp_obj.
My directory is /component/comp_obj_test.
I have 0 subcomponent(s).
My title is /component/comp_obj_test/comp_obj:.subcomp.

My path is /component/comp_obj_test/comp_obj:.subcomp.
My comp_id is [subcomponent '.subcomp' of /component/comp_obj_test/comp_obj].


------------------------------------------------------------

Method:
Declared args:
$crucial
$useless=>17

I am a subcomponent.
I am a method.
I am not file-based.
My short name is meth.
My parent component is /component/comp_obj_test/comp_obj.
My directory is /component/comp_obj_test.
I have 0 subcomponent(s).
My title is /component/comp_obj_test/comp_obj:meth.

My path is /component/comp_obj_test/comp_obj:meth.
My comp_id is [method 'meth' of /component/comp_obj_test/comp_obj].


------------------------------------------------------------

Anonymous component:
I am a flummoxed anonymous component.
I am a flummoxed anonymous component.
Declared args:

I am not a subcomponent.
I am not a method.
I am not file-based.
My short name is [anon something].
I have 0 subcomponent(s).
My title is [anon something].

My comp_id is [anon something].
EOF
                     );


#------------------------------------------------------------

    $group->add_test( name => 'context',
                      description => 'Tests list/scalar context propogation in comp calls',
                      component => <<'EOF',
Context checking:

List:\
% my $discard = [$m->comp('.subcomp')];


Scalar:\
% scalar $m->comp('.subcomp');


Scalar:\
<& .subcomp &>

<%def .subcomp>
% $m->print( wantarray ? 'array' : 'scalar' );

EOF
                      expect => <<'EOF',
Context checking:

List:
array

Scalar:
scalar

Scalar:
scalar

EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'scomp',
                      description => 'Test scomp Request method',
                      component => <<'EOF',

% my $text = $m->scomp('.subcomp', 1,2,3);
-----
<% $text %>

<%def .subcomp>
 Hello, you say <% join '', @_ %>.

EOF
                      expect => <<'EOF',

-----

 Hello, you say 123.


EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'mfu_count',
                      description => 'Test mfu_count component method',
                      component => <<'EOF',
<% $m->current_comp->mfu_count %>
% $m->current_comp->mfu_count(75);
<% $m->current_comp->mfu_count %>
EOF
                      expect => <<'EOF',
1
75
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'store',
                      description => 'Test store parameter to component call',
                      component => <<'EOF',

% my $buffy;
% my $rtn;
% $rtn = $m->comp({store => \$buffy}, '.subcomp', 1,2,3,4);
-----
<% $buffy %>
returned <% $rtn %>

<%def .subcomp>
 Hello, you say <% join '', @_ %>.
% return 'foo';

EOF
                      expect => <<'EOF',

-----

 Hello, you say 1234.

returned foo

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_clear',
                      description => 'Flush then clear',
                      component => <<'EOF',
Foo
% $m->flush_buffer;
Bar
% $m->clear_buffer;
Baz
EOF
                      expect => <<'EOF',
Foo
Baz
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_clear_scomp',
                      description => 'Flush then clear inside scomp - flush only affects top buffer',
                      component => <<'EOF',
<%method s>
Foo
% $m->flush_buffer;
Bar
% $m->clear_buffer;
Baz

This is me
----------
This is scomp-ed output:
<% $m->scomp('SELF:s') %>
----------
This is me again
EOF
                      expect => <<'EOF',
This is me
----------
This is scomp-ed output:
Baz

----------
This is me again
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'attr_if_exists',
                      description => 'Test attr_if_exists method',
                      component => <<'EOF',
have it: <% $m->base_comp->attr_if_exists('have_it') %>
don't have it: <% defined($m->base_comp->attr_if_exists('don\'t have_it')) ? 'defined' : 'undefined' %>
<%attr>
have_it => 1

EOF
                      expect => <<'EOF',
have it: 1
don't have it: undefined
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'methods',
                      description => 'Test methods method',
                      component => <<'EOF',
% my $comp = $m->request_comp;
% my $methods = $comp->methods;
% foreach my $name ( sort keys %$methods ) {
<% $name %>
% }
<% $comp->methods('x') ? 'has' : 'does not have' %> x
<% $comp->methods('y') ? 'has' : 'does not have' %> y
<% $comp->methods('z') ? 'has' : 'does not have' %> z
<%method x>
x

<%method y>
y

EOF
                      expect => <<'EOF',
x
y
has x
has y
does not have z
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'subcomps',
                      description => 'Test subcomps method',
                      component => <<'EOF',
% my $comp = $m->request_comp;
% my $subcomps = $comp->subcomps;
% foreach my $name ( sort keys %$subcomps ) {
<% $name %>
% }
<% $comp->subcomps('x') ? 'has' : 'does not have' %> x
<% $comp->subcomps('y') ? 'has' : 'does not have' %> y
<% $comp->subcomps('z') ? 'has' : 'does not have' %> z
<%def x>
x

<%def y>
y

EOF
                      expect => <<'EOF',
x
y
has x
has y
does not have z
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'attributes',
                      description => 'Test attributes method',
                      component => <<'EOF',
% my $comp = $m->request_comp;
% my $attrs = $comp->attributes;
% foreach my $name ( sort keys %$attrs ) {
<% $name %>
% }
<%attr>
x => 1
y => 2

EOF
                      expect => <<'EOF',
x
y
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'args_copying_helper',
                         component => <<'EOF',
<%init>
$_[1] = 4;
$b = 5;
$ARGS{'c'} = 6;


<%args>
$a
$b

EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'component_args_copying',
                      description => 'Test that @_ contains aliases, <%args> and %ARGS contain copies after comp',
                      component => <<'EOF',
$a is <% $a %>
$b is <% $b %>
$c is <% $c %>

<%init>;
my $a = 1;
my $b = 2;
my $c = 3;
$m->comp('args_copying_helper', a=>$a, b=>$b, c=>$c);

EOF
                      expect => <<'EOF',

$a is 4
$b is 2
$c is 3
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'subrequest_args_copying',
                      description => 'Test that @_ contains aliases, <%args> and %ARGS contain copies after subrequest',
                      component => <<'EOF',
$a is <% $a %>
$b is <% $b %>
$c is <% $c %>

<%init>;
my $a = 1;
my $b = 2;
my $c = 3;
$m->subexec('/component/args_copying_helper', a=>$a, b=>$b, c=>$c);

EOF
                      expect => <<'EOF',

$a is 4
$b is 2
$c is 3
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'modification_read_only_arg',
                      description => 'Test that read-only argument cannot be modified through @_',
                      component => <<'EOF',
<%init>;
$m->comp('args_copying_helper', a=>1, b=>2, c=>3);

EOF
                      expect_error => 'Modification of a read-only value',
                    );

#------------------------------------------------------------

    return $group;
}

HTML-Mason-1.59/t/14-cgi.t0000644000175000017500000001050213660015140014535 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::CGIHandler;
use CGI qw(-no_debug);  # Prevent "(offline mode: enter name=value pairs on standard input)"

{
    # This class simulates CGI requests.  It's rather ugly, it tries
    # to fool HTML::Mason::Tests into thinking that CGIHandler is a subclass of Interp.

    package CGITest;
    use HTML::Mason::Tests;
    use base 'HTML::Mason::Tests';

    sub _run_test
    {
        my $self = shift;
        my $test = $self->{current_test};

        $self->{buffer} = '';

        my %interp_params = ( exists $test->{interp_params} ?
                              %{ $test->{interp_params} } :
                              () );

        my $interp = HTML::Mason::CGIHandler->new
            (comp_root => $self->comp_root,
             data_dir  => $self->data_dir,
             %interp_params,
            );
        
        eval { local $CGI::LIST_CONTEXT_WARN = 0; $self->_execute($interp) };
        
        return $self->check_result($@);
    }

    sub _execute
    {
        my ($self, $interp) = @_;  # $interp is a CGIHandler object
        my $test = $self->{current_test};
        
        #print "Calling $test->{name} test with path: $test->{call_path}\n" if $DEBUG;
        $test->{pretest_code}->() if $test->{pretest_code};
        CGI::initialize_globals();     # make sure CGI doesn't cache previous query
        $ENV{REQUEST_METHOD} = 'GET';  # CGI.pm needs this, or it won't process args
        $ENV{PATH_INFO} = $test->{call_path};
        $ENV{QUERY_STRING} = join '=', @{$test->{call_args}};
        
        $interp->handle_request($self->{buffer});
    }
}

$ENV{DOCUMENT_ROOT} = CGITest->comp_root;

my $group = CGITest->new( name => 'cgi',
                          description => 'HTML::Mason::CGIHandler class',
                          interp_class => 'HTML::Mason::CGIHandler',
                        );

#------------------------------------------------------------

my $basic_header = "Content-Type: text/html";
$basic_header .= '; charset=ISO-8859-1' if CGI->can('charset');
$basic_header .= "${CGI::CRLF}${CGI::CRLF}";

$group->add_test( name => 'basic',
                  description => 'Test basic CGIHandler operation',
                  component => 'some text',
                  expect    => "${basic_header}some text",
                );

#------------------------------------------------------------

$group->add_test( name => 'dynamic',
                  description => 'Test CGIHandler operation with dynamic components',
                  component => 'some <% "dynamic" %> text',
                  expect    => "${basic_header}some dynamic text",
                );

#------------------------------------------------------------

$group->add_test( name => 'args',
                  description => 'Test CGIHandler operation with arguments',
                  call_args => [arg => 'dynamic'],
                  component => 'some <% $ARGS{arg} %> text',
                  expect    => "${basic_header}some dynamic text",
                );

#------------------------------------------------------------

$group->add_test( name => 'cgi_object',
                  description => 'Test access to the CGI request object',
                  call_args => [arg => 'boohoo'],
                  component => q{some <% $m->cgi_object->param('arg') %> cryin'},
                  expect    => "${basic_header}some boohoo cryin'",
                );

#------------------------------------------------------------

$group->add_test( name => 'fatal_error',
                  description => 'Test fatal error_mode',
                  interp_params => { error_mode => 'fatal', error_format => 'text' },
                  component => q{% die 'dead';},
                  expect_error => qr/dead at .+/,
                );

$group->add_test( name => 'headers',
                  description => 'Test header generation',
                  component => q{% $r->header_out('foo' => 'bar');},
                  expect    => qr/Foo: bar/i,
                );

$group->add_test( name => 'redirect_headers',
                  description => 'Test header generation',
                  component => q{% $m->redirect('/hello.html');},
                  expect    => qr/Status: 302\s+Location: \/hello\.html|Location: \/hello\.html\s+Status: 302/i,
                );

#------------------------------------------------------------

$group->run;

HTML-Mason-1.59/t/19-subrequest.t0000644000175000017500000002675513660015140016223 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'subrequest',
                                                      description => 'subrequest-related features' );

#------------------------------------------------------------

    $group->add_support( path => '/support/subrequest_error_test',
                         component => <<'EOF',
<& /shared/display_req_obj &>
% die "whoops!";
EOF
                       );

#------------------------------------------------------------


    $group->add_support( path => '/support/dir/autohandler',
                         component => <<'EOF',
I am the autohandler.
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/dir/comp',
                         component => <<'EOF',
I am the called comp (no autohandler).
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'subrequest',
                      description => 'tests the official subrequest mechanism',
                      component => <<'EOF',
<%def .helper>
Executing subrequest
% print "I can print before the subrequest\n";
% my $buf;
% my $req = $m->make_subrequest(comp=>'/shared/display_req_obj', out_method => \$buf);
% $req->exec();
<% $buf %>
% print "I can still print after the subrequest\n";


Calling helper
<& .helper &>
EOF
                      expect => <<'EOF',

Calling helper

Executing subrequest
I can print before the subrequest
My depth is 1.

I am a subrequest.

The top-level component is /shared/display_req_obj.

My stack looks like:
-----
/shared/display_req_obj
-----


I can still print after the subrequest
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'subrequest_with_autohandler',
                      description => 'tests the subrequest mechanism with an autohandler',
                      component => <<'EOF',
Executing subrequest
% my $buf;
% my $req = $m->make_subrequest(comp=>'/subrequest/support/dir/comp', out_method => \$buf);
% $req->exec();
<% $buf %>
EOF
                      expect => <<'EOF',
Executing subrequest
I am the autohandler.
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => '/subrequest2/autohandler',
                         component => <<'EOF',
I am the autohandler for <% $m->base_comp->name %>.
% $m->call_next;
<%flags>
inherit => undef

EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/subrequest2/bar',
                         component => <<'EOF',
I am bar.
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'subreq_exec_order',
                      path => '/subrequest2/subreq_exec_order',
                      call_path => '/subrequest2/subreq_exec_order',
                      description => 'Test that output from a subrequest comes out when we expect it to.',
                      component => <<'EOF',
% $m->subexec('/subrequest/subrequest2/bar');
I am subreq_exec_order.
EOF
                      expect => <<'EOF',
I am the autohandler for subreq_exec_order.
I am the autohandler for bar.
I am bar.
I am subreq_exec_order.
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => '/support/autoflush_subrequest',
                         component => <<'EOF',
% $m->autoflush($autoflush) if $autoflush;
here is the child
% $m->clear_buffer if $clear;
<%args>
$autoflush => 0
$clear => 0

EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'autoflush_subrequest',
                      description => 'make sure that a subrequest respects its parent autoflush setting',
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest');
% $m->clear_buffer;
EOF
                      expect => <<'EOF',
My child says:
here is the child
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'subrequest_inherits_no_autoflush',
                      description => 'make sure that a subrequest inherits its parent autoflush setting (autoflush off)',
                      interp_params => { autoflush => 0 },
                      component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest');
% $m->clear_buffer;
EOF
                      expect => <<'EOF',
My child says:
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'autoflush_in_subrequest',
                      description => 'make sure that a subrequest with autoflush on does not flush parent',
                      component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest', autoflush => 1);
% $m->clear_buffer;
EOF
                      expect => <<'EOF',
My child says:
EOF
                    );

#------------------------------------------------------------

    # SKIPPING THIS TEST FOR NOW - NOT SURE OF DESIRED BEHAVIOR
    if (0) {
        $group->add_test( name => 'autoflush_in_parent_not_subrequest',
                          description => 'make sure that a subrequest with autoflush can clear its own buffers',
                          interp_params => { autoflush => 1 },
                          component => <<'EOF',
My child says:
% $m->flush_buffer;
% $m->subexec('/subrequest/support/autoflush_subrequest', autoflush => 0, clear => 1);
% $m->clear_buffer;
EOF
                          expect => <<'EOF',
My child says:
EOF
                          );
    }

#------------------------------------------------------------

    $group->add_support( path => '/support/return/scalar',
                         component => <<'EOF',
% die "wantarray should be false" unless defined(wantarray) and !wantarray;
% return 'foo';
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'return_scalar',
                      description => 'tests that exec returns scalar return value of top component',
                      component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/scalar');
% my $value = $req->exec();
return value is <% $value %>
EOF
                      expect => <<'EOF',
return value is foo
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => '/support/return/list',
                         component => <<'EOF',
% die "wantarray should be true" unless wantarray;
% return (1, 2, 3);
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'return_list',
                      description => 'tests that exec returns list return value of top component',
                      component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/list');
% my @value = $req->exec();
return value is <% join(",", @value) %>
EOF
                      expect => <<'EOF',
return value is 1,2,3
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => '/support/return/nothing',
                         component => <<'EOF',
wantarray is <% defined(wantarray) ? "defined" : "undefined" %>
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'return_nothing',
                      description => 'tests exec in non-return context',
                      component => <<'EOF',
% my $req = $m->make_subrequest(comp=>'/subrequest/support/return/nothing');
% $req->exec();
EOF
                      expect => <<'EOF',
wantarray is undefined
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => '/support/output',
                         component => <<'EOF',
More output
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'kwindla',
                      description => 'tests bug report from Kwindla Kramer',
                      component => <<'EOF',
Some output
% $m->clear_buffer;
% my $req = $m->make_subrequest( comp => '/subrequest/support/output' );
% $req->exec();
% $m->flush_buffer;
% $m->abort;
EOF
                      expect => <<'EOF',
More output
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'in_package',
                      description => 'use in_package with subrequest',
                      interp_params => { in_package => 'Test::Package' },
                      component => <<'EOF',
Before subreq
% $m->subexec( '/subrequest/support/output' );
After subreq
EOF
                      expect => <<'EOF',
Before subreq
More output
After subreq
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'relative_path_call',
                      description => 'call subrequest with relative path',
                      component => <<'EOF',
% $m->subexec( 'support/output' );
EOF
                      expect => <<'EOF',
More output
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'comp_object_call',
                      description => 'call subrequest with component object',
                      component => <<'EOF',
% $m->subexec( $m->interp->load('/subrequest/support/output') );
EOF
                      expect => <<'EOF',
More output
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => 'support/subexec_recurse_test',
                         component => <<'EOF',
Entering <% $m->request_depth %>

% if ($count < $max) {
%   $m->subexec('subexec_recurse_test', count=>$count+1, max=>$max)
% }
Exiting <% $m->request_depth %>

<%args>
$count=>0
$max

EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'max_recurse_1',
                      description => 'Test that recursion 8 levels deep is allowed',
                      component => '<& support/subexec_recurse_test, max=>8 &>',
                      expect => <<'EOF',
Entering 1

Entering 2

Entering 3

Entering 4

Entering 5

Entering 6

Entering 7

Entering 8

Entering 9

Exiting 9

Exiting 8

Exiting 7

Exiting 6

Exiting 5

Exiting 4

Exiting 3

Exiting 2

Exiting 1

EOF
                      );

#------------------------------------------------------------

    $group->add_test( name => 'max_recurse_2',
                      description => 'Test that recursion is stopped after 32 subexecs',
                      component => '<& support/subexec_recurse_test, max=>48 &>',
                      expect_error => qr{subrequest depth > 32 \(infinite subrequest loop\?\)},
                    );

#------------------------------------------------------------

    return $group;
}
HTML-Mason-1.59/t/single_test.pl0000755000175000017500000000046213660015140016250 0ustar  autarchautarch#!/usr/bin/perl

use strict;

foreach (@ARGV) {
  $ENV{MASON_NO_CLEANUP} = 1;
  my @command = (-e 'Build' ?
                 ('Build', 'test', "test_files=$_", 'verbose=1') :
                 ('make', 'test', "TEST_FILES=$_", 'TEST_VERBOSE=1')
                );
  print "@command\n";
  system @command;
}
HTML-Mason-1.59/t/02-sections.t0000644000175000017500000002712313660015140015626 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'sections',
                                                      description => 'Tests various <%foo> sections' );


#------------------------------------------------------------

    $group->add_support( path => '/support/args_test',
                         component => <<'EOF',
<% $message %>\
<%args>
$message

EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/perl_args_test',
                         component => <<'EOF',
a: <% $a %>
b: <% join(",",@b) %>
c: <% join(",",map("$_=$c{$_}",sort(keys(%c)))) %>
d: <% $d %>
e: <% join(",",@e) %>
f: <% join(",",map("$_=$f{$_}",sort(keys(%f)))) %>

<%args>
$a       
@b       # a comment
%c
$d=>5    # another comment
@e=>('foo','baz')
%f=>(joe=>1,bob=>2)

EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'args',
                      description => 'tests <%args> block',
                      component => <<'EOF',



args Test



<& support/args_test, message => 'Hello World!' &>


EOF
                      expect => <<'EOF',



args Test



Hello World!


EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'attr',
                      description => 'tests <%attr> block',
                      component => <<'EOF',



attr Test



foo
<% $m->current_comp->attr('foo') %>
<% $m->current_comp->attr('bar')->[1] %>
<% $m->current_comp->attr('baz')->{b} %>


<%attr>
foo => 'a'
bar => [1, 3]
baz => { a => 1, b => 2 }

EOF
                      expect => <<'EOF',



attr Test



foo
a
3
2


EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'def',
                      description => 'tests <%def> block',
                      component => <<'EOF',
<%def intro>
% my $comp = $m->current_comp;
Hello!

My name is <% $comp->name %>. Full name <% $comp->title %>.

I was created by <% $comp->owner->path %>.

<& .link, site=>'masonhq', label=>'Mason' &>


<& intro &>

<& .link, site=>'apache', label=>'Apache Foundation' &>

<& .link, site=>'yahoo' &>

<& .link, site=>'excite' &>
<%def .link>
--> <% $label %>
<%args>
$site
$label=>ucfirst($site)


EOF
                      expect => <<'EOF',


Hello!

My name is intro. Full name /sections/def:intro.

I was created by /sections/def.


--> Mason




--> Apache Foundation



--> Yahoo



--> Excite
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'doc',
                      description => 'tests <%doc> section',
                      component => <<'EOF',



doc Test



Hello World!



<%doc>
This is an HTML::Mason documentation section.

Right?

EOF
                      expect => <<'EOF',



doc Test



Hello World!



EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'filter',
                      description => 'tests <%filter> section',
                      component => <<'EOF',



filter Test



!dlorW olleH



<%filter>
s/\!dlorW olleH/Hello World!/;

EOF
                      expect => <<'EOF',



filter Test



Hello World!



EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flags',
                      description => 'tests <%flags> section',
                      component => <<'EOF',



flags Test



foo


<%flags>
inherit=>undef   # an inherit flag

EOF
                      expect => <<'EOF',



flags Test



foo


EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'init',
                      description => 'tests <%init> section',
                      component => <<'EOF',



init Test



<% $message %>



<%init>
my $message = "Hello World!";

EOF
                      expect => <<'EOF',



init Test



Hello World!



EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'method',
                      description => 'tests <%method> section',
                      component => <<'EOF',



method Test



% $m->current_comp->call_method('foo','y'=>2);
% my $out = $m->current_comp->scall_method('bar',qw(a b c));
<% uc($out) %>


<%method foo>
% my $sum = $y + $y;
<% $y %> + <% $y %> = <% $sum %>.
<%ARGS>
$y


<%method bar>
The second method. Arguments are <% join(",",@_) %>.

EOF
                      expect => <<'EOF',



method Test




2 + 2 = 4.

THE SECOND METHOD. ARGUMENTS ARE A,B,C.



EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'once',
                      description => 'tests <%once> block',
                      component => <<'EOF',



once Test



<% $message %>



<%once>
my $message = "Hello World";


<%INIT>
$message .= "!";

EOF
                      expect => <<'EOF',



once Test



Hello World!




EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'perl',
                      description => 'test <%perl> sections and makes sure block names are case-insensitive',
                      component => <<'EOF',



perl Test



<%perl>
my $message = "Hello";

<%Perl>
$message .= " World!";

<% $message %>
<%perl>
$message = "How are you?";

<% $message %>


EOF
                      expect => <<'EOF',



perl Test



Hello World!
How are you?


EOF
                    );

#------------------------------------------------------------

=pod

    $group->add_test( name => 'perl_args',
                      description => 'tests old <%perl_args> block',
                      component => <<'EOF',
<& support/perl_args_test, a=>'fargo', b=>[17,82,16], c=>{britain=>3, spain=>1} &>

EOF
                      expect => <<'EOF',
a: fargo
b: 17,82,16
c: britain=3,spain=1
d: 5
e: foo,baz
f: bob=2,joe=1



EOF
                    );

=cut

#------------------------------------------------------------

    # Carp in 5.6.0 is broken so just skip it
    unless ($] == 5.006)
    {
        $group->add_test( name => 'omitted_args',
                          description => 'tests error message when expect args are not passed',
                          component => '<& support/perl_args_test, b=>[17,82,16], c=>{britain=>3, spain=>1} &>',
                          expect_error => qr{no value sent for required parameter 'a'},
                        );
    }

#------------------------------------------------------------

    $group->add_test( name => 'overridden_args',
                      description => 'tests overriding of default args values',
                      component => <<'EOF',
<& support/perl_args_test, a=>'fargo', b=>[17,82,16], c=>{britain=>3, spain=>1}, d=>103, e=>['a','b','c'], f=>{ralph=>15, sue=>37} &>
EOF
                      expect => <<'EOF',
a: fargo
b: 17,82,16
c: britain=3,spain=1
d: 103
e: a,b,c
f: ralph=15,sue=37


EOF
                    );

#------------------------------------------------------------

=pod

    $group->add_test( name => 'perl_doc',
                      description => 'tests old <%perl_doc> section',
                      component => <<'EOF',



perl_doc Test



Hello World!



<%perl_doc>
This is an HTML::Mason documentation section.

Right?

EOF
                      expect => <<'EOF',



perl_doc Test



Hello World!



EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'perl_init',
                      description => 'tests old <%perl_init> section',
                      component => <<'EOF',



perl_init Test



<% $message %>



<%perl_init>
my $message = "Hello World!";

EOF
                      expect => <<'EOF',



perl_init Test



Hello World!



EOF
                    );

=cut

#------------------------------------------------------------

    $group->add_test( name => 'shared',
                      description => 'tests <%shared> section',
                      component => <<'EOF',
<%def .main>
Hello <% $name %>.

% $m->current_comp->owner->call_method('foo');
% $m->current_comp->owner->call_method('bar');
<& .baz &>


<%method foo>
This is the foo method, <% $name %>.

<%method bar>
This is the bar method, <% $name %>.

<%def .baz>
This is the baz subcomponent, <% $name %>.


<& .main &>

% $name = 'Mary';
<& .main &>

<%shared>
my $name = 'Joe';

EOF
                      expect => <<'EOF',



Hello Joe.


This is the foo method, Joe.

This is the bar method, Joe.

This is the baz subcomponent, Joe.




Hello Mary.


This is the foo method, Mary.

This is the bar method, Mary.

This is the baz subcomponent, Mary.



EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'text',
                      description => 'tests <%text> section',
                      component => <<'EOF',
<%text>
%
<%once>
<%init>
<%doc>
<%args>

EOF
                      expect => <<'EOF',

%
<%once>
<%init>
<%doc>
<%args>
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'multiple',
                      description => 'tests repeated blocks of the same type',
                      component => <<'EOF',
<%attr>
name=>'Joe'

<%init>
my $var1 = "Foo!";

<%filter>
tr/a-z/A-Z/

var1 = <% $var1 %>
var2 = <% $var2 %>
Name = <% $m->current_comp->attr('name') %>
Color = <% $m->current_comp->attr('color') %>
<%filter>
s/\!/\?/g

<%init>
my $var2 = "Bar!";

<%attr>
color=>'Blue'

EOF
                      expect => <<'EOF',
VAR1 = FOO?
VAR2 = BAR?
NAME = JOE
COLOR = BLUE
EOF
                    );

#------------------------------------------------------------

    return $group;
}
HTML-Mason-1.59/t/00-report-prereqs.t0000644000175000017500000001342613660015140016770 0ustar  autarchautarch#!perl

use strict;
use warnings;

# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.027

use Test::More tests => 1;

use ExtUtils::MakeMaker;
use File::Spec;

# from $version::LAX
my $lax_version_re =
    qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )?
            |
            (?:\.[0-9]+) (?:_[0-9]+)?
        ) | (?:
            v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )?
            |
            (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)?
        )
    )/x;

# hide optional CPAN::Meta modules from prereq scanner
# and check if they are available
my $cpan_meta = "CPAN::Meta";
my $cpan_meta_pre = "CPAN::Meta::Prereqs";
my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic

# Verify requirements?
my $DO_VERIFY_PREREQS = 1;

sub _max {
    my $max = shift;
    $max = ( $_ > $max ) ? $_ : $max for @_;
    return $max;
}

sub _merge_prereqs {
    my ($collector, $prereqs) = @_;

    # CPAN::Meta::Prereqs object
    if (ref $collector eq $cpan_meta_pre) {
        return $collector->with_merged_prereqs(
            CPAN::Meta::Prereqs->new( $prereqs )
        );
    }

    # Raw hashrefs
    for my $phase ( keys %$prereqs ) {
        for my $type ( keys %{ $prereqs->{$phase} } ) {
            for my $module ( keys %{ $prereqs->{$phase}{$type} } ) {
                $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module};
            }
        }
    }

    return $collector;
}

my @include = qw(

);

my @exclude = qw(

);

# Add static prereqs to the included modules list
my $static_prereqs = do './t/00-report-prereqs.dd';

# Merge all prereqs (either with ::Prereqs or a hashref)
my $full_prereqs = _merge_prereqs(
    ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ),
    $static_prereqs
);

# Add dynamic prereqs to the included modules list (if we can)
my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml';
my $cpan_meta_error;
if ( $source && $HAS_CPAN_META
    && (my $meta = eval { CPAN::Meta->load_file($source) } )
) {
    $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs);
}
else {
    $cpan_meta_error = $@;    # capture error from CPAN::Meta->load_file($source)
    $source = 'static metadata';
}

my @full_reports;
my @dep_errors;
my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs;

# Add static includes into a fake section
for my $mod (@include) {
    $req_hash->{other}{modules}{$mod} = 0;
}

for my $phase ( qw(configure build test runtime develop other) ) {
    next unless $req_hash->{$phase};
    next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING});

    for my $type ( qw(requires recommends suggests conflicts modules) ) {
        next unless $req_hash->{$phase}{$type};

        my $title = ucfirst($phase).' '.ucfirst($type);
        my @reports = [qw/Module Want Have/];

        for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) {
            next if $mod eq 'perl';
            next if grep { $_ eq $mod } @exclude;

            my $file = $mod;
            $file =~ s{::}{/}g;
            $file .= ".pm";
            my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC;

            my $want = $req_hash->{$phase}{$type}{$mod};
            $want = "undef" unless defined $want;
            $want = "any" if !$want && $want == 0;

            my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required";

            if ($prefix) {
                my $have = MM->parse_version( File::Spec->catfile($prefix, $file) );
                $have = "undef" unless defined $have;
                push @reports, [$mod, $want, $have];

                if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) {
                    if ( $have !~ /\A$lax_version_re\z/ ) {
                        push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)";
                    }
                    elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) {
                        push @dep_errors, "$mod version '$have' is not in required range '$want'";
                    }
                }
            }
            else {
                push @reports, [$mod, $want, "missing"];

                if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) {
                    push @dep_errors, "$mod is not installed ($req_string)";
                }
            }
        }

        if ( @reports ) {
            push @full_reports, "=== $title ===\n\n";

            my $ml = _max( map { length $_->[0] } @reports );
            my $wl = _max( map { length $_->[1] } @reports );
            my $hl = _max( map { length $_->[2] } @reports );

            if ($type eq 'modules') {
                splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
                push @full_reports, map { sprintf("    %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
            }
            else {
                splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl];
                push @full_reports, map { sprintf("    %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports;
            }

            push @full_reports, "\n";
        }
    }
}

if ( @full_reports ) {
    diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports;
}

if ( $cpan_meta_error || @dep_errors ) {
    diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n";
}

if ( $cpan_meta_error ) {
    my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml';
    diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n";
}

if ( @dep_errors ) {
    diag join("\n",
        "\nThe following REQUIRED prerequisites were not satisfied:\n",
        @dep_errors,
        "\n"
    );
}

pass;

# vim: ts=4 sts=4 sw=4 et:
HTML-Mason-1.59/t/lib/0000755000175000017500000000000013660015140014134 5ustar  autarchautarchHTML-Mason-1.59/t/lib/BadModule.pm0000644000175000017500000000002613660015140016324 0ustar  autarchautarchpackage BadModule;

(
HTML-Mason-1.59/t/lib/Apache/0000755000175000017500000000000013660015140015315 5ustar  autarchautarchHTML-Mason-1.59/t/lib/Apache/test.pm0000644000175000017500000005506513660015140016645 0ustar  autarchautarchpackage Apache::test;

use strict;
use vars qw(@EXPORT $USE_THREAD $USE_SFIO $PERL_DIR @EXPORT_OK);
use Exporter ();
use Config;
use FileHandle ();
*import = \&Exporter::import;

@EXPORT = qw(test fetch simple_fetch have_module skip_test
             $USE_THREAD $USE_SFIO $PERL_DIR WIN32 grab run_test); 
@EXPORT_OK = qw(have_httpd);

BEGIN { 
    if(not $ENV{MOD_PERL}) {
        eval { require "net/config.pl"; }; #for 'make test'
        $PERL_DIR = $net::perldir;
    } 
    if ($net::httpserver) {
        # Validate that the OS knows the name of the server in $net::httpserver     
        # if 'localhost' is not defined, the tests wouldn't pass
        (my $hostname) = ($net::httpserver =~ /(.*?):/);
        warn qq{\n*** [Crucial] You must define "$hostname" (e.g. in /etc/hosts) in order for 'make test' to pass\n}  
        unless gethostbyname $hostname;
    }
}

$PERL_DIR = $ENV{PERL_DIR} if exists $ENV{PERL_DIR};

$USE_THREAD = ($Config{extensions} =~ /Thread/) || $Config{usethreads};
$USE_SFIO = (($Config{'usesfio'} || '') eq 'true');

my $Is_Win32 = ($^O eq "MSWin32");
sub WIN32 () { $Is_Win32 };

my $UA;

eval {
    require LWP::UserAgent;
    $UA = LWP::UserAgent->new;
};

unless (defined &Apache::bootstrap) {
    *Apache::bootstrap = sub {};
    *Apache::Constants::bootstrap = sub {};
}

sub write_httpd_conf {
    my $pkg = shift;
    my %args = (conf_file => 't/httpd.conf', @_);
    my $DIR = `pwd`; chomp $DIR;

    # Apache2 tweaks
    my $Port = 'Port';
    my $AccessConfig = 'AccessConfig /dev/null';
    my $ResourceConfig = 'ResourceConfig /dev/null';
    my $ScoreBoardFile = 'ScoreBoardFile /dev/null';
    if ($args{version} =~ m/^2\./) {
        $Port = 'Listen';
        $AccessConfig = '';
        $ResourceConfig = '';
        $ScoreBoardFile = '';
    }

    local *CONF;
    open CONF, ">$args{conf_file}" or die "Can't create $args{conf_file}: $!";
    print CONF <);
        $response ||= $default;
    } until (!$mustfind || ($response eq $canskip) || (-e $response || !print("$response not found\n")));

    return $response;
}

sub get_test_params {
    my $pkg = shift;

    print("\nFor testing purposes, please give the full path to an httpd\n",
          "with mod_perl enabled.  The path defaults to \$ENV{APACHE}, if present.");
    
    my %conf;
    
    my $httpd = $pkg->_find_mod_perl_httpd(1);

    my $found;
    do
    {
        $httpd = _ask("\n", $httpd, 1, '!');
        if ($httpd eq '!') {
            print "Skipping.\n";
            return;
        }

        if ($pkg->_httpd_has_mod_perl($httpd)) {
            $found = 1;
        } else {
            warn("$httpd does not appear to have been compiled with\n",
                 "mod_perl as a static or dynamic module\n");
            $httpd = $pkg->_find_mod_perl_httpd(0);
        }
    } until ($found);
    system "$Config{lns} $httpd t/httpd";
    $conf{httpd} = $httpd;

    # Default: search for dynamic dependencies if mod_so is present, don't bother otherwise.
    my $default = (`t/httpd -l` =~ /mod_so\.c/ ? 'y' : 'n');
    if (lc _ask("Search existing config file for dynamic module dependencies?", $default) eq 'y') {
        my %compiled = $pkg->get_compilation_params('t/httpd');

        $conf{version} = $compiled{SERVER_VERSION};
        $conf{config_file} = _ask("  Config file", $compiled{SERVER_CONFIG_FILE}, 1);
        $conf{modules} = $pkg->_read_existing_conf($conf{config_file});
    }

    # Get default user (apache doesn't like to run as root, special-case it)
    my $defuser = ($< && getpwuid $<) || 'nobody';
    $conf{user} = _ask("User to run tests under", $defuser);

    my $defgroup = ($defuser eq 'nobody' ? 'nobody' : getgrgid((getpwnam $conf{user})[3]));
    $conf{group} = _ask("Group to run tests under", $defgroup);

    $conf{port} = _ask("Port to run tests under", 8228);

    return %conf;
}

sub get_compilation_params {
    my ($self, $httpd) = @_;

    my %compiled;
    for (`$httpd -V`) {
        if (/([\w]+)="(.*)"/) {
            $compiled{$1} = $2;
        }
        if (/Server version: .*?([\d\.]+)/i) {
            $compiled{SERVER_VERSION} = $1;
        }
    }
    $compiled{SERVER_CONFIG_FILE} =~ s,^,$compiled{HTTPD_ROOT}/,
        unless $compiled{SERVER_CONFIG_FILE} =~ m,^/,;

    return %compiled;
}

sub _read_existing_conf {
    # Returns some "(Add|Load)Module" config lines, generated from the
    # existing config file and a few must-have modules.
    my ($self, $server_conf, $default_root, $is_include) = @_;

    open SERVER_CONF, $server_conf or die "Couldn't open $server_conf: $!";
    my @lines = grep {!m/^\s*\#/} ;
    close SERVER_CONF;

    my ($server_root) = (map /^\s*ServerRoot\s*(\S+)/, @lines);
    $server_root =~ s/^"//;
    $server_root =~ s/"$//;

    $server_root ||= $default_root;

    my @includes;
    foreach my $include (grep /^\s*Include\s+\S+/, @lines) {
        my ($file) = $include =~ /^\s*Include\s+(\S+)/;
        $file =~ s/^"//;
        $file =~ s/"//;
        $file =~ s!^([^/])!$server_root/$1!;  # absolute path

        if ($file =~ m/\*/) {
            # expand wildcard includes (used in Fedora Core 1 default config)
            my @add = glob $file;
            unless ($Apache::test::quiet) {
                warn "expanding wildcard Include $file\n";
                warn "ADDED INC $_\n" for @add;
            }
            push @includes, @add;
        } else {
            push @includes, $file;
            warn "ADDED INC $file\n" unless $Apache::test::quiet;
        }
    }

    my @modules = grep /^\s*(Add|Load|Clear)Module/, @lines;

    # Rewrite all modules to load from an absolute path.
    foreach (@modules) {
        s!(\s)([^/\s]\S+/)!$1$server_root/$2!;
    }

    # Follow each include recursively to find needed modules
    foreach my $include (@includes) {
        push @modules, $self->_read_existing_conf($include, $server_root, 1);
    }
    # The last bits only need to be done once.
    return @modules if $is_include;

    my $static_mods = $self->static_modules('t/httpd');
    
    my @load;
    # Have to make sure that dir, autoindex and perl are loaded.
    foreach my $module (qw(dir autoindex perl)) {
       unless ($static_mods->{"mod_$module"} or grep /$module/i, @modules) {
           warn "Will attempt to load mod_$module dynamically.\n" unless $Apache::test::quiet;
            push @load, $module;
        }
    }

    # Directories where apache DSOs live.
    my @module_dirs = map {m,(/\S*)/,} @modules;
    
    # Finally compute the directives to load modules that need to be loaded.
 MODULE:
    foreach my $module (@load) {
        foreach my $module_dir (@module_dirs) {
           foreach my $filename ("mod_$module.so", "lib$module.so", "ApacheModule\u$module.dll") {
               if (-e "$module_dir/$filename") {
                   push @modules, "LoadModule ${module}_module $module_dir/$filename\n"; next MODULE;
               }
            }
        }
       warn "Warning: couldn't find anything to load for 'mod_$module'.\n" unless $Apache::test::quiet;
    }

    unless ($Apache::test::quiet) {
        print "Adding the following dynamic config lines: \n";
        print join '', @modules;
        print "\n\n";
    }
    return join '', @modules;
}

sub static_modules {
    # Returns a hashref whose keys are each of the modules compiled
    # statically into the given httpd binary.
    my ($self, $httpd) = @_;

    my @l = `$httpd -l`;
    return {map {lc($_) => 1} map /(\S+)\.c/, @l};
}

sub _find_mod_perl_httpd {
    my ($self, $respect_env) = @_;

    return $ENV{'APACHE'} if $ENV{'APACHE'} && $respect_env;

    local $Apache::test::quiet = 1;
    foreach ( '/usr/local/apache/bin/httpd',
              '/usr/local/apache_mp/bin/httpd',
              '/usr/local/apache2/bin/httpd',
              '/opt/apache/bin/httpd',
              '/usr/sbin/apache-perl',
              '/usr/sbin/apache',
              '/usr/sbin/apache2',
              '/usr/sbin/httpd',
              $self->_which('httpd'),
              $self->_which('apache'),
            ) {
        return $_ if -x $_ && $self->_httpd_has_mod_perl($_);
    }
}

sub _httpd_has_mod_perl {
    my ($self, $httpd) = @_;

    return 1 if `$httpd -l` =~ /mod_perl\.c/;

    my %compiled = $self->get_compilation_params($httpd);

    if ($compiled{SERVER_VERSION} =~ m/^2\./) {
        warn("Apache $compiled{SERVER_VERSION} detected. Report problems to mason-users\@lists.sourceforge.net\n") unless $Apache::test::quiet;
    }

    if ($compiled{SERVER_CONFIG_FILE}) {
        local $Apache::test::quiet = 1;
        my @lines = $self->_read_existing_conf($compiled{SERVER_CONFIG_FILE},$compiled{HTTPD_ROOT});
        return 1 if grep { /mod_perl/ } grep /^\s*(Add|Load)Module/, @lines;
    }

    return 0;
}

sub _which {
    return grep {-x $_} map { "$_/$_[1]" } split /:/, $ENV{PATH};
}

sub test { 
    shift() if UNIVERSAL::isa($_[0], __PACKAGE__);
    my $s = $_[1] ? "ok $_[0]\n" : "not ok $_[0]\n";
    if($ENV{MOD_PERL}) {
        Apache->request->print($s);
    }
    else {
        print $s;
    }
}

sub fetch {
    # Old code calls fetch() as a function, new code as a method
    my $want_response;
    $want_response = shift() if UNIVERSAL::isa($_[0], __PACKAGE__);
    my ($ua, $url) = (@_ == 1 ? ($UA, shift()) : @_);
    my $request = ref $url ? $url : {uri=>$url};

    # Set some defaults
    $ENV{PORT} ||= 8529;  # For mod_perl's own tests
    $request->{method} ||= 'GET';
    $request->{content} = '' unless exists $request->{content};
    $request->{uri} = "http://localhost:$ENV{PORT}$request->{uri}"    
        unless $request->{uri} =~ /^http/;
    $request->{headers}{Content_Type} = 'application/x-www-form-urlencoded'
        if (!$request->{headers} and $request->{method} eq 'POST');  # Is this necessary?

    # Create & send the request
    $request->{headers} = new HTTP::Headers(%{$request->{headers}||{}});
    my $req = new HTTP::Request(@{$request}{'method','uri','headers','content'});
    my $response = $ua->request($req);

    return $want_response ? $response : $response->content;
}

sub simple_fetch {
    my $ua = LWP::UserAgent->new;
    my $url = URI::URL->new("http://$net::httpserver");
    my($path,$q) = split /\?/, shift; 
    $url->path($path);
    $url->query($q) if $q;
    my $request = new HTTP::Request('GET', $url);
    my $response = $ua->request($request, undef, undef);   
    $response->is_success;
}

sub have_module {
    my $mod = shift;
    my $v = shift;
    eval {# surpress "can't boostrap" warnings
        local $SIG{__WARN__} = sub {};
        if ($mod_perl2::VERSION >= 2.00) {
            # use Apache2 is no longer needed
        } else {
            require Apache;
        }
    };

    eval "require $mod";
    if($v and not $@) {
        eval { 
            local $SIG{__WARN__} = sub {};
            $mod->UNIVERSAL::VERSION($v);
        };
        if($@) {
            warn $@;
            return 0;
        }
    }
    if($@ && ($@ =~ /Can.t locate/)) {
        return 0;
    }
    elsif($@ && ($@ =~ /Can.t find loadable object for module/)) {
        return 0;
    }
    elsif($@) {
        warn "$@\n";
    }


    print "module $mod is installed\n" unless $ENV{MOD_PERL};
    
    return 1;
}

sub skip_test {
    print "1..0\n";
    exit;
}

sub have_httpd {
    return -e 't/httpd';
}

sub run {
    require Test::Harness;
    my $self = shift;
    my $args = shift || {};
    my @tests = ();

    # First we check if we already are within the "t" directory
    if (-d "t") {
        # try to move into test directory
        chdir "t" or die "Can't chdir: $!";

        # fix all relative library locations
        foreach (@INC) {
            $_ = "../$_" unless m,^(/)|([a-f]:),i;
        }
    }

    # Pick up the library files from the ../blib directory
    unshift(@INC, "../blib/lib", "../blib/arch");
    #print "@INC\n";

    $Test::Harness::verbose = shift(@ARGV)
        if $ARGV[0] =~ /^\d+$/ || $ARGV[0] eq "-v";

    $Test::Harness::verbose ||= $args->{verbose};

    if (@ARGV) {
        for (@ARGV) {
            if (-d $_) {
                push(@tests, <$_/*.t>);
            } 
            else {
                $_ .= ".t" unless /\.t$/;
                push(@tests, $_);
            }
        }
    } 
    else {
        push @tests, <*.t>, map { <$_/*.t> } @{ $args->{tdirs} || [] };
    }

    Test::Harness::runtests(@tests);
}

sub MM_test {
    # Writes the test section for the Makefile
    shift();  # Don't need package name
    my %conf = @_;

    my $section = < 0) { 
        die "usage: grab host:port path";
    }

    my($host, $port) = split ":", shift @args;
    $port ||= 80;
    my $url = shift @args || "/";

    my $remote = IO::Socket::INET->new(Proto     => "tcp",
                                       PeerAddr  => $host,
                                       PeerPort  => $port,
                                       );
    unless ($remote) {
        die "cannot connect to http daemon on $host"; 
    }
    $remote->autoflush(1);
    print $remote "GET $url HTTP/1.0\n\n";
    my $response_line = 0;
    my $header_terminator = 0;
    my @msg = ();

    while ( <$remote> ) {
        #e.g. HTTP/1.1 200 OK
        if(m:^(HTTP/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*):i) {
            push @msg, $_;
            $response_line = 1;
        }
        elsif(/^([a-zA-Z0-9_\-]+)\s*:\s*(.*)/) {
            push @msg, $_;
        }
        elsif(/^\015?\012$/) {
            $header_terminator = 1;
            push @msg, $_;
        }

        print;
    }
    close $remote;

    print "~" x 40, "\n", "Diagnostics:\n";
    if ($response_line and $header_terminator) {
        print " HTTP response is valid:\n";
    }
    else {
        print "     GET -> http://$host:$port$url\n";
        print " >>> No response line\n" unless $response_line;
        print " >>> No header terminator\n" unless $header_terminator;
        print " *** HTTP response is malformed\n";
    }
    print "-" x 40, "\n", @msg, "-" x 40, "\n";
}

sub run_test {
    my($test, $verbose) = @_; 
    my $cmd = "$^X -w $test|";
    my $fh = FileHandle->new;
    $fh->open($cmd) or print "can't run $test. $!\n";
    my($ok,$next,$max,$files,$totok,$totmax);
    $ok = $next = $max = 0;
    my @failed = ();
    while (<$fh>) {
        if( $verbose ){
            print ">>> $_";
        }
        if (/^1\.\.([0-9]+)/) {
            $max = $1;
            $totmax += $max;
            $files++;
            $next = 1;
        }
        elsif ($max && /^(not\s+)?ok\b/) {
            my $this = $next;
            if (/^not ok\s*(\d*)/){
                $this = $1 if $1 > 0;
                push @failed, $this;
            }
            elsif (/^ok\s*(\d*)/) {
                $this = $1 if $1 > 0;
                $ok++;
                $totok++;
            }
            if ($this > $next) {
                # warn "Test output counter mismatch [test $this]\n";
                # no need to warn probably
                push @failed, $next..$this-1;
            }
            elsif ($this < $next) {
                #we have seen more "ok" lines than the number suggests
                warn "Confused test output: test $this answered after test ", $next-1, "\n";
                $next = $this;
            }
            $next = $this + 1;
        }
    }
    $fh->close; # must close to reap child resource values
    return($max, \@failed);
}

1;

__END__

=head1 NAME

Apache::test - Facilitates testing of Apache::* modules

=head1 SYNOPSIS

 # In Makefile.PL
 use Apache::test;
 my %params = Apache::test->get_test_params();
 Apache::test->write_httpd_conf(%params, include => $more_directives);
 *MY::test = sub { Apache::test->MM_test(%params) };

 # In t/*.t script (or test.pl)
 use Apache::test qw(skip_test have_httpd);
 skip_test unless have_httpd;
 (Some more methods of Doug's that I haven't reviewed or documented yet)

=head1 DESCRIPTION

This module helps authors of Apache::* modules write test suites that
can query an actual running Apache server with mod_perl and their
modules loaded into it.  Its functionality is generally separated into
methods that go in a Makefile.PL to configure, start, and stop the
server, and methods that go in one of the test scripts to make HTTP
queries and manage the results.

=head1 METHODS

=head2 get_test_params()

This will ask the user a few questions about where the httpd binary
is, and what user/group/port should be used when running the server.
It will return a hash of the information it discovers.  This hash is
suitable for passing to the C method.

=head2 write_httpd_conf(%params)

This will write a basic C file suitable for starting a
HTTP server during the 'make test' stage.  A hash of key/value pairs
that affect the written file can be passed as arguments.  The
following keys are recognized:

=over 4

=item * conf_file

The path to the file that will be created.  Default is 't/httpd.conf'.

=item * port

The port that the Apache server will listen on.

=item * user

The user that the Apache server will run as.

=item * group

The group that the Apache server will run as.

=item * include

Any additional text you want added at the end of the config file.
Typically you'll have some C and C
directives to pass control to the module you're testing.  The C
directories will be added to the C<@INC> path when searching for
modules, so that's nice.

=back

=head2 MM_test(%params)

This method helps write a Makefile that supports running a web server
during the 'make test' stage.  When you execute 'make test', 'make'
will run 'make start_httpd', 'make run_tests', and 'make kill_httpd'
in sequence.  You can also run these commands independently if you
want.

Pass the hash of parameters returned by C as an
argument to C.

To patch into the ExtUtils::MakeMaker wizardry (voodoo?), typically
you'll do the following in your Makefile.PL:

  *MY::test = sub { Apache::test->MM_test(%params) };

=head2 fetch

  Apache::test->fetch($request);
  Apache::test->fetch($user_agent, $request);

Call this method in a test script in order to fetch a page from the
running web server.  If you pass two arguments, the first should be an
LWP::UserAgent object, and the second should specify the request to
make of the server.  If you only pass one argument, it specifies the
request to make.

The request can be specified either by a simple string indicating the
URI to fetch, or by a hash reference, which gives you more control
over the request.  The following keys are recognized in the hash:

=over 4

=item * uri

The URI to fetch from the server.  If the URI does not begin with
"http", we prepend "http://localhost:$PORT" so that we make requests
of the test server.

=item * method

The request method to use.  Default is 'GET'.

=item * content

The request content body.  Typically used to simulate HTML fill-out
form submission for POST requests.  Default is null.

=item * headers

A hash of headers you want sent with the request.  You might use this
to send cookies or provide some application-specific header.

=back

If you don't provide a 'headers' parameter and you set the 'method'
to 'POST', then we assume that you're trying to simulate HTML form
submission and we add a 'Content_Type' header with a value of
'application/x-www-form-urlencoded'.

In a scalar context, fetch() returns the content of the web server's
response.  In a list context, fetch() returns the content and the
HTTP::Response object itself.  This can be handy if you need to check
the response headers, or the HTTP return code, or whatever.

=head2 static_modules

 Example: $mods = Apache::test->static_modules('/path/to/httpd');

This method returns a hashref whose keys are all the modules
statically compiled into the given httpd binary.  The corresponding
values are all 1.

=head1 EXAMPLES

No good examples yet.  Example submissions are welcome.  In the meantime, see
L , which
I'm retrofitting to use Apache::test.

=head1 TO DO

The MM_test method doesn't try to be very smart, it just writes the
text that seems to work in my configuration.  I am morally against
using the 'make' command for installing Perl modules (though of course
I do it anyway), so I haven't looked into this very much.  Send bug
reports or better (patches).

I've got lots of code in my Apache::AuthCookie module (etc.) that
assists in actually making the queries of the running server.  I plan
to add that to this module, but first I need to compare what's already
here that does the same stuff.

=head1 KUDOS

To Doug MacEachern for writing the first version of this module.

To caelum@debian.org (Rafael Kitover) for contributing the code to
parse existing httpd.conf files for --enable-shared=max and DSOs.

=head1 CAVEATS

Except for making sure that the mod_perl distribution itself can run
'make test' okay, I haven't tried very hard to keep compatibility with
older versions of this module.  In particular MM_test() has changed
and probably isn't usable in the old ways, since some of its
assumptions are gone.  But none of this was ever documented, and
MM_test() doesn't seem to actually be used anywhere in the mod_perl
disribution, so I don't feel so bad about it.

=head1 AUTHOR

Doug MacEachern (original version)

Ken Williams (latest changes and this documentation)

=cut

HTML-Mason-1.59/t/lib/Mason/0000755000175000017500000000000013660015140015211 5ustar  autarchautarchHTML-Mason-1.59/t/lib/Mason/ApacheTest.pm0000644000175000017500000006657713660015140017615 0ustar  autarchautarchpackage Mason::ApacheTest;

use strict;
use warnings;

use Apache::test qw( have_httpd have_module );
use File::Basename qw( dirname );
use File::Path qw( mkpath rmtree );
use File::Spec;
use Module::Build;
use Test::More;

use lib 'inc';

use base 'Exporter';
our @EXPORT_OK = qw( require_libapreq require_cgi require_apache_filter chmod_data_dir );


my $TestConfig;

INIT
{
    $TestConfig = Module::Build->current()->notes()->{apache_test_conf};

    unless ( $TestConfig
             && defined $TestConfig->{apache_dir}
             && -d $TestConfig->{apache_dir} )
    {
        plan skip_all =>
            '$TestConfig->{is_maintainer} is not true or '
            . '$TestConfig->{apache_dir} is not a directory';
    }

    unless ( have_httpd() )
    {
        plan skip_all => 'Apache::test::have_httpd() returned a false value';
    }
}

sub require_libapreq
{
    my $version = _apache_version();

    my $module = $version == 1 ? 'Apache::Request' : 'Apache2::Request';

    unless ( eval "use $module; 1" )
    {
        plan skip_all => "These tests require the $module module.";
    }
}

sub require_cgi
{
    unless ( eval 'use CGI 3.08; 1' )
    {
        plan skip_all => 'These tests required CGI.pm 3.08 or greater.';
    }
}

sub require_apache_filter
{
    my $version = _apache_version();

    unless ( eval 'use Apache::Filter; 1' && $version == 1 )
    {
        plan skip_all => 'These tests required Apache::Filter and mod_perl 1.';
    }
}

sub _apache_version
{
    my $apache_bin = _apache_bin();

    my ($version) = `$apache_bin -v` =~ m{version: Apache/(\d)};

    die "Could not determine Apache version"
        unless $version;

    return $version;
}

sub _apache_bin
{
    return File::Spec->catfile( $TestConfig->{apache_dir}, 'httpd' );
}

sub chmod_data_dir
{
    # This is a hack but otherwise the multi-conf tests fail if the
    # Apache server runs as any user other than root.  In real life, a
    # user using the multi-config option with httpd.conf must handle
    # the file permissions manually.
    if ( $> == 0 || $< == 0 )
    {
        chmod 0777, File::Spec->catdir( $TestConfig->{apache_dir}, 'data' );
    }
}

sub run_tests
{
    my $class = shift;
    my %p     = @_;

    # Needed for Apache::test->fetch() to work
    local $ENV{PORT} = $TestConfig->{port};

    _write_test_comps();

    my @tests = $class->_tests(%p);

    my $count = 0;
    $count++ for grep { $_->{expect} || $_->{regex} } @tests;
    $count++ for map { $_->{extra} ? @{ $_->{extra} } : () } @tests;

    plan tests => $count;

    _kill_httpd();

    _start_httpd( $p{apache_define} );

    _cleanup_data_dir();

    _run_test( \%p, $_ ) for @tests;

    _kill_httpd();
}

sub _write_test_comps
{
    _write_comp( 'basic', <<'EOF',
Basic test.
2 + 2 = <% 2 + 2 %>.
uri = <% $r->uri =~ /basic$/ ? '/basic' : $r->uri %>.
method = <% $r->method %>.


EOF
              );

    _write_comp( 'headers', <<'EOF',


% $r->headers_out->{'X-Mason-Test'} = 'New value 2';
Blah blah
blah
% $r->headers_out->{'X-Mason-Test'} = 'New value 3';
<%init>
$r->headers_out->{'X-Mason-Test'} = 'New value 1';
$m->abort if $blank;

<%args>
$blank=>0

EOF
              );

    _write_comp( 'cgi_object', <<'EOF',
<% UNIVERSAL::isa(eval { $m->cgi_object } || undef, 'CGI') ? 'CGI' : 'NO CGI' %><% $@ || '' %>
EOF
              );

    _write_comp( 'params', <<'EOF',
% foreach (sort keys %ARGS) {
<% $_ %>: <% ref $ARGS{$_} ? join ', ', sort @{ $ARGS{$_} }, 'array' : $ARGS{$_} %>
% }
EOF
              );

    _write_comp( '_underscore', <<'EOF',
I am underscore.
EOF
              );

    _write_comp( 'die', <<'EOF',
% die 'Mine heart is pierced';
EOF
              );

    _write_comp( 'apache_request', <<'EOF',
% if ($r->isa('Apache::Request') || $r->isa('Apache2::Request')) {
Apache::Request
% }
EOF
                  );

    _write_comp( 'multiconf1/foo', <<'EOF',
I am foo in multiconf1
comp root is <% $m->interp->comp_root =~ m,/comps/multiconf1$, ? 'multiconf1' : $m->interp->comp_root %>
EOF
              );

    _write_comp( 'multiconf1/autohandler', <<'EOF'
<& $m->fetch_next, autohandler => 'present' &>
EOF
              );

    _write_comp( 'multiconf1/autohandler_test', <<'EOF'
<%args>
$autohandler => 'misnamed'

autohandler is <% $autohandler %>
EOF
              );


    _write_comp( 'multiconf2/foo', <<'EOF',
I am foo in multiconf2
comp root is <% $m->interp->comp_root =~ m,/comps/multiconf2$, ? 'multiconf2' : $m->interp->comp_root %>
EOF
              );

    _write_comp( 'multiconf2/dhandler', <<'EOF',
This should not work
EOF
              );

    _write_comp( 'allow_globals', <<'EOF',
% $foo = 1;
% @bar = ( qw( a b c ) );
$foo is <% $foo %>
@bar is <% @bar %>
EOF
              );

    _write_comp( 'decline_dirs', <<'EOF',
decline_dirs is <% $m->ah->decline_dirs %>
EOF
              );

    _write_comp( 'with_dhandler/dhandler', <<'EOF',
% $r->content_type('text/html');
with a dhandler
EOF
              );

    _write_comp( 'with_dhandler_no_ct/dhandler', <<'EOF',
with a dhandler, no content type
EOF
              );

    _write_comp( 'print', <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
              );

    _write_comp( 'r_print', <<'EOF',
This is first.
% $r->print("This is second.\n");
This is third.
EOF
              );

    _write_comp( 'flush_buffer', <<'EOF',
% $m->print("foo\n");
% $m->flush_buffer;
bar
EOF
              );

    _write_comp( 'head_request', <<'EOF',
<%init>
my $x = 1;
foreach (sort keys %ARGS) {
  $r->headers_out->{'X-Mason-HEAD-Test' . $x++} = "$_: " . (ref $ARGS{$_} ? 'is a ref' : 'not a ref' );
}

We should never see this.
EOF
              );

    _write_comp( 'redirect', <<'EOF',
% $m->print("\n");  # leading whitespace

<%perl>
$m->scomp('foo');
$m->redirect('/comps/basic');

<%def foo>
fum

EOF
              );

    _write_comp( 'internal_redirect', <<'EOF',
<%init>
if ($mod_perl2::VERSION >= 1.99) { require Apache2::SubRequest; }
$r->internal_redirect('/comps/internal_redirect_target?foo=17');
$m->auto_send_headers(0);
$m->clear_buffer;
$m->abort;

EOF
              );

    _write_comp( 'subrequest', <<'EOF',
<%init>
# tests can run under various comp_root settings
my $comp_root = $m->interp->comp_root;
$comp_root = $$comp_root[0][1] if ref $comp_root;
my $comp = $comp_root =~ m/comps/ ? '/internal_redirect_target' : '/comps/internal_redirect_target';

$m->clear_buffer;
my $sub = $m->make_subrequest(comp => $comp, args=> [ foo => 17 ]);
$sub->exec;
$m->flush_buffer;
$m->abort(200);

EOF
              );

    _write_comp( 'internal_redirect_target', <<'EOF',
The number is <% $foo %>.
<%args>
$foo

EOF
              );

    _write_comp( 'error_as_html', <<'EOF',
% my $x = 
EOF
              );

    _write_comp( 'interp_class', <<'EOF',
Interp class: <% ref $m->interp %>
EOF
              );

    _write_comp( 'old_html_escape', <<'EOF',
<% '<>' | old_h %>
EOF
              );

    _write_comp( 'old_html_escape2', <<'EOF',
<% '<>' | old_h2 %>
EOF
              );

    _write_comp( 'uc_escape', <<'EOF',
<% 'upper case' | uc %>
EOF
              );

    _write_comp( 'data_cache_defaults', <<'EOF',
is memory: <% $m->cache->isa('Cache::MemoryCache') ? 1 : 0 %>
namespace: <% $m->cache->get_namespace %>
EOF
              );

    _write_comp( 'test_code_param', <<'EOF',
preprocess changes lc fooquux to FOOQUUX
EOF
              );

    _write_comp( 'explicitly_send_header', <<'EOF',
Sending headers in this comp.
<%perl>
$r->send_http_header() if $r->can('send_http_header');

EOF
              );

    _write_comp( 'cgi_foo_param', <<'EOF',
CGI foo param is <% $r->query->param('foo') %>
EOF
              );

    _write_comp( 'abort_with_ok', <<'EOF',
All is well
% $m->abort(200);
Will not be seen
EOF
              );

    _write_comp( 'abort_with_not_ok', <<'EOF',
All is well
% $m->abort(500);
Will not be seen
EOF
              );

    _write_comp( 'cgi_dh/dhandler', <<'EOF' );
dhandler
dhandler_arg = <% $m->dhandler_arg %>
EOF

    _write_comp( 'cgi_dh/file', <<'EOF' );
file
dhandler_arg = <% $m->dhandler_arg %>
path_info = <% $ENV{PATH_INFO} %>
EOF

    _write_comp( 'cgi_dh/dir/file', '' );
}

sub _write_comp
{
    my $name = shift;
    my $comp = shift;

    my $file = File::Spec->catfile( $TestConfig->{apache_dir}, 'comps', $name );
    my $dir = dirname($file);
    mkpath( $dir, 0, 0755 ) unless -d $dir;

    open my $fh, '>',$file
        or die "Can't write to '$file': $!";

    print $fh $comp;

    close $fh;
}

sub _start_httpd
{
    my $def = shift;
    $def = "-D$def" if $def;

    my $httpd = _apache_bin();
    my $conf_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'conf', 'httpd.conf' );
    my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );

    my $cmd ="$httpd $def -f $conf_file";

    diag( "Executing $cmd" );

    system ($cmd)
        and die "Can't start httpd server as '$cmd': $!";

    diag( "Waiting 10 seconds for httpd to start." );

    my $x = 0;
    until ( -e $pid_file )
    {
        sleep (1);
        $x++;
        if ( $x > 10 )
        {
            die "No $pid_file file has appeared after 10 seconds.  ",
                "There is probably a problem with the configuration file that was generated for these tests.";
        }
    }
}

sub _kill_httpd
{
    my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );

    return unless -e $pid_file;
    my $pid = _get_pid();

    diag( "Killing httpd process ($pid)" );

    my $result = kill 'TERM', $pid;
    if ( ! $result and $! =~ /no such (?:file|proc)/i )
    {
        # Looks like apache wasn't running, so we're done
        unlink $pid_file
            or warn "Couldn't remove $pid_file: $!";
        return;
    }

    die "Can't kill process $pid: $!" unless $result;

    diag( "Waiting up to 10 seconds for httpd to shut down" );

    my $x = 0;
    while ( -e $pid_file )
    {
        sleep (1);

        $x++;
        if ( $x > 1 )
        {
            $result = kill 'TERM', $pid;
            if ( ! $result and $! =~ /no such (?:file|proc)/i )
            {
                # Looks like apache wasn't running, so we're done
                if ( -e $pid_file )
                {
                    unlink $pid_file
                        or warn "Couldn't remove $pid_file: $!";
                }
                return;
            }
        }

        die "$pid_file file still exists after 10 seconds.  Exiting."
            if $x > 10;
    }
}

sub _get_pid
{
    my $pid_file = File::Spec->catfile( $TestConfig->{apache_dir}, 'logs', 'httpd.pid' );

    open my $fh, '<', $pid_file
        or die "Can't open $pid_file: $!";

    my $pid = <$fh>;
    close $fh;

    chomp $pid;

    return $pid;
}

# by wiping out the subdirectories here we can catch permissions
# issues if some of the tests can't write to the data dir.
sub _cleanup_data_dir
{
    return if $ENV{MASON_NO_CLEANUP};

    my $dir = File::Spec->catdir( $TestConfig->{apache_dir}, 'data' );

    opendir my $dh, $dir
        or die "Can't open $dir dir: $!";

    foreach ( grep { -d File::Spec->catdir( $dir, $_ ) && $_ !~ /^\./ } readdir $dh )
    {
        rmtree( File::Spec->catdir( $TestConfig->{apache_dir}, 'data', $_ ) );
    }

    closedir $dh;
}

sub _tests
{
    my $class = shift;
    my %p     = @_;

    my @sets = @{ $p{test_sets} };

    my @tests;
    for my $set (@sets)
    {
        my $meth = q{_} . $set . '_tests';
        push @tests, $class->$meth(%p);

        my $addl_meth =
              $p{with_handler}
            ? q{_} . $set . '_with_handler_tests'
            : q{_} . $set . '_no_handler_tests';

        push @tests, $class->$addl_meth(%p)
            if $class->can($addl_meth);
    }

    return @tests;
}

sub _standard_tests
{
    shift;
    my %p = @_;

    my @tests =
        ( { path => '/comps/basic',
            expect => <<'EOF',
X-Mason-Test: Initial value
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.


Status code: 0
EOF
            extra =>
            [ sub { my $response = shift;
                    unlike( $response->content, qr{HTTP/1\.1},
                            'the response for a good component should not contain headers in the body' ); },
            ],
          },
          { path => '/comps/headers',
            expect => <<'EOF',
X-Mason-Test: New value 3


Blah blah
blah
Status code: 0
EOF
          },
          { path => '/comps/headers?blank=1',
            expect => <<'EOF',
X-Mason-Test: New value 1
Status code: 0
EOF
          },
          { path => '/comps/_underscore',
            expect => <<'EOF',
X-Mason-Test: Initial value
I am underscore.
Status code: 0
EOF
          },
          { path  => '/comps/die',
            regex => qr{error.*Mine heart is pierced}s,
          },
          { path => '/comps/params?qs1=foo&qs2=bar&foo=A&foo=B',
            expect => <<'EOF',
X-Mason-Test: Initial value
foo: A, B, array
qs1: foo
qs2: bar
Status code: 0
EOF
          },
          { path => '/comps/params',
            post => { post1 => 'foo',
                      post2 => 'bar',
                      foo   => [ 'A', 'B' ],
                    },
            expect => <<'EOF',
X-Mason-Test: Initial value
foo: A, B, array
post1: foo
post2: bar
Status code: 0
EOF
          },

          { path => '/comps/params?qs1=foo&qs2=bar&mixed=A',
            post => { post1 => 'a',
                      post2 => 'b',
                      mixed => 'B',
                    },
            expect => <<'EOF',
X-Mason-Test: Initial value
mixed: A, B, array
post1: a
post2: b
qs1: foo
qs2: bar
Status code: 0
EOF
          },
          { path => '/comps/print',
            expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
          },
          { path => '/comps/r_print',
            expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
          },
          { path => '/comps/flush_buffer',
            expect => <<'EOF',
X-Mason-Test: Initial value
foo
bar
Status code: 0
EOF
          },
          { path => '/comps/redirect',
            expect => <<'EOF',
X-Mason-Test: Initial value
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.


Status code: 0
EOF
          },
          { path => '/comps/internal_redirect',
            expect => <<'EOF',
X-Mason-Test: Initial value
The number is 17.
Status code: 0
EOF
          },
          { path => '/comps/subrequest',
            expect => <<'EOF',
X-Mason-Test: Initial value
The number is 17.
Status code: 0
EOF
          },
          { path => '/comps/error_as_html',
            regex => qr{error:.*Error during compilation}s,
            extra =>
            [ sub { my $response = shift;
                    unlike( $response->content, qr{HTTP/1\.1},
                            'the response for a compilation error should not contain headers in the body' ); },
            ],
          },
          { path => '/comps/explicitly_send_header',
            expect => <<'EOF',
X-Mason-Test: Initial value
Sending headers in this comp.
Status code: 0
EOF
          },
        );

    my $expected_class = $p{with_handler} ? 'My::Interp' : 'HTML::Mason::Interp';

    push @tests, { path => '/comps/interp_class',
                   expect => <<"EOF",
X-Mason-Test: Initial value
Interp class: $expected_class
Status code: 0
EOF
                 };

    return @tests;
}

sub _standard_with_handler_tests
{
    shift;
    my %p = @_;

    return ( { path => '/ah=1/comps/headers',
               expect => <<'EOF',
X-Mason-Test: New value 1


Blah blah
blah
Status code: 0
EOF
             },
             { path => '/ah=1/comps/headers?blank=1',
               expect => <<'EOF',
X-Mason-Test: New value 1
Status code: 0
EOF
             },
             { path => '/ah=3/comps/die',
               # error_mode is fatal so we just get a 500
               regex => qr{500 Internal Server Error},
             },
             { path => '/ah=1/comps/print',
               expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
             },
             { path => '/ah=1/comps/r_print',
               expect => <<'EOF',
X-Mason-Test: Initial value
This is first.
This is second.
This is third.
Status code: 0
EOF
             },
             { path => '/ah=1/comps/flush_buffer',
               expect => <<'EOF',
X-Mason-Test: Initial value
foo
bar
Status code: 0
EOF
             },
           );
}

sub _apache_request_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/apache_request',
               expect => <<'EOF',
X-Mason-Test: Initial value
Apache::Request
Status code: 0
EOF
             },
           );
}

sub _apache_request_with_handler_tests
{
    shift;
    my %p = @_;

    return ( { path => '/ah=4/comps/apache_request',
               expect => <<'EOF',
X-Mason-Test: Initial value
Status code: 0
EOF
             },
           );
}

sub _apache_request_no_handler_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/decline_dirs',
               expect => <<'EOF',
X-Mason-Test: Initial value
decline_dirs is 0
Status code: 0
EOF
             },
             { path => '/comps/old_html_escape',
               expect => <<'EOF',
X-Mason-Test: Initial value
<>
Status code: 0
EOF
             },
             { path => '/comps/old_html_escape2',
               expect => <<'EOF',
X-Mason-Test: Initial value
<>
Status code: 0
EOF
             },
             { path => '/comps/uc_escape',
               expect => <<'EOF',
X-Mason-Test: Initial value
UPPER CASE
Status code: 0
EOF
             },
             { path => '/comps/data_cache_defaults',
               expect => <<'EOF',
X-Mason-Test: Initial value
is memory: 1
namespace: foo
Status code: 0
EOF
             },
             { path => '/comps/test_code_param',
               expect => <<"EOF",
X-Mason-Test: Initial value
preprocess changes lc FOOQUUX to FOOQUUX
Status code: 0
EOF
             },
             { path => '/comps/with_dhandler/',
               expect => <<"EOF",
X-Mason-Test: Initial value
with a dhandler
Status code: 0
EOF
             },
           );
}

sub _cgi_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/cgi_object',
               expect => <<'EOF',
X-Mason-Test: Initial value
CGI
Status code: 0
EOF
             },
             { path   => '/comps/head_request?foo=1&bar=1&bar=2',
               method => 'HEAD',
               expect => <<'EOF',
X-Mason-Test: Initial value
X-Mason-HEAD-Test1: bar: is a ref
X-Mason-HEAD-Test2: foo: not a ref
Status code: 0
EOF
             },
           );
}

sub _cgi_no_handler_tests
{
    shift;
    my %p = @_;

    # tests that MasonAllowGlobals works with a list of params
    # (testing a list parameter from httpd.conf)
    return ( { path => '/comps/allow_globals',
               expect => <<'EOF',
X-Mason-Test: Initial value
$foo is 1
@bar is abc
Status code: 0
EOF
             },
           );
}

sub _filter_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/basic',
               expect => <<'EOF',
X-Mason-Test: Initial value
BASIC TEST.
2 + 2 = 4.
URI = /BASIC.
METHOD = GET.


Status code: 0
EOF
             },
           );
}

sub _set_content_type_tests
{
    shift;
    my %p = @_;

    return ( { path  => '/comps/basic',
               extra =>
               [ sub { my $response = shift;
                       is( $response->headers()->header('Content-Type'),
                           'text/html; charset=i-made-this-up',
                           'Content type set by handler is preserved by Mason' ); },
                 sub { my $response = shift;
                       unlike( $response->content(), qr/Content-Type:/i,
                               'response body does not contain a content-type header' ); },
               ],
             },
             { path => '/comps/with_dhandler_no_ct/',
               extra =>
               [ sub { my $response = shift;
                       is( $response->headers()->header('Content-Type'),
                           'text/html; charset=i-made-this-up',
                           'Content type set by handler is preserved by Mason with directory request' ); },
                 sub { my $response = shift;
                       unlike( $response->content(), qr/Content-Type:/i,
                               'response body does not contain a content-type header with directory request' ); },
               ],
             },
           );
}

sub _multi_config_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/multiconf1/foo',
               expect => <<'EOF',
X-Mason-Test: Initial value
I am foo in multiconf1
comp root is multiconf1
Status code: 0
EOF
             },
             { path => '/comps/multiconf1/autohandler_test',
               expect => <<'EOF',
X-Mason-Test: Initial value
autohandler is misnamed
Status code: 0
EOF
             },
             { path => '/comps/multiconf2/foo',
               expect => <<'EOF',
X-Mason-Test: Initial value
I am foo in multiconf2
comp root is multiconf2
Status code: 0
EOF
             },
             { path => '/comps/multiconf2/dhandler_test',
               regex => qr{404 not found}i,
             },
             { path => '/perl-status',
               regex => qr{HTML::Mason status},
             },
           );
}

sub _cgi_handler_tests
{
    shift;
    my %p = @_;

    return ( { path => '/comps/basic',
               unfiltered_response => 1,
               expect => <<'EOF',
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.
EOF
             },
             { path => '/comps/print',
               unfiltered_response => 1,
               expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
             },
             { path => '/comps/print/autoflush',
               unfiltered_response => 1,
               expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
             },
             { path => '/comps/print/handle_comp',
               unfiltered_response => 1,
               expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
             },
             { path => '/comps/print/handle_cgi_object',
               unfiltered_response => 1,
               expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
             },
             { path => '/comps/cgi_foo_param/handle_cgi_object',
               unfiltered_response => 1,
               expect => <<'EOF',
CGI foo param is bar
EOF
             },
             { path => '/comps/redirect',
               unfiltered_response => 1,
               expect => <<'EOF',
Basic test.
2 + 2 = 4.
uri = /basic.
method = GET.
EOF
             },
             { path => '/comps/params?qs1=foo&qs2=bar&mixed=A',
               post => { post1 => 'a',
                         post2 => 'b',
                         mixed => 'B',
                       },
               unfiltered_response => 1,
               expect => <<'EOF',
mixed: A, B, array
post1: a
post2: b
qs1: foo
qs2: bar
EOF
             },
             { path => '/comps/error_as_html',
               regex => qr{error:.*Error during compilation}s,
             },
             { path => '/comps/abort_with_ok',
               unfiltered_response => 1,
               expect => <<'EOF',
All is well
EOF
             },
             # XXX - does this test make any sense?
             { path => '/comps/abort_with_not_ok',
               unfiltered_response => 1,
               expect => <<'EOF',
All is well
EOF
             },
             { path => '/comps/foo/will_decline',
               # Having decline generate an error like this is bad,
               # but there's not much else we can do without rewriting
               # more of CGIHandler, which isn't a good idea for
               # stable, methinks.
               regex => qr{could not find component for initial path}is,
             },
             { path => '/comps/cgi_dh/dir/extra/stuff',
               unfiltered_response => 1,
               expect => <<'EOF',
dhandler
dhandler_arg = dir/extra/stuff
EOF
             },
             { path => '/comps/explicitly_send_header',
               unfiltered_response => 1,
               expect => <<'EOF',
Sending headers in this comp.
EOF
             },
           );

    ## CGIHandler.pm does not do this the same as ApacheHandler.pm
    ## but we do not want to rewrite CGIHandler in stable
    #
    #       my $path = '/comps/cgi_dh/file/extra/stuff';
    #        my $response = Apache::test->fetch($path);
    #        expect => <<'EOF',
    #file
    #dhandler_arg = 
    #path_info = /extra/stuff
    #EOF
}

sub _run_test
{
    my $p    = shift;
    my $test = shift;

    my $path = $test->{path}
        or die "Test with no path!";

    if ( $p->{with_handler} && $path !~ m{^/ah=\d/} )
    {
        $path = '/ah=0' . $path;
    }

    my %fetch_p = ( uri => $path );
    if ( $test->{post} )
    {
        $fetch_p{method} = 'POST';

        my $uri = URI->new();
        $uri->query_form( $test->{post} );

        $fetch_p{content} = $uri->query();
    }
    elsif ( $test->{method} )
    {
        $fetch_p{method} = $test->{method};
    }

    my $response = Apache::test->fetch( \%fetch_p );

    my $output =
          $test->{unfiltered_response}
        ? $response->content()
        : _filter_response( $response, $p, $test );

    _check_output( $output, $test );

    if ( $test->{extra} )
    {
        $_->($response) for @{ $test->{extra} };
    }
}

# We're not interested in headers that are always going to be
# different (like date or server type).
sub _filter_response
{
    my $response = shift;
    my $p        = shift;
    my $test     = shift;

    my $actual;
    {
        $actual = 'X-Mason-Test: ';

        my $val;

        # This is a nasty hack because some tests using a handler()
        # sub are expected to always return this header, and others
        # are not.
        if ( $p->{with_handler} )
        {
            $val = $response->headers->header('X-Mason-Test');
        }
        else
        {
            $val = ( defined $response->headers->header('X-Mason-Test') ?
                     $response->headers->header('X-Mason-Test') :
                     'Initial value' );
        }

        $actual .= defined $val ? $val : '';
    }

    $actual .= "\n";

    # Any headers starting with X-Mason are added, excluding
    # X-Mason-Test, which is handled above
    my @headers;
    $response->headers->scan( sub { return if $_[0] eq 'X-Mason-Test' || $_[0] !~ /^X-Mason/;
                                    push @headers, [ $_[0], $_[1] ] } );

    foreach my $h ( sort { $a->[0] cmp $b->[0] } @headers )
    {
        $actual .= "$h->[0]: ";
        $actual .= defined $h->[1] ? $h->[1] : '';
        $actual .= "\n";
    }

    my $content = $response->content();
    $actual .= $content if defined $content;

    if ( ( $test->{method} && $test->{method} eq 'HEAD' ) || ! $p->{with_handler} )
    {
        my $code = $response->code() == 200 ? 0 : $response->code();
        $actual .= "Status code: $code";
    }

    return $actual;
}

sub _check_output
{
    my $output = shift;
    my $test   = shift;

    my $desc = $test->{path};
    $desc .= ' (post)' if $test->{post};

    if ( $test->{expect} )
    {
        my $expect = $test->{expect};

        for ( $output, $expect )
        {
            s/\s+$//s;
        }

        is( $output, $expect, $desc );
    }
    elsif ( $test->{regex} )
    {
        like( $output, $test->{regex},
              "Regex test for $desc" );
    }
    elsif ( ! $test->{extra} )
    {
        die "No error, expect, or extra key provided for test ($test->{path})";
    }
}


1;
HTML-Mason-1.59/t/lib/LoadTest.pm0000644000175000017500000000007213660015140016210 0ustar  autarchautarchpackage LoadTest;

use Does::Not::Exist;

sub new {}


1;
HTML-Mason-1.59/t/10b-cache-chi.t0000644000175000017500000003731313660015140015746 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;
use HTML::Mason::Tools;

# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
    print "1..0 # Skipped: flock() is not available on this system\n";
    exit;
}

# Skip if CHI not present.
eval "use CHI 0.21";
if ($@)
{
    print "1..0 # Skipped: CHI 0.21+ is not installed\n";
    exit;
}

my %chi_interp_params = (interp_params => { data_cache_api => 'chi' });

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'cache',
                                                      description => 'Test caching' );

#------------------------------------------------------------

    $group->add_support( path => 'support/cache_test',
                         component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.

<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache->get('fandango')) {
    $result = "Hello Dolly.";
    $return = $m->cache->set('fandango', $result) || '';
} else {
    $cached = 1;
}

EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'cache',
                      description => 'basic caching functionality',
                      %chi_interp_params,
                      component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
                      expect => <<'EOF',
Hello Dolly.
This was not cached.


Hello Dolly.
This was cached.


Hello Dolly.
This was cached.


EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'keys',
                      description => q|test multiple keys and $m->cache->get_keys|,
                      %chi_interp_params,
                      component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
    $m->cache->set($key, $key);
}
my @keys = sort $m->cache->get_keys;
$m->print("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
    my $value = $m->cache->get($key) || "undefined";
    $m->print("value for $key is $value\n");
}
$m->cache->remove('foo');
$m->cache->remove('bar');
$m->print("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
    my $value = $m->cache->get($key) || "undefined";
    $m->print("value for $key is $value\n");
}

EOF
                      expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self;

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self',
                      description => 'test $m->cache_self',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self, x => 1 &>
<& support/cache_self, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expires_in',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self( expires_in => '3s' );

EOF
                        );

    $group->add_test( name => 'cache_self_expires_in',
                      description => 'test that $m->cache_self respects expires_in parameter',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_expires_in, x => 1 &>
<& support/cache_self_expires_in, x => 2 &>
% sleep 5;
<& support/cache_self_expires_in, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 99
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expire_in',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self( expire_in => '1s' );

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_expire_in',
                      description => 'test that $m->cache_self respects expire_in parameter',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_expire_in, x => 1 &>
<& support/cache_self_expire_in, x => 2 &>
% sleep 5;
<& support/cache_self_expire_in, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 99
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expire_if',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_expire_if',
                      description => 'test that $m->cache_self respects expire_if parameter',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_expire_if, x => 1 &>
<& support/cache_self_expire_if, x => 2 &>
<& support/cache_self_expire_if, x => 3 &>
<& support/cache_self_expire_if, x => 4 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 3

x is 3
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_with_key',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
$key

<%init>
return if $m->cache_self( key => $key );

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_key',
                      description => 'test $m->cache_self with a key',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_with_key, x => 1, key => 1 &>
<& support/cache_self_with_key, x => 99, key => 99 &>
<& support/cache_self_with_key, x => 1000, key => 1 &>
EOF
                      expect => <<'EOF',
x is 1

x is 99

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_and_die',
                          component => <<'EOF',
<%init>
return if $m->cache_self;
die "argh!";

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_error',
                      description => 'test $m->cache_self with an error to make sure errors are propogated',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_and_die, x => 1, key => 1 &>
EOF
                      expect_error => qr/argh! at .*/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_scomp',
                      description => 'make sure that $m->cache_self cooperates with $m->scomp',
                      %chi_interp_params,
                      component => <<'EOF',
<% $m->scomp( 'support/cache_self', x => 1 ) %>
<% $m->scomp( 'support/cache_self', x => 99 ) %>
EOF
                      expect => <<'EOF',
x is 1

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_filtered',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
$key => 1

<%init>
return if $m->cache_self( key => $key );

<%filter>
$_ = uc $_;
$_ .= ' filtered';

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered',
                      description => 'test $m->cache_self with a filter block',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_filtered, x => 1 &>
<& support/cache_self_filtered, x => 99 &>
EOF
                      expect => <<'EOF',
X IS 1
 filtered
X IS 1
 filtered
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered_scomp',
                      description => 'test $m->cache_self with a filter block callled via $m->scomp',
                      %chi_interp_params,
                      component => <<'EOF',
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 1 ) %>
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 99 ) %>
EOF
                      expect => <<'EOF',
X IS 1
 filtered
X IS 1
 filtered
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_filtered_2',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self;

<%filter>
s/(\d+)/$1+1/ge;

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered_2',
                      description => 'make sure that results are only filtered once',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_filtered_2, x => 1 &>
<& support/cache_self_filtered_2, x => 99 &>
EOF
                      expect => <<'EOF',
x is 2

x is 2
EOF
                    );

#------------------------------------------------------------

# Note: expire_if works differently with CHI than with previous Mason caching.
# CHI does not actually expire the value (which would entail an extra write),
# it just returns false from get(). This was different in earlier verisons of CHI,
# so we don't test for $value3 as we do in the comprable 10-cache.t test.

    $group->add_test( name => 'expire_if',
                      description => 'test expire_if',
                      %chi_interp_params,
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef' ) %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia');
my $value1 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at <= $time-1 });
my $value2 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at >= $time });

EOF
                      expect => <<'EOF',
gardenia, undef
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'busy_lock',
                      description => 'test busy_lock',
                      %chi_interp_params,
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'10 sec');
my $value2 = $cache->get('main');

EOF
                      expect => <<'EOF',
undef, gardenia
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'busy_lock_expiration',
                      description => 'test busy_lock expiration',
                      %chi_interp_params,
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'1 sec');
sleep(1);
my $value2 = $cache->get('main');

EOF
                      expect => <<'EOF',
undef, undef
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_die',
                          component => <<'EOF',
die
<%init>
return if $m->cache_self;
die 'foo';

EOF
                        );

    $group->add_test( name => 'cache_self_death',
                      description => 'test $m->cache_self and death',
                      %chi_interp_params,
                      component => <<'EOF',
<%init>
$m->comp( 'support/cache_self_die' );

EOF
                      expect_error => qr/foo at/,
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_abort2',
                          component => <<'EOF',
going to abort, a = <% $ARGS{a} %>
% $m->abort();
EOF
                        );

    $group->add_support( path => 'support/cache_self_abort',
                         component => <<'EOF',
<%init>
return if $m->cache_self;
$m->comp( 'cache_self_abort2', a=>5 );

EOF
                       );

    $group->add_test( name => 'cache_self_abort',
                      description => 'test $m->cache_self and abort',
                      %chi_interp_params,
                      component => <<'EOF',
<%init>
eval { $m->comp( 'support/cache_self_abort', a=>5 ) };
eval { $m->comp( 'support/cache_self_abort', a=>10 ) };

EOF
                      expect => <<'EOF'
going to abort, a = 5
going to abort, a = 5
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'support/cache_self_with_subexec2',
                         component => <<'EOF',
This is the subrequest, a = <% $ARGS{a} %>
EOF
                       );

    $group->add_support( path => 'support/cache_self_with_subexec',
                         component => <<'EOF',
% return if $m->cache_self;
% $m->subexec('cache_self_with_subexec2', a=>$ARGS{a});
EOF
                       );

    $group->add_test( name => 'cache_self_with_subexec',
                      description => 'test $m->subexec in presence of $m->cache_self',
                      %chi_interp_params,
                      component => <<'EOF',
<& support/cache_self_with_subexec, a=>5 &>
<& support/cache_self_with_subexec, a=>10 &>
EOF
                         expect => <<'EOF',
This is the subrequest, a = 5

This is the subrequest, a = 5
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'declined/dhandler',
                         component => <<'EOF',
decline was called
EOF
                       );

    $group->add_test( name => 'declined/cache_self_decline',
                      description => 'test $m->decline in presence of $m->cache_self',
                      %chi_interp_params,
                      component => <<'EOF',
% return if $m->cache_self;
% $m->decline;
EOF
                      expect => <<'EOF',
decline was called
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'data_cache_defaults',
                      description => 'modifying data_cache_defaults',
                      interp_params => { data_cache_api => 'chi', data_cache_defaults => { driver => 'Memory', global => 1 } },
                      component => <<'EOF',
Using driver '<% $m->cache->short_driver_name %>'

% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
                      expect => <<'EOF',
Using driver 'Memory'

Hello Dolly.
This was not cached.


Hello Dolly.
This was cached.


Hello Dolly.
This was cached.


EOF
                    );

#------------------------------------------------------------

    return $group;
}

HTML-Mason-1.59/t/15-subclass.t0000644000175000017500000001135213660015140015617 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

{
    package HTML::Mason::Request::Test;

    @HTML::Mason::Request::Test::ISA = 'HTML::Mason::Request';

    __PACKAGE__->valid_params( foo_val => { parse => 'string', type => Params::Validate::SCALAR } );

    # shuts up 5.00503 warnings
    1 if $HTML::Mason::ApacheHandler::VERSION;
    1 if $HTML::Mason::CGIHandler::VERSION;

    sub new
    {
        my $class = shift;

        $class->alter_superclass( $HTML::Mason::ApacheHandler::VERSION ?
                                  'HTML::Mason::Request::ApacheHandler' :
                                  $HTML::Mason::CGIHandler::VERSION ?
                                  'HTML::Mason::Request::CGI' :
                                  'HTML::Mason::Request' );

        my $self = $class->SUPER::new(@_);
    }

    sub foo_val { $_[0]->{foo_val} }
}

{
    package HTML::Mason::Request::Test::Subclass;

    @HTML::Mason::Request::Test::Subclass::ISA = 'HTML::Mason::Request::Test';

    __PACKAGE__->valid_params( bar_val => { parse => 'string', type => Params::Validate::SCALAR } );

    sub bar_val { $_[0]->{bar_val} }
}

{
    package HTML::Mason::Lexer::Test;

    @HTML::Mason::Lexer::Test::ISA = 'HTML::Mason::Lexer';

    __PACKAGE__->valid_params( bar_val => { parse => 'string', type => Params::Validate::SCALAR } );

    sub bar_val { $_[0]->{bar_val} }
}

{
    package HTML::Mason::Compiler::ToObject::Test;

    @HTML::Mason::Compiler::ToObject::Test::ISA = 'HTML::Mason::Compiler::ToObject';

    __PACKAGE__->valid_params( baz_val => { parse => 'string', type => Params::Validate::SCALAR } );

    sub baz_val { $_[0]->{baz_val} }

    sub compiled_component
    {
        my $self = shift;

        my $comp = $self->SUPER::compiled_component(@_);

        $$comp =~ s/!!BAZ!!/$self->{baz_val}/g;

        return $comp;
    }
}

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'subclass',
                                                      description => 'Test use of subclasses for various core classes' );

#------------------------------------------------------------

    $group->add_test( name => 'request_subclass',
                      description => 'use a HTML::Mason::Request subclass',
                      interp_params => { request_class => 'HTML::Mason::Request::Test',
                                         foo_val => 77 },
                      component => <<'EOF',
% if ( $m->can('foo_val') ) {
foo_val is <% $m->foo_val %>
% } else {
this request cannot ->foo_val!
% }
EOF
                      expect => <<'EOF',
foo_val is 77
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'request_subclass_of_subclass',
                      description => 'use a HTML::Mason::Request grandchild',
                      interp_params =>
                      { request_class => 'HTML::Mason::Request::Test::Subclass',
                        foo_val => 77,
                        bar_val => 42,
                      },
                      component => <<'EOF',
% if ( $m->can('foo_val') ) {
foo_val is <% $m->foo_val %>
% } else {
this request cannot ->foo_val!
% }
% if ( $m->can('bar_val') ) {
bar_val is <% $m->bar_val %>
% } else {
this request cannot ->bar_val!
% }
EOF
                      expect => <<'EOF',
foo_val is 77
bar_val is 42
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'lexer_subclass',
                      description => 'use a HTML::Mason::Lexer subclass',
                      interp_params => { lexer_class => 'HTML::Mason::Lexer::Test',
                                         bar_val => 76 },
                      component => <<'EOF',
% my $lex = $m->interp->compiler->lexer;
% if ( $lex->can('bar_val') ) {
bar_val is <% $lex->bar_val %>
% } else {
this lexer cannot ->bar_val!
% }
EOF
                      expect => <<'EOF',
bar_val is 76
EOF
                    );

#------------------------------------------------------------

    # We don't use object files, because we want to catch the output
    # of compiled_component() instead of writing it to a file
    $group->add_test( name => 'compiler_subclass',
                      description => 'use a HTML::Mason::Compiler subclass',
                      interp_params => { compiler_class => 'HTML::Mason::Compiler::ToObject::Test',
                                         use_object_files => 0,
                                         baz_val => 75 },
                      component => <<'EOF',
baz is !!BAZ!!
EOF
                      expect => <<'EOF',
baz is 75
EOF
                    );

#------------------------------------------------------------

    return $group;
}

HTML-Mason-1.59/t/23-leak2.t0000644000175000017500000000712313660015140014776 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use File::Temp  qw( tempdir );
use Test::More;

use HTML::Mason::Interp;

BEGIN
{
    unless ( eval { require Test::Memory::Cycle;
                    Test::Memory::Cycle->import(); 1 } )
    {
        plan skip_all => 'These tests require Test::Memory::Cycle to run.';
    }
}

plan tests => 8;

SIMPLE_OBJECTS:
{
    my $interp = HTML::Mason::Interp->new( out_method => sub {} );
    memory_cycle_ok( $interp, 'Interp before making a request' );

    my $comp = $interp->make_component( comp_source => 'Comp' );
    $interp->exec( $comp, foo => 1 );
    memory_cycle_ok( $interp, 'Interp after making a request with in-memory comp' );
}

our $Destroyed = 0;

COMP_ON_DISK:
{
    my $dir = tempdir( CLEANUP => 1 );

    make_comp( $dir, 'comp1', <<'EOF' );
This is component 1.

<&| comp2, object => $object &>
content


<%args>
$object

EOF

    make_comp( $dir, 'comp2', <<'EOF' );
This is component 2.
EOF

    my $interp = HTML::Mason::Interp->new( out_method => sub {},
                                           comp_root  => $dir,
                                         );

    $interp->exec( '/comp1', object => Object->new() );
    memory_cycle_ok( $interp, 'Interp after making a request with on-disk comp' );
    is( $Destroyed, 1, 'object passed into request was destroyed' );

    my $req = $interp->make_request( comp => '/comp1', args => [ object => Object->new() ] );
    memory_cycle_ok( $req, 'Request object' );

    undef $req;
    is( $Destroyed, 2, 'object passed into make_request was destroyed' );
}

# See http://marc.theaimsgroup.com/?l=mason&m=115883578111647&w=2 for
# details.
OBJECTS_CREATED_IN_COMP:
{
    my $dir = tempdir( CLEANUP => 1 );

    make_comp( $dir, 'comp1', <<'EOF' );
<& /comp2, object => Object->new() &>

Destroyed: <% Object->DestroyCount() %>
EOF

    make_comp( $dir, 'comp2', 'Comp 2' );

    my $output = '';
    my $interp = HTML::Mason::Interp->new( out_method => \$output,
                                           comp_root  => $dir,
                                         );

    $Destroyed = 0;
    $interp->exec('/comp1');

    like( $output, qr/Destroyed: 1/,
          'one object was destroyed in comp1' );
}

# See http://marc.theaimsgroup.com/?l=mason&m=111769803701028&w=2 for
# details. It actually has nothing to do with %ARGS, it's seems that
# anything referred to inside nested comp-with-content calls never
# gets destroyed.
TWO_COMP_WITH_CONTENT_CALLS:
{
    my $dir = tempdir( CLEANUP => 1 );

    make_comp( $dir, 'comp1', <<'EOF' );
<%init>
my $object = Object->new();


<&| .sub &>
%# <% $object %> - with this here the object doesn't leak!
<&| .sub &>
<% $object %>



else

<%def .sub>
<% $m->content() %>

EOF

    my $output = '';
    my $interp = HTML::Mason::Interp->new( out_method => sub {},
                                           comp_root  => $dir,
                                         );

    $Destroyed = 0;
    $interp->exec('/comp1');

    # See
    # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-10/msg00189.html
    # for further details.
    local $TODO = 'This seems to be a bug in Perl (< 5.10.0), not Mason.'
        if $] < 5.010000;
    is( $Destroyed, 1, 'object was destroyed - 2 layers of comp-with-content' );
}

sub make_comp
{
    my $dir     = shift;
    my $file    = shift;
    my $content = shift;

    open my $fh, '>', File::Spec->catfile( $dir, $file )
        or die $!;
    print $fh $content
        or die $!;
    close $fh;
}


package Object;

sub new { return bless {}, $_[0] }

sub DESTROY { $Destroyed++ }

sub DestroyCount { $Destroyed }
HTML-Mason-1.59/t/10a-cache-1.0x.t0000644000175000017500000001304613660015140015665 0ustar  autarchautarch#
# Test 1.0 cache API compatibility layer.
#

use strict;
use warnings;

use HTML::Mason::Tests;

# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
    print "1..0\n";
    exit;
}

# Skip if Cache::FileCache not present.
eval { require Cache::FileCache };
if ($@)
{
    print "1..0\n";
    exit;
}

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'cache',
                                                      description => 'Test caching' );


#------------------------------------------------------------

    $group->add_support( path => 'support/cache_test',
                         component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.
Return value: <% $return %>

<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache(key=>'fandango')) {
    $result = "Hello Dolly.";
    $return = $m->cache(action=>'store', key=>'fandango', value=>$result) || '';
} else {
    $cached = 1;
}

EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'cache',
                      description => 'basic caching functionality',
                      interp_params => { data_cache_api => '1.0' },
                      component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
                      expect => <<'EOF',
Hello Dolly.
This was not cached.
Return value: Hello Dolly.


Hello Dolly.
This was cached.
Return value: 


Hello Dolly.
This was cached.
Return value: 


EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => 'support/cache_self_test',
                         component => <<'EOF',
Hello World! var = <% $var %>
<%init>
return if $m->cache_self(key=>'fandango');

<%args>
$var


EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'cache_self',
                      description => 'cache_self functionality',
                      interp_params => { data_cache_api => '1.0' },
                      component => <<'EOF',
% my $var = 1;
% for (my $i=0; $i<3; $i++) {
<% $m->comp('support/cache_self_test',var=>$var) %>
% $var++;
% }
EOF
                      expect => <<'EOF',
Hello World! var = 1


Hello World! var = 1


Hello World! var = 1


EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'keys',
                      description => q|test $m->cache( action => 'keys' )|,
                      interp_params => { data_cache_api => '1.0' },
                      component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
    $m->cache(action=>'store',key=>$key,value=>$key);
}
my @keys = sort $m->cache(action=>'keys');
$m->out("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
    my $value = $m->cache(key=>$key) || "undefined";
    $m->out("value for $key is $value\n");
}
$m->cache(action=>'expire', key=>[qw(foo bar)]);
$m->out("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
    my $value = $m->cache(key=>$key) || "undefined";
    $m->out("value for $key is $value\n");
}

EOF
                      expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'expire_if',
                      description => 'test expire_if',
                      interp_params => { data_cache_api => '1.0' },
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef', $value3 || 'undef', $value4 || 'undef') %>
<%init>
my $time = time;
$m->cache(value=>'gardenia', action=>'store');
my $value1 = $m->cache;
my $value2 = $m->cache(expire_if=>sub { $_[0] <= $time-1 });
my $value3 = $m->cache(expire_if=>sub { $_[0] >= $time });
my $value4 = $m->cache;

EOF
                      expect => <<'EOF',
gardenia, gardenia, undef, undef
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'busy_lock',
                      description => 'test busy_lock',
                      interp_params => { data_cache_api => '1.0' },
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
$m->cache(value=>'gardenia', action=>'store', expire_at=>time);
sleep(1);
my $value1 = $m->cache(busy_lock=>'10 sec');
my $value2 = $m->cache;

EOF
                      expect => <<'EOF',
undef, gardenia
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'busy_lock_expiration',
                      description => 'test busy_lock expiration',
                      interp_params => { data_cache_api => '1.0' },
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
$m->cache(value=>'gardenia', action=>'store', expire_at=>time);
sleep(1);
my $value1 = $m->cache(busy_lock=>'1 sec');
sleep(1);
my $value2 = $m->cache;

EOF
                      expect => <<'EOF',
undef, undef
EOF
                    );

#------------------------------------------------------------

    return $group;
}
HTML-Mason-1.59/t/07-interp.t0000644000175000017500000006520513660015140015310 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);
use IO::File;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'interp',
                                                      description => 'interp object functionality',
                                                      pre_test_cleanup => 0 );

#------------------------------------------------------------

    $group->add_support( path => '/autohandler_test/autohandler',
                         component => <<'EOF',
The recursive autohandler: <% $m->current_comp->path %>

% $m->call_next;
EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'no recursive autohandlers',
                      description => 'tests turning off recursive autohandlers',
                      call_path => '/autohandler_test/subdir/hello',
                      component => <<'EOF',
Hello World!
EOF
                      expect => <<'EOF',
The recursive autohandler: /interp/autohandler_test/autohandler

Hello World!
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'no autohandlers',
                      description => 'tests turning off autohandlers by setting name to ""',
                      call_path => '/autohandler_test/subdir/off',
                      interp_params => { autohandler_name => '' },
                      component => <<'EOF',
Hello World!  Autohandlers are <% $m->interp->use_autohandlers ? 'on' : 'off' %>
EOF
                      expect => <<'EOF',
Hello World!  Autohandlers are off
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => '/autohandler_test/subdir/plainfile',
                         component => <<'EOF',
The local autohandler: <% $m->current_comp->path %>

% $m->call_next;
EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'alternate autohandler name',
                      description => 'tests that providing an alternate name for autohandlers works',
                      call_path => '/autohandler_test/subdir/hello',
                      interp_params => { autohandler_name => 'plainfile' },
                      component => <<'EOF',
Hello World!
EOF
                      expect => <<'EOF',
The local autohandler: /interp/autohandler_test/subdir/plainfile

Hello World!
EOF
                    );

    my $alt_root = File::Spec->catdir( HTML::Mason::Tests->tests_class->base_path, 'alt_root' );
    my @roots = ( [ main => HTML::Mason::Tests->tests_class->comp_root],
                  [ alt => $alt_root ] );


    #HACK!
    HTML::Mason::Tests->tests_class->write_comp( '/alt_root/interp/comp_root_test/private2',
                                                 File::Spec->catdir( $alt_root, 'interp', 'comp_root_test' ),
                                                 'private2',
                                                 <<'EOF' );
private2 in the alternate component root.
<& showcomp &>
EOF

    HTML::Mason::Tests->tests_class->write_comp( '/alt_root/interp/comp_root_test/shared',
                                                 File::Spec->catdir( $alt_root, 'interp', 'comp_root_test' ),
                                                 'shared',
                                                 <<'EOF' );
shared.html in the alternate component root.
<& showcomp &>
EOF


#------------------------------------------------------------

    $group->add_support( path => '/comp_root_test/showcomp',
                         component => <<'EOF',
% my $comp = $m->callers(1);
<& /shared/display_comp_obj, comp=>$comp &>
EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'shared',
                      description => 'test that component in both comp_roots is called in first comp_root',
                      call_path => '/comp_root_test/shared',
                      interp_params => { comp_root => \@roots },
                      component => <<'EOF',
shared in the main component root.
<& showcomp &>
EOF
                      expect => <<'EOF',
shared in the main component root.
Declared args:

I am not a subcomponent.
I am not a method.
I am file-based.
My short name is shared.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/shared [main].

My path is /interp/comp_root_test/shared.
My comp_id is /main/interp/comp_root_test/shared.



EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'private1',
                      description => 'test that component in first comp_root is found',
                      call_path => '/comp_root_test/private1',
                      interp_params => { comp_root => \@roots },
                      component => <<'EOF',
private1 in the main component root.
<& showcomp &>
EOF
                      expect => <<'EOF',
private1 in the main component root.
Declared args:

I am not a subcomponent.
I am not a method.
I am file-based.
My short name is private1.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/private1 [main].

My path is /interp/comp_root_test/private1.
My comp_id is /main/interp/comp_root_test/private1.



EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'private2',
                      description => 'test that component in second comp_root is found',
                      call_path => '/comp_root_test/private2',
                      path => '/foo', # its already written.  HACK!
                      interp_params => { comp_root => \@roots },
                      component => <<'EOF',
foo
EOF
                      expect => <<'EOF',
private2 in the alternate component root.
Declared args:

I am not a subcomponent.
I am not a method.
I am file-based.
My short name is private2.
My directory is /interp/comp_root_test.
I have 0 subcomponent(s).
My title is /interp/comp_root_test/private2 [alt].

My path is /interp/comp_root_test/private2.
My comp_id is /alt/interp/comp_root_test/private2.



EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'support/recurse_test',
                         component => <<'EOF',
Entering <% $count %>

% if ($count < $max) {
<& recurse_test, count=>$count+1, max=>$max &>
% }
Exiting <% $count %>
\
<%args>
$count=>0
$max

EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'max_recurse_1',
                      description => 'Test that recursion 8 levels deep is allowed',
                      component => <<'EOF',
% eval { $m->comp('support/recurse_test', max=>8) };
EOF
                      expect => <<'EOF',
Entering 0

Entering 1

Entering 2

Entering 3

Entering 4

Entering 5

Entering 6

Entering 7

Entering 8

Exiting 8

Exiting 7

Exiting 6

Exiting 5

Exiting 4

Exiting 3

Exiting 2

Exiting 1

Exiting 0

EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'max_recurse_2',
                      description => 'Test that recursion is stopped after 32 levels',
                      interp_params => { autoflush => 1 },
                      component => '<& support/recurse_test, max=>48 &>',
                      expect_error => qr{32 levels deep in component stack \(infinite recursive call\?\)},
                    );


#------------------------------------------------------------

    $group->add_test( name => 'max_recurse_3',
                      description => 'Test interp max_recurse param',
                      interp_params => { max_recurse => 50 },
                      component => <<'EOF',
% eval { $m->comp('support/recurse_test', max=>48) };

<% $@ ? "Error" : "No error" %>
EOF
                      expect => <<'EOF',
Entering 0

Entering 1

Entering 2

Entering 3

Entering 4

Entering 5

Entering 6

Entering 7

Entering 8

Entering 9

Entering 10

Entering 11

Entering 12

Entering 13

Entering 14

Entering 15

Entering 16

Entering 17

Entering 18

Entering 19

Entering 20

Entering 21

Entering 22

Entering 23

Entering 24

Entering 25

Entering 26

Entering 27

Entering 28

Entering 29

Entering 30

Entering 31

Entering 32

Entering 33

Entering 34

Entering 35

Entering 36

Entering 37

Entering 38

Entering 39

Entering 40

Entering 41

Entering 42

Entering 43

Entering 44

Entering 45

Entering 46

Entering 47

Entering 48

Exiting 48

Exiting 47

Exiting 46

Exiting 45

Exiting 44

Exiting 43

Exiting 42

Exiting 41

Exiting 40

Exiting 39

Exiting 38

Exiting 37

Exiting 36

Exiting 35

Exiting 34

Exiting 33

Exiting 32

Exiting 31

Exiting 30

Exiting 29

Exiting 28

Exiting 27

Exiting 26

Exiting 25

Exiting 24

Exiting 23

Exiting 22

Exiting 21

Exiting 20

Exiting 19

Exiting 18

Exiting 17

Exiting 16

Exiting 15

Exiting 14

Exiting 13

Exiting 12

Exiting 11

Exiting 10

Exiting 9

Exiting 8

Exiting 7

Exiting 6

Exiting 5

Exiting 4

Exiting 3

Exiting 2

Exiting 1

Exiting 0

No error
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => '/support/code_cache/show_code_cache',
                         component => <<'EOF',
% $m->interp->purge_code_cache();
% my $code_cache = $m->interp->{code_cache};
% my @plain_comp_names = sort grep { /^plain/ } map { $_->{comp}->name } values(%$code_cache);
Code cache contains: <% join(", ", @plain_comp_names) %>
EOF
                       );


#------------------------------------------------------------

    foreach my $i (1..7) {
        $group->add_support( path => "/support/code_cache/plain$i",
                             component => "",
                           );
    }

    $group->add_support( path => "/support/code_cache/call_plain_comps",
                         component => <<'EOF',
<& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &><& plain1 &>
<& plain2 &><& plain2 &><& plain2 &><& plain2 &><& plain2 &>
<& plain3 &><& plain3 &><& plain3 &>
<& plain4 &>
<& plain5 &><& plain5 &>
<& plain6 &><& plain6 &><& plain6 &><& plain6 &>
<& plain7 &><& plain7 &><& plain7 &><& plain7 &><& plain7 &><& plain7 &>
EOF
                       );

#------------------------------------------------------------

    my $create_code_cache_test = sub {
        my ($max_size, $expected) = @_;
        $group->add_test( name => "code_cache_$max_size",
                          interp_params => { code_cache_max_size => $max_size },
                          description => "code cache: max_size = $max_size",
                          component => <<'EOF',
<%init>
$m->scomp('support/code_cache/call_plain_comps');
$m->scomp('support/code_cache/call_plain_comps');
$m->comp('support/code_cache/show_code_cache');

EOF
                          expect => <<"EOF",
Code cache contains: $expected
EOF
                          );
    };

    $create_code_cache_test->('unlimited', 'plain1, plain2, plain3, plain4, plain5, plain6, plain7');
    $create_code_cache_test->(0, '');
    $create_code_cache_test->(4, 'plain1, plain2, plain7');
    $create_code_cache_test->(8, 'plain1, plain2, plain3, plain5, plain6, plain7');

#------------------------------------------------------------

    $group->add_test( name => 'dhandler_name',
                      description => 'Test that providing an alternate name for dhandlers works',
                      path => 'dhandler_test/plainfile',
                      call_path => 'dhandler_test/foo/blag',
                      interp_params => { dhandler_name => 'plainfile' },
                      component => <<'EOF',
dhandler arg = <% $m->dhandler_arg %>
EOF
                      expect => <<'EOF',
dhandler arg = foo/blag
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'dhandler_name2',
                      description => 'Shut off dhandlers',
                      path => 'dhandler_test/plainfile',
                      call_path => 'dhandler_test/foo/blag',
                      interp_params => { dhandler_name => '' },
                      component => 'foo',
                      expect_error => qr{could not find component},
                    );

#------------------------------------------------------------

    $group->add_test( name => 'no dhandlers',
                      description => 'tests turning off dhandlers by setting name to ""',
                      call_path => 'dhandler_test/exists',
                      interp_params => { dhandler_name => '' },
                      component => <<'EOF',
Hello World!  dhandlers are <% $m->use_dhandlers ? 'on' : 'off' %>
EOF
                      expect => <<'EOF',
Hello World!  dhandlers are off
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'dhandler_name0',
                      description => 'dhandler_name => 0 should not shut off dhandlers',
                      path => 'dhandler_test/0',
                      call_path => 'dhandler_test/foo/blag',
                      interp_params => { dhandler_name => '0' },
                      component => <<'EOF',
dhandler arg = <% $m->dhandler_arg %>
comp = <% $m->current_comp->name %>
EOF
                      expect => <<'EOF',
dhandler arg = foo/blag
comp = 0
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => 'mode_test',
                         component => <<'EOF',
First of all I'd
% $m->clear_buffer;
No what I really wanted to say was
% $m->clear_buffer;
Oh never mind.
EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'no_autoflush_mode',
                      description => 'Test that no autoflush (batch) mode setting works',
                      component => <<'EOF',
<& mode_test &>
EOF
                      expect => <<'EOF',
Oh never mind.
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'autoflush_mode',
                      description => 'Test that autoflush setting works',
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
<& mode_test &>
EOF
                      expect => <<'EOF',
First of all I'd
No what I really wanted to say was
Oh never mind.
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => 'preloads_test/show_code_cache',
                         component => <<'EOF',
Code cache contains:
% my %c = %{$m->interp->{code_cache}};
<% join("\n",sort(keys(%c))) %>
EOF
                    );



#------------------------------------------------------------

    $group->add_support( path => 'preloads_test/hello',
                         component => 'hello',
                       );


#------------------------------------------------------------

    $group->add_support( path => 'preloads_test/goodbye',
                         component => 'goodbye',
                       );


#------------------------------------------------------------

    $group->add_support( path => 'preloads_test/howareyou',
                         component => 'howareyou',
                       );


#------------------------------------------------------------

    $group->add_support( path => 'preloads_test/subdir/in_a_subdir',
                         component => 'howareyou',
                       );

#------------------------------------------------------------

    $group->add_test( name => 'preload_1',
                      description => 'Make sure no preloading is done by default',
                      component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
                      expect => <<'EOF',
Code cache contains:
/interp/preload_1
/interp/preloads_test/show_code_cache
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'preload_2',
                      description => 'Preload a single component by filename',
                      interp_params => { preloads => [ '/interp/preloads_test/hello' ] },
                      component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
                      expect => <<'EOF',
Code cache contains:
/interp/preload_2
/interp/preloads_test/hello
/interp/preloads_test/show_code_cache
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'preload_3',
                      description => 'Preload all components (including subdirectory) by glob pattern',
                      interp_params => { preloads => [ '/interp/preloads_test/*', '/interp/preloads_test/*/*' ] },
                      component => <<'EOF',
<& preloads_test/show_code_cache &>
EOF
                      expect => <<'EOF',
Code cache contains:
/interp/preload_3
/interp/preloads_test/goodbye
/interp/preloads_test/hello
/interp/preloads_test/howareyou
/interp/preloads_test/show_code_cache
/interp/preloads_test/subdir/in_a_subdir
EOF
                    );

#------------------------------------------------------------

    my $interp = HTML::Mason::Tests->tests_class->_make_interp
        ( data_dir => $group->data_dir,
          comp_root => $group->comp_root,
          );
    $interp->compiler->allow_globals( qw($global) );
    $interp->set_global( global => 'parsimmon' );


    $group->add_test( name => 'globals',
                      description => 'Test setting a global in interp & compiler objects',
                      interp => $interp,
                      component => <<'EOF',
<% $global %>
EOF
                      expect => <<'EOF',
parsimmon
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => '/comp_path_test/a/b/c/foo',
                         component => <<'EOF',
I am foo!
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'process_comp_path',
                      description => 'Test that component paths cannot be resolved outside the comp root',
                      component => <<'EOF',
<& ../../../../../interp/comp_path_test/a/b/c/../c/foo &>
EOF
                      expect => <<'EOF'
I am foo!

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'process_comp_path2',
                      description => 'Test that component paths containing /../ work as long they stay in the comp root',
                      path => '/comp_path_test/a/b/d/process',
                      call_path => '/comp_path_test/a/b/d/process',
                      component => <<'EOF',
<& ../c/foo &>
EOF
                      expect => <<'EOF'
I am foo!

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'default_warnings',
                      description => 'test that warnings during component compilation cause an exception except for redefined subs',
                      component => <<'EOF',
a global: <% $GLOBAL %>
<%once>
sub foo { 1 }
sub foo { 1 }

EOF
                      expect_error => qr/Global symbol "\$GLOBAL" requires explicit package name/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'ignore_warnings',
                      description => 'test that setting ignore_warnings_exp works',
                      interp_params => { ignore_warnings_expr => qr/useless use of "re" pragma/i },
                      component => <<'EOF',
% use re;
foo
EOF
                      expect => <<'EOF',
foo
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'ignore_all_warnings',
                      description => 'test ignoring all warnings',
                      interp_params =>
                      { ignore_warnings_expr => '.' },
                      component => <<'EOF',
<%once>
sub foo { 1 }
sub foo { 1 }

foo
EOF
                      expect => <<'EOF',
foo
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'make_anonymous_component',
                      description => 'test make_component() without a path',
                      component => <<'EOF',
<%init>
my $ctext = q|
% my $x = 'Hello, ';
<% $x %>|;
my $comp = $m->interp->make_component( comp_source => $ctext );

% $m->comp($comp);
World
EOF
                      expect => <<'EOF',

Hello, World
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'read_write_contained',
                      description => 'test that we can read/write contained object params',
                      component => <<'EOF',
% $m->autoflush(1);
% my $req = $m->make_subrequest(comp=>($m->interp->make_component(comp_source => 'hi')));
% $m->autoflush(0);
autoflush for new request is <% $req->autoflush %>
EOF
                      expect => <<'EOF',
autoflush for new request is 1
EOF
                    );

#------------------------------------------------------------

    if ( load_pkg('Cache::Cache') && load_pkg('Cache::MemoryCache') )
    {
        $group->add_test( name => 'no_data_dir',
                          description => 'test interp without a data directory',
                          interp => HTML::Mason::Tests->tests_class->_make_interp( comp_root => HTML::Mason::Tests->tests_class->comp_root ),
                          component => <<'EOF',
Hello World!
<% ref $m->cache %>
EOF
                          expect => <<'EOF',
Hello World!
HTML::Mason::Cache::MemoryCache
EOF
                          );
    }

#------------------------------------------------------------

    $group->add_support( path => 'no_comp_root_helper',
                         component => <<'EOF',
I am rootless
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'no_comp_root',
                      description => 'test interp without a comp root or data dir',
                      component => <<'EOF',
% my $buffer;
% my $interp = HTML::Mason::Tests->tests_class->_make_interp( out_method => \$buffer );
% $interp->exec( "/mason_tests/$$/comps/interp/no_comp_root_helper" );
<% $buffer %>
EOF
                      expect => <<'EOF',
I am rootless
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'make_component_error',
                      description => 'make sure a proper exception is thrown with make_component syntax errors',
                      component => <<'EOF',
% $m->interp->make_component(comp_source => '<% &>');
EOF
                      # Would be better to do $@->isa(syntax-error) or the like.
                      expect_error => qr/without matching/,
                    );

#------------------------------------------------------------

    if ( $] < 5.012 && load_pkg('Switch') )
    {
        $group->add_test( name => 'source_filter',
                          description => 'make sure source filters work',
                          interp_params =>
                          { ignore_warnings_expr =>
                            qr/uninitialized|Subroutine .* redefined/i },
                          component => <<'EOF',
no explosion
<%init>
use Switch;

my $x = 1;

switch ($x) { case 1 { $x = 2 } }

EOF
                          expect => <<'EOF',
no explosion
EOF
                        );
    }

#------------------------------------------------------------

    $group->add_test( name => 'escape_flags',
                      description => 'test setting escape flags via constructor',
                      interp_params =>
                      { escape_flags => { uc => sub { ${$_[0]} = uc ${$_[0]} } } },
                      component => <<'EOF',
<% 'upper case' | uc %>
EOF
                      expect => <<'EOF',
UPPER CASE
EOF
                    );


#------------------------------------------------------------

    # Note that setting out_method on the interp affects _future_
    # request objects, not the current one.  This is just a test to
    # make sure we can set it at all.
    $group->add_test( name => 'set_out_method',
                      description => 'test setting out_method on the interp object',
                      component => <<'EOF',
foo
% $m->interp->out_method( sub {} );
bar
baz
EOF
                      expect => <<'EOF',
foo
bar
baz
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => '/support/corrupt_object_file',
                         component => "I was loaded\n",
                        );

    $group->add_test( name => 'corrupt_object_file',
                      description => 'test that Mason can recover from a corrupt or empty object file',
                      component => <<'EOF',
<%init>
my $path = 'support/corrupt_object_file';    
my $comp = $m->fetch_comp('support/corrupt_object_file');
$m->comp($comp);
my $object_file = $comp->object_file;
die "object file does not exist" unless -f $object_file;
die "object file is not writable" unless -w $object_file;

my $corrupt_object_file_and_reload = sub {
    my ($content) = @_;
    my $original_object_file_size = (stat($object_file))[7];

    my $fh = new IO::File ">$object_file"
        or die "cannot write $object_file: $!";
    $fh->print($content);
    $fh->close();
    die "object file is not the right size after corruption"
        unless (stat($object_file))[7] == length($content);

    $m->interp->flush_code_cache();
    $m->comp($path);
    die "object file is the same size after reloading"
        if (stat($object_file))[7] == length($content);
};

$corrupt_object_file_and_reload->("");
$corrupt_object_file_and_reload->(0);
$corrupt_object_file_and_reload->("return 5");
$corrupt_object_file_and_reload->("slkd%^^&*(@@");
$corrupt_object_file_and_reload->("die 'bleah';");

EOF
                      expect => <<'EOF',
I was loaded
I was loaded
I was loaded
I was loaded
I was loaded
I was loaded
EOF
                    );

    return $group;
}
HTML-Mason-1.59/t/05-request.t0000644000175000017500000006100613660015140015470 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'request',
                                                      description => 'request object functionality' );


#------------------------------------------------------------

    $group->add_support( path => '/support/abort_test',
                         component => <<'EOF',
<%args>
$val => 50

Some more text

% $m->abort($val);

But this will never be seen
EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => '/sections/perl',
                         component => <<'EOF',
foo
EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => '/support/various_test',
                         component => <<'EOF',
Caller is <% $m->caller->title %> or <% $m->callers(1)->title %> or <% $m->callers(-2)->title %>.
The top level component is <% $m->callers(-1)->title %> or <% $m->request_comp->title %>.
The full component stack is <% join(",",map($_->title,$m->callers)) %>.
My argument list is (<% join(",",$m->caller_args(0)) %>).
The top argument list is (<% join(",",$m->request_args()) %>) or (<% join(",",$m->caller_args(-1)) %>).

% foreach my $path (qw(various_test /request/sections/perl foobar /shared)) {
%   my $full_path = HTML::Mason::Tools::absolute_comp_path($path, $m->current_comp->dir_path);
Trying to fetch <% $path %> (full path <% $full_path %>):
%   if ($m->comp_exists($path)) {
%     if (my $comp = $m->fetch_comp($path)) {
<% $path %> exists with title <% $comp->title %>.
%     } else {
<% $path %> exists but could not fetch object!
%     }
%   } else {
<% $path %> does not exist.
%   }
% }

% $m->print("Output via the out function.");

/request/file outputs <% int(length($m->scomp("/request/file"))/10) %>0+ characters.
EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => 'various_helper',
                         component => <<'EOF',
<& support/various_test, %ARGS &>
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'abort',
                      description => 'test $m->abort method (autoflush on)',
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
Some text

% eval {$m->comp('support/abort_test')};
% if (my $err = $@) {
%   if ($m->aborted) {
Component aborted with value <% $err->aborted_value %>
%   } else {
Got error
%   }
% }
EOF
                      expect => <<'EOF',
Some text

Some more text

Component aborted with value 50
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'abort_0',
                      description => 'test $m->abort method with value of 0',

                      component => <<'EOF',
Some text

% eval {$m->comp('support/abort_test', val => 0)};
% if (my $err = $@) {
%   if ($m->aborted($err)) {
Component aborted with value <% $err->aborted_value %>
%   } else {
Got error
%   }
% }
EOF
                      expect => <<'EOF',
Some text

Some more text

Component aborted with value 0
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'abort',
                      description => 'test $m->abort method (autoflush off)',
                      component => <<'EOF',
Some text

% eval {$m->comp('support/abort_test')};
% if (my $err = $@) {
%   if ($m->aborted) {
Component aborted with value <% $err->aborted_value %>
%   } else {
Got error
%   }
% }
EOF
                      expect => <<'EOF',
Some text

Some more text

Component aborted with value 50
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'file',
                      description => 'tests $m->file method',
                      component => <<'EOF',
Now I will print myself:

% my $output = $m->file("file");
% $output =~ s/\cM//g;
<% $output %>
EOF
                      expect => <<'EOF',
Now I will print myself:

Now I will print myself:

% my $output = $m->file("file");
% $output =~ s/\cM//g;
<% $output %>
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'file_in_subcomp',
                      description => 'tests $m->file method in subcomponent',
                      component => <<'EOF',
Here I am:

<& .sub &>
<%def .sub>
% my $f = $m->file('file_in_subcomp'); $f =~ s/\r\n?/\n/g;
<% $f %>

EOF
                      expect => <<'EOF',
Here I am:


Here I am:

<& .sub &>
<%def .sub>
% my $f = $m->file('file_in_subcomp'); $f =~ s/\r\n?/\n/g;
<% $f %>

EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'list_out',
                      description => 'tests that $m->print can handle a list of arguments',
                      component => <<'EOF',
Sending list of arguments:

<% 'blah','boom','bah' %>

<%perl>
 $m->print(3,4,5);
 my @lst = (7,8,9);
 $m->print(@lst);

EOF
                      expect => <<'EOF',
Sending list of arguments:

blahboombah

345789
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'req_obj',
                      description => 'tests various operations such as comp calls, $m->current_comp',
                      component => <<'EOF',
<%def .subcomp>
% if ($count < 5) {
<& $m->current_comp, count=>$count+1 &>
% } else {
<& /shared/display_req_obj &>
% }
<%args>
$count



<% '-' x 10 %>

One level request:
<& /shared/display_req_obj &>

<% '-' x 10 %>

Many level request:
<& .subcomp, count=>0 &>

<% '-' x 10 %>
EOF
                      expect => <<'EOF',

----------

One level request:
My depth is 2.

I am not a subrequest.

The top-level component is /request/req_obj.

My stack looks like:
-----
/shared/display_req_obj
/request/req_obj
-----



----------

Many level request:






My depth is 8.

I am not a subrequest.

The top-level component is /request/req_obj.

My stack looks like:
-----
/shared/display_req_obj
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj:.subcomp
/request/req_obj
-----









----------
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'various',
                      call_args => {junk=>5},
                      description => 'tests caller, callers, fetch_comp, process_comp_path, comp_exists and scomp',
                      component => <<'EOF',
<& various_helper, junk=>$ARGS{junk}+1 &>
EOF
                      expect => <<'EOF',
Caller is /request/various_helper or /request/various_helper or /request/various_helper.
The top level component is /request/various or /request/various.
The full component stack is /request/support/various_test,/request/various_helper,/request/various.
My argument list is (junk,6).
The top argument list is (junk,5) or (junk,5).

Trying to fetch various_test (full path /request/support/various_test):
various_test exists with title /request/support/various_test.
Trying to fetch /request/sections/perl (full path /request/sections/perl):
/request/sections/perl exists with title /request/sections/perl.
Trying to fetch foobar (full path /request/support/foobar):
foobar does not exist.
Trying to fetch /shared (full path /shared):
/shared does not exist.

Output via the out function.
/request/file outputs 120+ characters.
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => '/autohandler_test2/autohandler',
                         component => <<'EOF',
This is the first autohandler
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
<& $m->fetch_next, level => 1 &>\
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/autohandler_test2/dir1/autohandler',
                         component => <<'EOF',
This is the second autohandler
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
% foreach (@_) {
<% $_ %>
% }
<& $m->fetch_next, level => 2 &>\
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'fetch_next',
                      path => '/autohandler_test2/dir1/fetch_next',
                      call_path => '/autohandler_test2/dir1/fetch_next',
                      description => 'Test $m->fetch_next and $m->fetch_next_all',
                      component => <<'EOF',
This is the main component (called by level <% $ARGS{level} %>)
Remaining chain: <% join(',',map($_->title,$m->fetch_next_all)) %>
% foreach (@_) {
<% $_ %>
% }
EOF
                      expect => <<'EOF',
This is the first autohandler
Remaining chain: /request/autohandler_test2/dir1/autohandler,/request/autohandler_test2/dir1/fetch_next
This is the second autohandler
Remaining chain: /request/autohandler_test2/dir1/fetch_next
level
1
This is the main component (called by level 2)
Remaining chain: 
level
2
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'print',
                      description => 'Test print function from a component',
                      component => <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
                      expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'printf',
                      description => 'Test printf function from a component',
                      component => <<'EOF',
This is first.
% printf '%s', "This is second.\n";
This is third.
EOF
                      expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'autoflush_print',
                      description => 'Test print function from a component with autoflush on',
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
This is first.
% print "This is second.\n";
This is third.
EOF
                      expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'autoflush_printf',
                      description => 'Test printf function from a component with autoflush on',
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
This is first.
% printf '%s', "This is second.\n";
This is third.
EOF
                      expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_print',
                      description => 'Test print function from a component in conjunction with $m->flush_buffer call',
                      component => <<'EOF',
This is first.
% print "This is second.\n";
% $m->flush_buffer;
This is third.
EOF
                      expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_print_autoflush',
                      description => 'Test print function from a component with autoflush on in conjunction with $m->flush_buffer call',
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
This is first.
% print "This is second.\n";
% $m->flush_buffer;
This is third.
EOF
                      expect => <<'EOF',
This is first.
This is second.
This is third.
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_filter',
                      description => 'Test $m->flush_buffer in presence of filter',
                      component => <<'EOF',
one
% $m->flush_buffer;
% $m->clear_buffer;
two
<%filter>
$_ .= $_;

EOF
                      expect => <<'EOF',
one
one
two
two
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'clear_buffer',
                      description => 'Test $m->clear_buffer in a normal component',
                      component => <<'EOF',
one
% $m->clear_buffer;
two
EOF
                      expect => <<'EOF',
two
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'clear_filter',
                      description => 'Test $m->clear_buffer in presence of filter',
                      component => <<'EOF',
one
% $m->clear_buffer;
two
<%filter>
$_ .= $_;

EOF
                      expect => <<'EOF',
two
two
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'autoflush_disabled',
                      description => 'Using autoflush when disabled generates an error',
                      interp_params => { autoflush => 1, enable_autoflush => 0 },
                      component => <<'EOF',
Hi
EOF
                      expect_error => qr/Cannot use autoflush unless enable_autoflush is set/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'instance',
                      description => 'Test HTML::Mason::Request->instance',
                      component => <<'EOF',
<% $m eq HTML::Mason::Request->instance ? 'yes' : 'no' %>
EOF
                      expect => <<'EOF',
yes
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'abort_and_filter',
                      description => 'Test that an abort in a filtered component still generates _some_ output, and that filter is run only once',
                      component => <<'EOF',
filter

% eval { $m->comp('support/abort_test') };
<%filter>
$_ = uc $_;
$_ =~ s/\s+$//;
$_ .= "\nfilter ran once";

EOF
                      expect => <<'EOF',
FILTER

SOME MORE TEXT
filter ran once
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'abort_and_filter_2',
                      description => 'Test that $m->aborted can be checked in a filter section',
                      component => <<'EOF',
filter

% $m->abort;
<%filter>
unless ( $m->aborted )
{
    $_ = uc $_;
    $_ =~ s/\s+$//;
    $_ .= "\nfilter ran once";
}

EOF
                      expect => <<'EOF',
filter
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'abort_and_store',
                      description => 'Test that an abort in a store\'d component still generates _some_ output',
                      component => <<'EOF',
filter

% my $foo;
% eval { $m->comp( { store => \$foo }, 'support/abort_test') };
<% $foo %>
EOF
                      expect => <<'EOF',
filter

Some more text

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'clear_and_abort',
                      description => 'Test the clear_and_abort() method',
                      component => <<'EOF',
Some output
% $m->flush_buffer;
More output
% $m->clear_and_abort();
EOF
                      expect => <<'EOF',
Some output
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'reexec',
                      description => 'test that $m cannot be reexecuted',
                      component => <<'EOF',
<%init>
$m->exec;

EOF
                      expect_error => qr/Can only call exec\(\) once/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'caller_in_subcomp',
                      description => 'tests $m->caller() in subcomponent',
                      component => <<'EOF',
<%def .foo>
 <% $m->caller->name %>

<& .foo &>
EOF
                      expect => <<'EOF',

 caller_in_subcomp
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'caller_at_top_level',
                      description => 'tests $m->caller() from top component',
                      component => <<'EOF',
caller is <% defined($m->caller) ? "defined" : "undefined" %>
callers(5) is <% defined($m->callers(5)) ? "defined" : "undefined" %>
caller_args(7) is <% defined($m->callers(7)) ? "defined" : "undefined" %>
EOF
                      expect => <<'EOF',
caller is undefined
callers(5) is undefined
caller_args(7) is undefined
EOF
                    );


#------------------------------------------------------------

    $group->add_support( path => '/support/longjump_test3',
                         component => <<'EOF',
Depth is <% $m->depth %>.
The full component stack is <% join(",",map($_->title,$m->callers)) %>.
EOF
                       );

    $group->add_support( path => '/support/subdir/longjump_test2',
                         component => <<'EOF',
This is longjump_test2
% no warnings 'uninitialized'; next;
EOF
                       );

    $group->add_support( path => '/support/longjump_test1',
                         component => <<'EOF',
<& longjump_test3 &>
% foreach my $i (0..2) {
<& subdir/longjump_test2 &>
% }
<& longjump_test3 &>
EOF
                       );

    # It is possible to accidentally call 'next' from a component and
    # jump out to the last loop or block in a previous component.
    # While this cannot be supported behavior (since necessary cleanup
    # and plugin code is skipped), we'd like to avoid a Mason request
    # stack corruption at a minimum.
    #
    $group->add_test( name => 'longjump',
                      description => 'Accidentally calling next to exit a component does not corrupt stack',
                      component => <<'EOF',
<& support/longjump_test1 &>
EOF
                      expect => <<'EOF',
Depth is 3.
The full component stack is /request/support/longjump_test3,/request/support/longjump_test1,/request/longjump.

This is longjump_test2

This is longjump_test2

This is longjump_test2

Depth is 3.
The full component stack is /request/support/longjump_test3,/request/support/longjump_test1,/request/longjump.
EOF
                      # This just shuts the test code up
                      expect_warnings => qr/.*/,
                    );

#------------------------------------------------------------

    $group->add_support( path => '/support/callers_out_of_bounds2',
                         component => <<'EOF',
hi
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/callers_out_of_bounds1',
                         component => <<'EOF',
<& callers_out_of_bounds2 &>
% foreach my $i (-4 .. 4) {
callers(<% $i %>) is <% defined($m->callers($i)) ? $m->callers($i)->title : 'not defined' %>
% }
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'callers_out_of_bounds',
                      description => 'tests $m->callers() for out of bounds indexes',
                      component => <<'EOF',
<& support/callers_out_of_bounds1 &>
EOF
                      expect => <<'EOF',
hi

callers(-4) is not defined
callers(-3) is not defined
callers(-2) is /request/support/callers_out_of_bounds1
callers(-1) is /request/callers_out_of_bounds
callers(0) is /request/support/callers_out_of_bounds1
callers(1) is /request/callers_out_of_bounds
callers(2) is not defined
callers(3) is not defined
callers(4) is not defined
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'call_self',
                      description => 'Test $m->call_self',
                      component => <<'EOF',
called
<%init>
my $out;
if ( $m->call_self( \$out, undef ) )
{
    $m->print($out);
    return;
}

EOF
                      expect => <<'EOF',
called
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'call_self_retval',
                      description => 'Test that we can get return value of component via $m->call_self',
                      component => <<'EOF',
called
<%init>
my @return;
if ( $m->call_self( undef, \@return ) )
{
    $m->print( "0: $return[0]\n1: $return[1]\n" );
    return;
}
return ( 'foo', 'bar' );

EOF
                      expect => <<'EOF',
0: foo
1: bar
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'call_self_output_and_retval',
                      description => 'Test that we can get return value and output of component via $m->call_self',
                      component => <<'EOF',
called
<%init>
my $out;
my @return;
if ( $m->call_self( \$out, \@return ) )
{
    $m->print( "${out}0: $return[0]\n1: $return[1]\n" );
    return;
}

<%cleanup>
return ( 'foo', 'bar' );

EOF
                      expect => <<'EOF',
called
0: foo
1: bar
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'call_self_with_filter',
                      description => 'Test that $m->call_self works in presence of filter',
                      component => <<'EOF',
called
<%filter>
$_ = uc $_;
$_ .= ' filtered';

<%init>
my $out;
if ( $m->call_self( \$out, undef ) )
{
    $m->print($out);
    return;
}

EOF
                      expect => <<'EOF',
CALLED
 filtered
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'subcomp_from_shared',
                      description => 'Test calling a subcomponent inside shared block',
                      component => <<'EOF',
<%shared>
$m->comp('subcomp');

<%def subcomp>
a subcomp

EOF
                      expect_error =>
                      qr/cannot call a method or subcomponent from a <%shared> block/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'method_in_shared',
                      description => 'Test calling a method inside shared block',
                      component => <<'EOF',
<%shared>
$m->comp('SELF:meth');

<%method meth>
a method

EOF
                      expect_error =>
                      qr/cannot call a method or subcomponent from a <%shared> block/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'notes',
                      description => 'Test the notes() method',
                      component => <<'EOF',
% $m->notes('key', 'value');
k: <% $m->notes('key') %>
k2: <% $m->notes->{key} %>
EOF
                      expect =>
                      qr/k: value\s+k2: value/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_and_store',
                      description => q{Test that $m->flush_buffer is ignored in a store'd component},
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
<%def .world>\
World\


% my $world;
% $m->comp( { store => \$world }, '.world');
Hello, <% $world %>!

% $world = $m->scomp('.world');
Hello, <% $world %>!
EOF
                      expect => <<'EOF',

Hello, World!

Hello, World!
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_and_scomp_recursive',
                      description => 'Test that $m->flush_buffer is ignored in a recursive scomp() call',
                      interp_params => { autoflush => 1 },
                      component => <<'EOF',
<%def .orld>\
orld\


<%def .world>\
W<& .orld &>\


% my $world = $m->scomp('.world');
Hello, <% $world %>!
EOF
                      expect => <<'EOF',


Hello, World!
EOF
                    );

#------------------------------------------------------------

    return $group;
}
HTML-Mason-1.59/t/07b-interp-static-source.t0000644000175000017500000001422713660015140020233 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);
use IO::File;

package HTML::Mason::Commands;
sub write_component
{
    my ($comp, $text) = @_;
    my $file = $comp->source_file;
    my $fh = new IO::File ">$file" or die "Cannot write to $file: $!";
    $fh->print($text);
    $fh->close();
}

package main;
my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'interp-static-source',
                                                      description => 'interp static source mode' );

#------------------------------------------------------------

    foreach my $i (1..4) {
        $group->add_support( path => "support/remove_component$i",
                             component => "I will be removed ($i).\n",
                           );
    }

#------------------------------------------------------------

    foreach my $i (1..4) {
        $group->add_support( path => "support/change_component$i",
                             component => "I will be changed ($i).\n",
                           );
    }

#------------------------------------------------------------

    $group->add_test( name => 'change_component_without_static_source',
                      description => 'test that on-the-fly component changes are detected with static_source=0',
                      component => <<'EOF',
<& support/change_component1 &>\
<%perl>
sleep(2);  # Make sure timestamp changes
write_component($m->fetch_comp('support/change_component1'), "I have changed!\n");

<& support/change_component1 &>
EOF
                      expect => <<'EOF',
I will be changed (1).
I have changed!
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'change_component_with_static_source',
                      description => 'test that changing component has no effect with static_source=1',
                      interp_params => { static_source => 1 },
                      component => <<'EOF',
<& support/change_component2 &>\
<%perl>
sleep(1);  # Make sure timestamp changes
write_component($m->fetch_comp('support/change_component2'), "I have changed!\n");
my $comp = $m->interp->load("/interp-static-source/support/change_component2");
$m->comp($comp);

<& support/change_component2 &>
EOF
                      expect => <<'EOF',
I will be changed (2).
I will be changed (2).
I will be changed (2).
EOF
                    );

#------------------------------------------------------------

    my $static_source_touch_file = File::Spec->catfile($group->base_path, '.__static_source_touch');
    $group->add_test( name => 'change_component_with_static_source_touch_file',
                      description => 'test that changing component has no effect until touch file is touched',
                      interp_params => { static_source => 1,
                                         static_source_touch_file => $static_source_touch_file },
                      component => <<'EOF',
<%perl>
my $path = "/interp-static-source/support/change_component3";
$m->comp($path);
sleep(1);  # Make sure timestamp changes
write_component($m->fetch_comp('support/change_component3'), "I have changed!\n");
$m->interp->check_static_source_touch_file;
$m->comp($path);
my $touch_file = $m->interp->static_source_touch_file;
my $fh = new IO::File ">$touch_file"
   or die "cannot write to '$touch_file': $!";
$fh->close();
$m->interp->check_static_source_touch_file;
$m->comp($path);

EOF
                      expect => <<'EOF',
I will be changed (3).
I will be changed (3).
I have changed!
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'remove_component_without_static_source',
                      description => 'test that removing source causes component not found with static_source=0',
                      component => <<'EOF',
<& support/remove_component1 &>
<%perl>
my $file = $m->fetch_comp('support/remove_component1')->source_file;
unlink($file) or die "could not unlink '$file'";

<& support/remove_component1 &>
EOF
                      expect_error => qr/could not find component for path/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'remove_component_with_static_source',
                      description => 'test that removing source has no effect with static_source=1',
                      interp_params => { static_source => 1 },
                      component => <<'EOF',
<%init>
# flush_code_cache actually broke this behavior at one point
$m->interp->flush_code_cache;


<& support/remove_component2 &>
<%perl>
my $file = $m->fetch_comp('support/remove_component2')->source_file;
unlink($file) or die "could not unlink '$file'";
my $comp = $m->interp->load("/interp-static-source/support/remove_component2")
  or die "could not load component";
$m->comp($comp);

<& support/remove_component2 &>
EOF
                      expect => <<'EOF',

I will be removed (2).

I will be removed (2).
I will be removed (2).
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'flush_code_cache_with_static_source',
                      description => 'test that code cache flush & object file removal works with static_source=1',
                      interp_params => { static_source => 1 },
                      component => <<'EOF',
<& support/change_component4 &>
<%perl>
write_component($m->fetch_comp('support/change_component4'), "I have changed!\n");

# Not enough - must delete object file
$m->interp->flush_code_cache;
my $comp = $m->interp->load("/interp-static-source/support/change_component4");
$m->comp($comp);

# This should work
unlink($comp->object_file);
undef $comp;
$m->interp->flush_code_cache;
my $comp2 = $m->interp->load("/interp-static-source/support/change_component4");
$m->comp($comp2);

<& support/change_component4 &>
EOF
                      expect => <<'EOF',
I will be changed (4).

I will be changed (4).
I have changed!
I have changed!
EOF
                    );

    return $group;
}
HTML-Mason-1.59/t/06-compiler.t0000644000175000017500000011004313660015140015607 0ustar  autarchautarchuse strict;
use warnings;

use Config;
use HTML::Mason::Tests;
use HTML::Mason::Tools qw(load_pkg);

my $tests = make_tests();
$tests->run;

{ package HTML::Mason::Commands;
  sub _make_interp {
      $tests->_make_interp(@_);
  }}

sub make_tests {
    my $group = HTML::Mason::Tests->tests_class->new( name => 'compiler',
                                                      description => 'compiler and lexer object functionality' );


#------------------------------------------------------------

    $group->add_test( name => 'allowed_globals',
                      description => 'test that undeclared globals cause an error',
                      interp_params => { use_object_files => 0 }, # force it to parse comp each time
                      component => <<'EOF',
<% $global = 1 %>
EOF
                      expect_error => 'Global symbol .* requires explicit package name',
                    );


#------------------------------------------------------------

    $group->add_test( name => 'allowed_globals2',
                      description => 'test that undeclared globals cause an error',
                      pretest_code => sub { undef *HTML::Mason::Commands::global; undef *HTML::Mason::Commands::global },  # repeated to squash a var used only once warning
                      interp_params => { use_object_files => 0 },
                      component => <<'EOF',
<% $global = 1 %>
EOF
                      expect_error => 'Global symbol .* requires explicit package name',
                    );


#------------------------------------------------------------

    $group->add_test( name => 'allowed_globals3',
                      description => 'test that declared globals are allowed',
                      interp_params => { use_object_files => 0, allow_globals => ['$global'] },
                      component => <<'EOF',
<% $global = 1 %>
EOF
                      expect => <<'EOF',
1
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'default_escape_flags',
                      description => 'test that no escaping is done by default',
                      interp_params => { use_object_files => 0 },
                      component => <<'EOF',
Explicitly HTML-escaped: <% $expr |h %>

Explicitly HTML-escaped redundantly: <% $expr |hh %>

Explicitly URL-escaped: <% $expr |u
%>

No flags: <% $expr %>

No flags again: <% $expr %>

Explicitly not escaped: <% $expr | n%>

<%init>
my $expr = "Hello there.";

EOF
                      expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.

Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.

Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.

No flags: Hello there.

No flags again: Hello there.

Explicitly not escaped: Hello there.

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'default_escape_flags_new',
                      description => 'test new escape flags',
                      interp_params => { use_object_files => 0 },
                      component => <<'EOF',
Explicitly HTML-escaped: <% $expr | h %>

Explicitly HTML-escaped redundantly: <% $expr | h,h %>

Explicitly URL-escaped: <% $expr |u
%>

No flags: <% $expr %>

No flags again: <% $expr %>

Explicitly not escaped: <% $expr | n %>

<%init>
my $expr = "Hello there.";

EOF
                      expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.

Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.

Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.

No flags: Hello there.

No flags again: Hello there.

Explicitly not escaped: Hello there.

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'default_escape_flags_2',
                      description => 'test that turning on default escaping works',
                      interp_params => { use_object_files => 0, default_escape_flags => 'h' },
                      component => <<'EOF',
Explicitly HTML-escaped: <% $expr |h %>

Explicitly HTML-escaped redundantly: <% $expr |hh %>

Explicitly URL-escaped: <% $expr |un
%>

No flags: <% $expr %>

No flags again: <% $expr %>

Explicitly not escaped: <% $expr | n%>

<%init>
my $expr = "Hello there.";

EOF
                      expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.

Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.

Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.

No flags: <b><i>Hello there</i></b>.

No flags again: <b><i>Hello there</i></b>.

Explicitly not escaped: Hello there.

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'default_escape_flags_2_new',
                      description => 'test that turning on default escaping works with new flags',
                      interp_params => { use_object_files => 0,
                                         default_escape_flags => [ 'h' ] },
                      component => <<'EOF',
Explicitly HTML-escaped: <% $expr | h %>

Explicitly HTML-escaped redundantly: <% $expr | h , h %>

Explicitly URL-escaped: <% $expr | u, n
%>

No flags: <% $expr %>

No flags again: <% $expr %>

Explicitly not escaped: <% $expr | n %>

<%init>
my $expr = "Hello there.";

EOF
                      expect => <<'EOF',
Explicitly HTML-escaped: <b><i>Hello there</i></b>.

Explicitly HTML-escaped redundantly: <b><i>Hello there</i></b>.

Explicitly URL-escaped: %3Cb%3E%3Ci%3EHello%20there%3C%2Fi%3E%3C%2Fb%3E.

No flags: <b><i>Hello there</i></b>.

No flags again: <b><i>Hello there</i></b>.

Explicitly not escaped: Hello there.

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'setting_escapes',
                      description => 'test setting escapes',
                      component => <<'EOF',
% $m->interp->set_escape( uc => sub { ${$_[0]} = uc ${$_[0]} } );
This will be in <% 'upper case' | uc %>
EOF
                      expect => <<'EOF',
This will be in UPPER CASE
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'invalid_escape_name',
                      description => 'test setting an escape with an invalid name',
                      component => <<'EOF',
% $m->interp->set_escape( 'u c' => sub { uc $_[0] } );
EOF
                      expect_error => qr/Invalid escape name/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'globals_in_default_package',
                      description => 'tests that components are executed in HTML::Mason::Commands package by default',
                      interp_params => { use_object_files => 0,
                                         allow_globals => ['$packvar'] },
                      component => <<'EOF',
<% $packvar %>
<%init>
$HTML::Mason::Commands::packvar = 'commands';
$HTML::Mason::NewPackage::packvar = 'newpackage';

EOF
                      expect => <<'EOF',
commands
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'globals_in_different_package',
                      description => 'tests in_package compiler parameter',
                      interp_params => { use_object_files => 0,
                                         allow_globals => ['$packvar'],
                                         in_package => 'HTML::Mason::NewPackage' },
                      component => <<'EOF',
<% $packvar %>
<%init>
$HTML::Mason::Commands::packvar = 'commands';
$HTML::Mason::NewPackage::packvar = 'newpackage';

EOF
                      expect => <<'EOF',
newpackage
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'preamble',
                      description => 'tests preamble compiler parameter',
                      interp_params => { preamble => 'my $msg = "This is the preamble.\n"; $m->print($msg);
'},
                      component => <<'EOF',
This is the body.
EOF
                      expect => <<'EOF',
This is the preamble.
This is the body.
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'postamble',
                      description => 'tests postamble compiler parameter',
                      interp_params => { postamble => 'my $msg = "This is the postamble.\n"; $m->print($msg);
'},
                      component => <<'EOF',
This is the body.
EOF
                      expect => <<'EOF',
This is the body.
This is the postamble.
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'preprocess',
                      description => 'test preprocess compiler parameter',
                      interp_params => { preprocess => \&brackets_to_lt_gt },
                      component => <<'EOF',
[% 'foo' %]
bar
EOF
                      expect => <<'EOF',
foo
bar
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'postprocess_text1',
                      description => 'test postprocess compiler parameter (alpha blocks)',
                      interp_params => { postprocess_text => \&uc_alpha },
                      component => <<'EOF',
<% 'foo' %>
bar
EOF
                      expect => <<'EOF',
foo
BAR
EOF
                    );


#------------------------------------------------------------
    $group->add_test( name => 'postprocess_text2',
                      description => 'test postprocess compiler parameter (alpha blocks)',
                      interp_params => { postprocess_text => \&uc_alpha },
                      component => <<'EOF',
<% 'foo' %>
<%text>bar
EOF
                      expect => <<'EOF',
foo
BAR
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'postprocess_perl1',
                      description => 'test postprocess compiler parameter (perl blocks)',
                      interp_params => { postprocess_perl => \&make_foo_foofoo },
                      component => <<'EOF',
<% 'foo' %>
bar
EOF
                      expect => <<'EOF',
foofoo
bar
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'postprocess_perl2',
                      description => 'test postprocess compiler parameter (perl blocks)',
                      interp_params => { postprocess_perl => \&make_foo_foofoo },
                      component => <<'EOF',
<% 'foo' %>
% $m->print("Make mine foo!\n");
bar
<% "stuff-$var-stuff" %>
<%init>
 my $var = 'foo';

EOF
                      expect => <<'EOF',
foofoo
Make mine foofoo!
bar
stuff-foofoo-stuff
EOF
                    );




#------------------------------------------------------------
    $group->add_test( name => 'bad_var_name',
                      description => 'test that invalid Perl variable names are caught',
                      component => <<'EOF',
<%args>
$foo
$8teen
%bar

Never get here
EOF
                      expect_error => qr{Invalid <%args> section line},
                    );

#------------------------------------------------------------
    $group->add_test( name => 'whitespace_near_args',
                      description => 'test that whitespace is allowed before ',
                      call_args => [qw(foo foo)],
                      component => <<'EOF',
  <%args>
   $foo
  
EOF
                      expect => "  \n",
                    );

#------------------------------------------------------------

    $group->add_test( name => 'line_nums',
                      description => 'make sure that errors are reported with the correct line numbers',
                      component => <<'EOF',
<% $x %> <% $y %>
<% $z %>
% die "Dead";
<%init>
my ($x, $y, $z) = qw(a b c);

EOF
                      expect_error => qr/Dead at .* line 3/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'line_nums2',
                      description => 'make sure that errors are reported with the correct line numbers',
                      component => <<'EOF',
<% $x %> <% $y %>
<% $z %>\
% die "Dead";
<%init>
my ($x, $y, $z) = qw(a b c);

EOF
                      expect_error => qr/Dead at .* line 3/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'line_nums3',
                      description => 'make sure that errors are reported with the correct line numbers',
                      component => <<'EOF',
<% $x %> <% $y %>
<% $z %>
<%init>
my ($x, $y, $z) = qw(a b c);
die "Dead";

EOF
                      expect_error => qr/Dead at .* line 5/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'line_nums4',
                      description => 'make sure that errors are reported with the correct line numbers in <%once> blocks',
                      component => <<'EOF',
1
2
3
<%ONCE>
$x = 1;

EOF
                      expect_error => qr/Global symbol .* at .* line 5/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'line_nums_with_escaped_newlines',
                      description => 'Check line numbers of error messages after escaped newlines',
                      component => <<'EOF',
1
2
3\
4\
5
% die "Dead";
EOF
                      expect_error => qr/Dead at .* line 6/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'line_nums_off_by_one',
                      description => 'make sure that line number reporting is not off by one',
                      component => <<'EOF',
1
2
3
<%once>#4
my $x = 1; #5
6
7
<%args>#8
$foo#9
@bar#10
11
<%init>#12
#13
#14
#15
$y; #16

EOF
                      expect_error => qr/Global symbol .* at .* line 16/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'line_nums_off_2',
                      description => 'make sure that line number reporting is not off (another buggy case)',
                      component => <<'EOF',
<%flags>
    inherit => undef

% die "really #4";
EOF
                      expect_error => qr/really #4 .* line 4/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'attr_block_zero',
                      description => 'test proper handling of zero in <%attr> block values',
                      component => <<'EOF',
<%attr>
 key => 0

<% $m->current_comp->attr_exists('key') ? 'exists' : 'missing' %>
EOF
                      expect => "exists\n",
                    );

#------------------------------------------------------------

    $group->add_test( name => 'attr_flag_block_comment',
                      description => 'test comment lines in attr and flags blocks',
                      component => <<'EOF',
<%attr>
# this is a comment
  # another comment
 key => 'foo'
# one last comment

<%flags>
# this is a comment
  # another comment
inherit => undef
# one last comment

compiled
EOF
                      expect => 'compiled',
                    );

#------------------------------------------------------------

    $group->add_test( name => 'attr_flag_block_empty',
                      description => 'test empty attr and flags blocks',
                      component => <<'EOF',
<%attr>
<%flags>

compiled
EOF
                      expect => 'compiled',
                    );

#------------------------------------------------------------

    my $error =
        $] >= 5.006 ? qr/Unterminated <>/ : qr/Bareword "subcomp" not allowed/;

    $group->add_test( name => 'subcomp_parse_error',
                      description => 'A misnamed block at the beginning of a component was throwing the lexer into an infinite loop.  Now it should be compiled into a component with a syntax error.',
                      component => <<'EOF',
<%subcomp .foo>
 <% 5 %>

EOF
                      expect_error => $error,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'error_in_args',
                      description => 'Test line number reporting for <%args> block',
                      component => <<'EOF',
lalalal
<%args>
$foo => this should break

EOF
                      expect_error => qr/Bareword "break".*error_in_args line 3/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'block_end_without_nl',
                      description => 'Test that a block can end without a newline before it',
                      component => <<'EOF',
no newlines<%args>$foo => 1<%attr>foo => 1<%flags>inherit => undef
EOF
                      expect => <<'EOF',
no newlines
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'more_block_variations',
                      description => 'Test various mixture of whitespace with blocks',
                      component => <<'EOF',
various
<%args>
 $foo => 1
<%attr>
  foo => 1
<%args>$bar => 1

<%attr>bar => 1

<%args>
 $quux => 1
<%attr>
  quux => 1
<%args>  $baz => 1

<%attr>  baz => 1

EOF
                      expect => <<'EOF',
various
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'percent_at_end',
                      description => 'Make sure that percent signs are only considered perl lines when at the beginning of the line',
                      component => <<'EOF',
<% $x %>% $x = 5;
<% $x %>
<%init>
my $x = 10;

EOF
                      expect => <<'EOF',
10% $x = 5;
10
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'nameless_method',
                      description => 'Check for appropriate error message when there is a method or def block without a name',
                      component => <<'EOF',
<%method>
foo

EOF
                      expect_error => qr/method block without a name at .*/
                    );

#------------------------------------------------------------

    $group->add_test( name => 'invalid_method_name',
                      description => 'Check for appropriate error message when there is a method with an invalid name',
                      component => <<'EOF',
<%method   >
foo

EOF
                      expect_error => qr/Invalid method name:.*/
                    );

#------------------------------------------------------------

        $group->add_test( name => 'uc_method',
                          description => 'make sure that <%METHOD ...> is allowed',
                          component => <<'EOF',
calling SELF:foo - <& SELF:foo &>
<%METHOD foo>bar
EOF
                          expect => <<'EOF',
calling SELF:foo - bar
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'no_strict',
                          description => 'test turning off strict in a component',
                          interp_params => { use_strict => 0 },
                          component => <<'EOF',
no errors
<%init>
$x = 1;

EOF
                          expect => <<'EOF',
no errors
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'no_strict_no_object_files',
                          description =>
                          'test turning off strict in a component when not using object files',
                          interp_params => { use_strict => 0, use_object_files => 0 },
                          component => <<'EOF',
no errors
<%init>
$x = 1;

EOF
                          expect => <<'EOF',
no errors
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'weird_case',
                          description => 'test weird parsing case',
                          component => <<'EOF',
<%init()%>
<%args()%>
<%once>
sub init { 'init' }
sub args { 'args' }

EOF
                          expect => <<'EOF',
init
args
EOF
                        );


#------------------------------------------------------------

        $group->add_test( name => 'subst_tag_comments',
                          description => 'Make sure comments parse correctly in substitution tags',
                          component => <<'EOF',
<%# Here's a comment
  5 + 5 %>
EOF
                          expect => 10,
                        );

#------------------------------------------------------------

        $group->add_test( name => 'shared_to_init',
                          description => 'Make sure <%init> can see lexicals in <%shared>',
                          component => <<'EOF',
<%init>
 $m->out( $x );

<%shared>
 my $x = 7;

EOF
                          expect => 7,
                        );

#------------------------------------------------------------

        $group->add_test( name => 'shared_to_init_global',
                          description => 'Make sure <%init> can see global variables in <%shared>',
                          interp_params => { allow_globals => ['$x'] },
                          component => <<'EOF',
<%init>
 $m->out( $x );

<%shared>
 $x = 8;

EOF
                          expect => 8,
                        );

#------------------------------------------------------------

        $group->add_test( name => 'double_pipe_or',
                          description => 'Make sure || works in a substitution',
                          component => <<'EOF',
Should be 1: <% 1 || 2 %>
EOF
                          expect => <<'EOF',
Should be 1: 1
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'double_pipe_or_2',
                          description => 'Make sure || works in a substitution (again)',
                          component => <<'EOF',
<%once>
sub foo { 'foo!' }
sub bar { 'bar!' }

<% foo || bar %>
EOF
                          expect => <<'EOF',
foo!
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'flags_regex',
                          description => 'Make sure flags must start with alpha or underscore',
                          component => <<'EOF',
<% 1 | 1 %>
EOF
                          expect => <<'EOF',
1
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'qw_in_perl_lines',
                          description => 'Make sure that Mason that a qw() list stretching across multiple perl-lines works',
                          component => <<'EOF',
% foreach my $foo ( qw( a
%                       b ) ) {
<% $foo %>
% }
EOF
                          expect => <<'EOF',
a
b
EOF
                        );

#------------------------------------------------------------

    $group->add_support( path => '/has_subcomp',
                         component => <<'EOF',
<& .a &>
<%def .a>
A

EOF
                       );

    $group->add_support( path => '/no_subcomp',
                         component => <<'EOF',
<%shared>
my $y = 1;

EOF
                       );

    $group->add_test( name => 'subcomp_leak',
                      description => 'Make sure subcomps from one component do not show up in other components',
                      component => <<'EOF',
<%init>
$m->scomp('has_subcomp');
$m->scomp('no_subcomp');

local *FH;
my $obj = $m->fetch_comp('no_subcomp')->object_file;
open FH, "< $obj"
    or die "Cannot read $obj";
my $text = join '', ;
close FH;

% if ( $text =~ /subcomponent_\.a/ ) {
Subcomponent leakage!
% } else {
No leak
% }
EOF
                      expect => <<'EOF',
No leak
EOF
                    );

#------------------------------------------------------------

        $group->add_test( name => 'use_source_line_numbers_1',
                          description => 'test presence of line directives when use_source_line_numbers is 1 (default)',
                          component => <<'EOF',
This is line <% __LINE__ %>.
<%doc>


This is line <% __LINE__ %>.
EOF
                          expect => <<'EOF',
This is line 1.
This is line 5.
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'use_source_line_numbers_0',
                          description => 'test absence of line directives when use_source_line_numbers is 1',
                          interp_params => { use_source_line_numbers => 0 },
                          component => <<'EOF',
This line number is <% __LINE__ < 3 ? 'less than 3' : 'not less than 3' %>.
EOF
                          expect => <<'EOF',
This line number is not less than 3.
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'define_args_hash_never',
                          description => 'test setting define_args_hash to never',
                          interp_params => { define_args_hash => 'never' },
                          component => <<'EOF',
% $ARGS{foo} = 1;
no error?
EOF

                          expect_error => qr/Global symbol.*%ARGS/
                        );

#------------------------------------------------------------

        $group->add_test( name => 'define_args_hash_always',
                          description => 'test setting define_args_hash to always',
                          interp_params => { define_args_hash => 'always' },
                          component => <<'EOF',
% eval '$AR' . 'GS{foo} = 1';
<% $@ ? $@ : 'no error' %>
EOF
                          expect => <<'EOF',
no error
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'define_args_hash_auto',
                          description => 'test setting define_args_hash to always',
                          call_args => { bar => 7 },
                          component => <<'EOF',
<%args>
$foo => $ARGS{bar}

foo is <% $foo %>
EOF
                          expect => <<'EOF',
foo is 7
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'comment_in_sub',
                          description => 'test a substitution that only contains a comment',
                          component => <<'EOF',
0
<% # a one-line comment %>
1
<%
   # a multiline
  
   # comment
%>
2
<% # a multiline
   # comment %>
3
<% %>
4

EOF
                          expect => <<'EOF',
0

1

2

3

4
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'in_package_shared',
                          description => 'Make sure in_package works with %shared',
                          interp_params => { in_package => 'HTML::Mason::Foo' },
                          component => <<'EOF',
<%shared>
my $foo = 'bar';

Foo: <% $foo %>
EOF
                          expect => <<'EOF',
Foo: bar
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'in_package_m_in_shared',
                          description => 'Make sure $m works with %shared when in_package is set',
                          interp_params => { in_package => 'HTML::Mason::Bar' },
                          component => <<'EOF',
<%shared>
my $dh = $m->dhandler_name;

<% $dh %>
EOF
                          expect => <<'EOF',
dhandler
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'compiler_id_change',
                          description => 'Make sure different compiler params use different object dirs',
                          component => <<'EOF',
<%args>
$count => 0
$compiler_params => {}
$object_id_hash => {}


count = <% $count %>

<%perl>
my $object_id = $m->interp->compiler->object_id;
if ($object_id_hash->{$object_id}++) {
    die "object_id '$object_id' has been seen (count = $count)!";
}
if ($count == 0) {
    $compiler_params->{enable_autoflush} = 0;
} elsif ($count == 1) {
    $compiler_params->{default_escape_flags} = 'h';
} elsif ($count == 2) {
    $compiler_params->{use_source_line_numbers} = 0;
} elsif ($count == 3) {
    $compiler_params->{postprocess_text} = sub { my $content = shift; $$content =~ tr/a-z/A-Z/ };
} else {
    return;
}
my $buf;
my $interp = _make_interp(comp_root => $m->interp->comp_root,
                          data_dir => $m->interp->data_dir,
                          out_method => \$buf,
                          %$compiler_params);
$interp->exec($m->current_comp->path, count=>$count+1, compiler_params=>$compiler_params, object_id_hash=>$object_id_hash);
$m->print($buf);

EOF
                          expect => <<'EOF',

count = 0


count = 1


count = 2


count = 3


COUNT = 4
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'no_warnings',
                          description => 'Make sure no warnings are generated for trying to output undef',
                          component => <<'EOF',
% my $x;
x is <% $x %>
EOF
                          expect => <<'EOF',
x is 
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'no_warnings_without_autoflush',
                          description => 'Make sure no warnings are generated for trying to output undef when enable_autoflush is off',
                          interp_params => { enable_autoflush => 0 },
                          component => <<'EOF',
% my $x;
x is <% $x %>
EOF
                          expect => <<'EOF',
x is 
EOF
                          no_warnings => 1,
                        );

#------------------------------------------------------------

        $group->add_test( name => 'no warnings',
                          description => "Make sure that warnings _aren't_ generated for other bad use of uninit",
                          component => <<'EOF',
% my $x;
x is <% $x + 2 %>
EOF
                          expect => <<'EOF',
x is 2
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'warnings_without_autoflush',
                          description => "Make sure that warnings _aren't_ generated for other bad use of uninit when enable_autoflush is off",
                          interp_params => { enable_autoflush => 0 },
                          component => <<'EOF',
% my $x;
x is <% $x + 2 %>
EOF
                          expect => <<'EOF',
x is 2
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'warnings_need_explicit_enabling',
                          description => "Make sure that warnings _are_ generated for other bad use of uninit",
                          component => <<'EOF',
% use warnings;
% my $x;
x is <% $x + 2 %>
EOF
                          expect => <<'EOF',
x is 2
EOF
                          expect_warnings => qr/Use of uninitialized value.+in addition/,
                        );

#------------------------------------------------------------

        $group->add_test( name => 'warnings_need_explicit_enabling_without_autoflush',
                          description => "Make sure that warnings _are_ generated for other bad use of uninit when enable_autoflush is off",
                          interp_params => { enable_autoflush => 0 },
                          component => <<'EOF',
% use warnings;
% my $x;
x is <% $x + 2 %>
EOF
                          expect => <<'EOF',
x is 2
EOF
                          expect_warnings => qr/Use of uninitialized value.+in addition/,
                        );

#------------------------------------------------------------

        $group->add_test( name => 'warnings_do_not_need_explicit_enabling_on_use_warnings',
                          interp_params => { use_warnings => 1 },
                          description => "Make sure that warnings _are_ generated on use_warnings for other bad use of uninit",
                          component => <<'EOF',
% my $x;
use_warnings is <% $x + 2 %>
EOF
                          expect => <<'EOF',
use_warnings is 2
EOF
                          expect_warnings => qr/Use of uninitialized value.+in addition/,
                        );

#------------------------------------------------------------

        $group->add_test( name => 'warnings_do_not_need_explicit_enabling_without_autoflush_on_use_warnings',
                          description => "Make sure that warnings _are_ generated on use_warnings for other bad use of uninit when enable_autoflush is off",
                          interp_params => { enable_autoflush => 0, use_warnings => 1 },
                          component => <<'EOF',
% my $x;
use_warnings is <% $x + 2 %>
EOF
                          expect => <<'EOF',
use_warnings is 2
EOF
                          expect_warnings => qr/Use of uninitialized value.+in addition/,
                        );

#------------------------------------------------------------

        $group->add_test( name => 'unbalanced_content_block_error',
                          description => 'Detect and report unbalanced  tags',
                          interp_params => { enable_autoflush => 0 },
                          component => <<'EOF',

EOF
                          expect_error => qr/content ending tag but no beginning tag/
                        );

#------------------------------------------------------------

        $group->add_test( name => 'unbalanced_content_block_subcomp_error',
                          description => 'Detect and report unbalanced  tags in subcomponents',
                          interp_params => { enable_autoflush => 0 },
                          component => <<'EOF',
<%def test>


EOF
                          expect_error => qr/content ending tag but no beginning tag/
                        );

#------------------------------------------------------------

    $group->add_test( name => 'non_stringifying_escape',
                      description => 'stringify after escapes, not before',
                      component => <<'EOF',
% $m->interp->set_escape( blort => sub { ${$_[0]} = ${$_[0]}->[0] if ref ${$_[0]} } );
Works for <% 'strings' | blort %>
Works for <% ['refs']  | blort %>
EOF
                      expect => <<'EOF',
Works for strings
Works for refs
EOF
                    );

#------------------------------------------------------------

    return $group;
}

# preprocessing the component
sub brackets_to_lt_gt
{
    my $comp = shift;
    ${ $comp } =~ s/\[\%(.*?)\%\]/<\%$1\%>/g;
}

# postprocessing alpha/perl code
sub uc_alpha
{
    ${ $_[0] } = uc ${ $_[0] };
}

sub make_foo_foofoo
{
    ${ $_[0] } =~ s/foo/foofoo/ig;
}
HTML-Mason-1.59/t/06b-compiler-named-subs.t0000644000175000017500000000427213660015140020013 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;


my $tests = make_tests();
$tests->run;

sub make_tests {
    my $group =
        HTML::Mason::Tests->tests_class->new
            ( name => 'compiler_named_subs',
              description => 'compiler with named subs in components' );

#------------------------------------------------------------

    $group->add_test( name => 'basic',
                      description => 'Make sure that named_component_subs_works',
                      interp_params => { named_component_subs => 1 },
                      component => <<'EOF',
This is a test
EOF
                      expect => <<'EOF',
This is a test
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'subcomps',
                      description => 'Make sure that named_component_subs_works with subcomps',
                      interp_params => { named_component_subs => 1 },
                      component => <<'EOF',
<& .subcomp &>
<%def .subcomp>
This is a subcomp

EOF
                      expect => <<'EOF',

This is a subcomp
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'methods',
                      description => 'Make sure that named_component_subs_works with methods',
                      interp_params => { named_component_subs => 1 },
                      component => <<'EOF',
<& SELF:method &>
<%method method>
This is a method

EOF
                      expect => <<'EOF',

This is a method
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'shared',
                      description => 'Make sure that named_component_subs_works with shared block',
                      interp_params => { named_component_subs => 1 },
                      component => <<'EOF',
<%shared>
my $x = 42;


1: x is <% $x %>
<& SELF:method &>
<%method method>
2: x is <% $x %>

EOF
                      expect => <<'EOF',

1: x is 42

2: x is 42
EOF
                    );

#------------------------------------------------------------

    return $group;
}
HTML-Mason-1.59/t/10-cache.t0000644000175000017500000003546513660015140015051 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;
use HTML::Mason::Tools;

# Skip if flock not implemented.
eval { my $fh = do { local *FH; *FH; }; open $fh, $0; flock $fh,1; };
if ($@)
{
    print "1..0 # Skipped: flock() is not available on this system\n";
    exit;
}

# Skip if Cache::FileCache not present.
eval { require Cache::FileCache };
if ($@)
{
    print "1..0 # Skipped: Cache::FileCache is not installed\n";
    exit;
}

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'cache',
                                                      description => 'Test caching' );

#------------------------------------------------------------

    $group->add_test( name => 'cache_packages',
                      description => 'test that Mason cache packages get created',
                      component => <<'EOF',
% my $cache;
% $cache = $m->cache(cache_class=>'Cache::FileCache');
<% ref($cache) %>
<% $HTML::Mason::Cache::FileCache::VERSION + 0 %>
<% HTML::Mason::Tools::pkg_loaded('HTML::Mason::Cache::FileCache') ? 'loaded' : 'not loaded' %>
% $cache = $m->cache(cache_class=>'MemoryCache');
<% ref($cache) %>
<% $HTML::Mason::Cache::MemoryCache::VERSION + 0%>
<% HTML::Mason::Tools::pkg_loaded('HTML::Mason::Cache::FileCache') ? 'loaded' : 'not loaded' %>
EOF
                      expect => <<'EOF',
HTML::Mason::Cache::FileCache
1
loaded
HTML::Mason::Cache::MemoryCache
1
loaded
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'support/cache_test',
                         component => <<'EOF',
<% $result %>
This was<% $cached ? '' : ' not' %> cached.

<%init>
my $cached = 0;
my $result;
my $return;
unless ($result = $m->cache->get('fandango')) {
    $result = "Hello Dolly.";
    $return = $m->cache->set('fandango', $result) || '';
} else {
    $cached = 1;
}

EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'cache',
                      description => 'basic caching functionality',
                      component => <<'EOF',
% for (my $i=0; $i<3; $i++) {
<& support/cache_test &>
% }
EOF
                      expect => <<'EOF',
Hello Dolly.
This was not cached.


Hello Dolly.
This was cached.


Hello Dolly.
This was cached.


EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'keys',
                      description => q|test multiple keys and $m->cache->get_keys|,
                      component => <<'EOF',
<%init>
foreach my $key (qw(foo bar baz)) {
    $m->cache->set($key, $key);
}
my @keys = sort $m->cache->get_keys;
$m->print("keys in cache: ".join(",",@keys)."\n");
foreach my $key (qw(foo bar baz)) {
    my $value = $m->cache->get($key) || "undefined";
    $m->print("value for $key is $value\n");
}
$m->cache->remove('foo');
$m->cache->remove('bar');
$m->print("expiring foo and bar...\n");
foreach my $key (qw(foo bar baz)) {
    my $value = $m->cache->get($key) || "undefined";
    $m->print("value for $key is $value\n");
}

EOF
                      expect => <<'EOF',
keys in cache: bar,baz,foo
value for foo is foo
value for bar is bar
value for baz is baz
expiring foo and bar...
value for foo is undefined
value for bar is undefined
value for baz is baz
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self;

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self',
                      description => 'test $m->cache_self',
                      component => <<'EOF',
<& support/cache_self, x => 1 &>
<& support/cache_self, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expires_in',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self( expires_in => '3s' );

EOF
                        );

    $group->add_test( name => 'cache_self_expires_in',
                      description => 'test that $m->cache_self respects expires_in parameter',
                      component => <<'EOF',
<& support/cache_self_expires_in, x => 1 &>
<& support/cache_self_expires_in, x => 2 &>
% sleep 5;
<& support/cache_self_expires_in, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 99
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expire_in',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self( expire_in => '2s' );

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_expire_in',
                      description => 'test that $m->cache_self respects expire_in parameter',
                      component => <<'EOF',
<& support/cache_self_expire_in, x => 1 &>
<& support/cache_self_expire_in, x => 2 &>
% sleep 5;
<& support/cache_self_expire_in, x => 99 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 99
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_expire_if',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self( expire_if => sub { $x == 3 } );

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_expire_if',
                      description => 'test that $m->cache_self respects expire_if parameter',
                      component => <<'EOF',
<& support/cache_self_expire_if, x => 1 &>
<& support/cache_self_expire_if, x => 2 &>
<& support/cache_self_expire_if, x => 3 &>
<& support/cache_self_expire_if, x => 4 &>
EOF
                      expect => <<'EOF',
x is 1

x is 1

x is 3

x is 3
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_with_key',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
$key

<%init>
return if $m->cache_self( key => $key );

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_key',
                      description => 'test $m->cache_self with a key',
                      component => <<'EOF',
<& support/cache_self_with_key, x => 1, key => 1 &>
<& support/cache_self_with_key, x => 99, key => 99 &>
<& support/cache_self_with_key, x => 1000, key => 1 &>
EOF
                      expect => <<'EOF',
x is 1

x is 99

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_and_die',
                          component => <<'EOF',
<%init>
return if $m->cache_self;
die "argh!";

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_error',
                      description => 'test $m->cache_self with an error to make sure errors are propogated',
                      component => <<'EOF',
<& support/cache_self_and_die, x => 1, key => 1 &>
EOF
                      expect_error => qr/argh! at .*/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_scomp',
                      description => 'make sure that $m->cache_self cooperates with $m->scomp',
                      component => <<'EOF',
<% $m->scomp( 'support/cache_self', x => 1 ) %>
<% $m->scomp( 'support/cache_self', x => 99 ) %>
EOF
                      expect => <<'EOF',
x is 1

x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_filtered',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x
$key => 1

<%init>
return if $m->cache_self( key => $key );

<%filter>
$_ = uc $_;
$_ .= ' filtered';

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered',
                      description => 'test $m->cache_self with a filter block',
                      component => <<'EOF',
<& support/cache_self_filtered, x => 1 &>
<& support/cache_self_filtered, x => 99 &>
EOF
                      expect => <<'EOF',
X IS 1
 filtered
X IS 1
 filtered
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered_scomp',
                      description => 'test $m->cache_self with a filter block callled via $m->scomp',
                      component => <<'EOF',
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 1 ) %>
<% $m->scomp( 'support/cache_self_filtered', key => 2, x => 99 ) %>
EOF
                      expect => <<'EOF',
X IS 1
 filtered
X IS 1
 filtered
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_filtered_2',
                          component => <<'EOF',
x is <% $x %>
<%args>
$x

<%init>
return if $m->cache_self;

<%filter>
s/(\d+)/$1+1/ge;

EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'cache_self_filtered_2',
                      description => 'make sure that results are only filtered once',
                      component => <<'EOF',
<& support/cache_self_filtered_2, x => 1 &>
<& support/cache_self_filtered_2, x => 99 &>
EOF
                      expect => <<'EOF',
x is 2

x is 2
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'expire_if',
                      description => 'test expire_if',
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef', $value3 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia');
my $value1 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at <= $time-1 });
my $value2 = $cache->get('main', expire_if=>sub { $_[0]->get_created_at >= $time });
my $value3 = $cache->get('main');

EOF
                      expect => <<'EOF',
gardenia, undef, undef
EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'busy_lock',
                      description => 'test busy_lock',
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'10 sec');
my $value2 = $cache->get('main');

EOF
                      expect => <<'EOF',
undef, gardenia
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'busy_lock_expiration',
                      description => 'test busy_lock expiration',
                      component => <<'EOF',
<% join(', ', $value1 || 'undef', $value2 || 'undef') %>
<%init>
my $time = time;
my $cache = $m->cache;
$cache->set('main', 'gardenia', 0);
my $value1 = $cache->get('main', busy_lock=>'1 sec');
sleep(1);
my $value2 = $cache->get('main');

EOF
                      expect => <<'EOF',
undef, undef
EOF
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_die',
                          component => <<'EOF',
die
<%init>
return if $m->cache_self;
die 'foo';

EOF
                        );

    $group->add_test( name => 'cache_self_death',
                      description => 'test $m->cache_self and death',
                      component => <<'EOF',
<%init>
$m->comp( 'support/cache_self_die' );

EOF
                      expect_error => qr/foo at/,
                    );

#------------------------------------------------------------

    $group->add_support ( path => 'support/cache_self_abort2',
                          component => <<'EOF',
going to abort, a = <% $ARGS{a} %>
% $m->abort();
EOF
                        );

    $group->add_support( path => 'support/cache_self_abort',
                         component => <<'EOF',
<%init>
return if $m->cache_self;
$m->comp( 'cache_self_abort2', a=>5 );

EOF
                       );

    $group->add_test( name => 'cache_self_abort',
                      description => 'test $m->cache_self and abort',
                      component => <<'EOF',
<%init>
eval { $m->comp( 'support/cache_self_abort', a=>5 ) };
eval { $m->comp( 'support/cache_self_abort', a=>10 ) };

EOF
                      expect => <<'EOF'
going to abort, a = 5
going to abort, a = 5
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'support/cache_self_with_subexec2',
                         component => <<'EOF',
This is the subrequest, a = <% $ARGS{a} %>
EOF
                       );

    $group->add_support( path => 'support/cache_self_with_subexec',
                         component => <<'EOF',
% return if $m->cache_self;
% $m->subexec('cache_self_with_subexec2', a=>$ARGS{a});
EOF
                       );

    $group->add_test( name => 'cache_self_with_subexec',
                      description => 'test $m->subexec in presence of $m->cache_self',
                      component => <<'EOF',
<& support/cache_self_with_subexec, a=>5 &>
<& support/cache_self_with_subexec, a=>10 &>
EOF
                         expect => <<'EOF',
This is the subrequest, a = 5

This is the subrequest, a = 5
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => 'declined/dhandler',
                         component => <<'EOF',
decline was called
EOF
                       );

    $group->add_test( name => 'declined/cache_self_decline',
                      description => 'test $m->decline in presence of $m->cache_self',
                      component => <<'EOF',
% return if $m->cache_self;
% $m->decline;
EOF
                      expect => <<'EOF',
decline was called
EOF
                    );

#------------------------------------------------------------

    return $group;
}

HTML-Mason-1.59/t/07a-interp-mcr.t0000644000175000017500000001247113660015140016225 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'interp-mcr',
                                                      description => 'In-depth testing of multiple component roots' );

    $group->add_test( name           => 'no_dynamic_comp_root',
                      description    => 'change comp root without dynamic_comp_root',
                      pre_code       => sub {
                          my ($interp) = @_;
                          $interp->comp_root($group->data_dir);
                      },
                      skip_component => 1,
                      call_path      => '/',
                      expect_error   => qr/cannot assign new comp_root/,
                      );

    $group->add_test( name           => 'change_single_comp_root',
                      description    => 'change single root',
                      interp_params  => {comp_root => '/usr/local/foo',
                                         dynamic_comp_root => 1},
                      pre_code       => sub {
                          my ($interp) = @_;
                          $interp->comp_root('/usr/local/bar');
                      },
                      skip_component => 1,
                      call_path      => '/',
                      expect_error   => qr/was originally associated with .*, cannot change/,
                      );

    $group->add_test( name           => 'reuse_comp_root_key',
                      description    => 'change comp root key mapping',
                      interp_params  => {comp_root => [['foo' => '/usr/local/foo'],
                                                       ['bar' => '/usr/local/bar']],
                                         dynamic_comp_root => 1},
                      pre_code       => sub {
                          my ($interp) = @_;
                          $interp->comp_root([['foo' => '/usr/local/foo'],
                                              ['bar' => '/usr/local/baz']]),
                      },
                      skip_component => 1,
                      call_path      => '/',
                      expect_error   => qr/was originally associated with .*, cannot change/,
                      );

    # For each test below, change the interpreter's component root on
    # the fly, then make sure the right versions of /foo and /bar/ are
    # being loaded.  Also occasionally remove a component to make sure
    # that the next one gets loaded. Run with both static_source=0 and
    # static_source=1.
    #

    foreach my $static_source (0, 1) {
        my $interp = $group->_make_interp ( comp_root         => $group->comp_root,
                                            data_dir          => $group->data_dir,
                                            static_source     => $static_source,
                                            dynamic_comp_root => 1,
                                          );
        
        foreach my $root (1..4) {
            $group->add_support( path => "/$root/interp-mcr/$static_source/foo",
                                 component => "I am $root/foo, <& bar &>",
                               );
        }
        foreach my $root (7..8) {
            $group->add_support( path => "/$root/interp-mcr/$static_source/bar",
                                 component => "I am $root/bar",
                               );
        }

        my $make_test_for_roots = sub
        {
            my ($keys, %params) = @_;
            my $test_name = "test" . join('', @$keys) . "-" . $static_source;

            $group->add_test( name => $test_name,
                              description => "test roots assigned to " . join(", ", @$keys) . ", static_source=$static_source",
                              skip_component => 1,
                              interp => $interp,
                              pre_code => sub {
                                  $interp->comp_root([map { [$_, $group->comp_root . "/interp-mcr/$_"] } @$keys]);
                                  if ($params{remove}) {
                                      foreach my $comp (qw(foo bar)) {
                                          unlink("mason_tests/$$/comps/interp-mcr/$params{remove}/interp-mcr/$static_source/$comp");
                                      }
                                  }
                              },
                              call_path => "/$static_source/foo",
                              %params
                            );
        };

        $make_test_for_roots->([1, 7],           expect=>'I am 1/foo, I am 7/bar');
        $make_test_for_roots->([1, 2, 3, 4, 8],  expect=>'I am 1/foo, I am 8/bar');
        if ($static_source) {
            $make_test_for_roots->([1, 2, 3, 7], remove=>'1', expect=>'I am 1/foo, I am 7/bar');
        } else {
            $make_test_for_roots->([1, 2, 3, 7], remove=>'1', expect=>'I am 2/foo, I am 7/bar');
        }
        $make_test_for_roots->([2, 3, 4, 7],     expect=>'I am 2/foo, I am 7/bar');
        $make_test_for_roots->([5, 4, 2, 3, 8],  expect=>'I am 4/foo, I am 8/bar');
        $make_test_for_roots->([5, 6],           expect_error => qr/could not find component/);
        $make_test_for_roots->([1, 2, 3, 4],     expect_error => qr/could not find component/);
    }

    return $group;
}
HTML-Mason-1.59/t/01-syntax.t0000644000175000017500000001564213660015140015327 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{

    my $group = HTML::Mason::Tests->tests_class->new( name => 'syntax',
                                                      description => 'Basic component syntax tests' );


#------------------------------------------------------------

    $group->add_test( name => 'replace',
                      description => 'tests <% %> tag',
                      component => <<'EOF',



Replacement Test



<% "Hello World!" %>


EOF
                      expect => <<'EOF',



Replacement Test



Hello World!


EOF
                    );


#------------------------------------------------------------

        $group->add_test( name => 'percent',
                          description => 'tests %-line syntax',
                          component => <<'EOF',



Percent Test



% my $message = "Hello World!";
<% $message %>


EOF
                          expect => <<'EOF',



Percent Test



Hello World!


EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'fake_percent',
                          description => 'tests % in text section',
                          component => 'some text, a %, and some text',
                          expect =>    'some text, a %, and some text',
                        );

#------------------------------------------------------------
        $group->add_test( name => 'empty_percents',
                          description => 'tests empty %-lines',
                          component => <<'EOF',
some text,
%
and some more
EOF
                          expect =>    "some text,\nand some more\n",
                        );
#------------------------------------------------------------

        $group->add_test( name => 'empty_percents2',
                          description => 'tests empty %-lines followed by other %-lines',
                          component => <<'EOF',
some text,
%
% $m->print('foo, ');
and some more
EOF
                          expect =>    "some text,\nfoo, and some more\n",
                        );

#------------------------------------------------------------

        $group->add_test( name => 'space_after_method_name',
                          description => 'tests that spaces are allowed after method/subcomp names',
                          component => <<'EOF',
a
<%def foo  >

<%method bar   
>

b
EOF
                          expect => <<'EOF',
a
b
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'comment_in_attr_flags',
                          description => 'tests that comments are allowed at end of flag/attr lines',
                          component => <<'EOF',
a
<%flags>
inherit => undef # foo bar

<%attr>
a => 1 # a is 1
b => 2 # ya ay

b
EOF
                          expect => <<'EOF',
a
b
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'dash in subcomp named',
                          description => 'tests that dashes are allowed in subcomponent names',
                          component => <<'EOF',
a
<%def has-dashes>
foo

b
EOF
                          expect => <<'EOF',
a
b
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'flags_on_one_line',
                          description => 'tests that a flags block can be one line',
                          component => <<'EOF',
a
<%flags>inherit => undef
b
EOF
                          expect => <<'EOF',
a
b
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'attr_uc_ending',
                          description => 'tests that an attr ending tag can be upper-case',
                          component => <<'EOF',
<%ATTR>
thing => 1
thing: <% $m->request_comp->attr('thing') %>
EOF
                          expect => <<'EOF',
thing: 1
EOF
                        );

#------------------------------------------------------------

        $group->add_test( name => 'args_uc_ending',
                          description => 'tests that args ending tag can be mixed case',
                          component => <<'EOF',
<%ARGS>
$a => 1
a is <% $a %>
b
EOF
                          expect => <<'EOF',
a is 1
b
EOF
                        );

#------------------------------------------------------------

    $group->add_test( name => 'comment_in_call',
                      description => 'make a comp call with a commented line',
                      component => <<'EOF',
<& .foo,
   foo => 1,
#   bar => 2,
 &>
<& .foo,
#   foo => 1,
   bar => 2,
 &>
<%def .foo>foo! args are <% join(", ", %ARGS) %>
EOF
                      expect => <<'EOF',
foo! args are foo, 1
foo! args are bar, 2
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'comment_in_call2',
                      description => 'make a comp call with content with a commented line',
                      component => <<'EOF',
<&| .show_content,
   foo => 1,
#   bar => 2,
 &>\
This is the content\

<%def .show_content>\
<% $m->content %>\

EOF
                      expect => <<'EOF',
This is the content
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'call_starts_with_newline',
                      description => 'make a comp call where the tag starts with a newline',
                      component => <<'EOF',
<&
 .foo,
 x => 1
 &>\
<%def .foo>\
x is <% $ARGS{x} %>

EOF
                      expect => <<'EOF',
x is 1
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'cleanup_init',
                      description => 'test that cleanup block has access to variables from init section',
                      component => <<'EOF',
<%init>
my $x = 7;

<%cleanup>
$m->print("x is $x");

EOF
                      expect => <<'EOF',
x is 7
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'cleanup_perl',
                      description => 'test that cleanup block has access to variables from perl section',
                      component => <<'EOF',
<%perl>
my $x = 7;

<%cleanup>
$m->print("x is $x");

EOF
                      expect => <<'EOF',
x is 7
EOF
                    );

#------------------------------------------------------------

    return $group;
}
HTML-Mason-1.59/t/17-print.t0000644000175000017500000000237713660015140015145 0ustar  autarchautarchuse strict;

use Cwd;
use File::Spec;

use HTML::Mason::Tests;

print "1..9\n";

my $comp_root = File::Spec->catdir( getcwd(), 'mason_tests', 'comps' );
($comp_root) = $comp_root =~ /(.*)/;
my $data_dir = File::Spec->catdir( getcwd(), 'mason_tests', 'data' );
($data_dir) = $data_dir =~ /(.*)/;

my $tests = HTML::Mason::Tests->tests_class->new( name => 'print',
                                                  description => 'printing to standard output' );

my $interp = HTML::Mason::Tests->tests_class->_make_interp
    ( comp_root => $comp_root,
      data_dir => $data_dir
      );

{
    my $source = <<'EOF';
ok 1
% print "ok 2\n";
EOF

    my $comp = $interp->make_component( comp_source => $source );

    my $req = $interp->make_request(comp=>$comp);

    $req->exec();
}

# same stuff but with autoflush
{
    my $source = <<'EOF';
ok 3
% print "ok 4\n";
EOF

    my $comp = $interp->make_component( comp_source => $source );

    my $req = $interp->make_request( comp=>$comp, autoflush => 1 );

    $req->exec();
}

{
    my $source = <<'EOF';
ok 5
% print "ok 6\n";
ok 7
% print "ok 8\n";
% print "", "ok ", "9", "\n";
EOF

    my $comp = $interp->make_component( comp_source => $source );

    my $req = $interp->make_request( comp=>$comp );

    $req->exec();
}
HTML-Mason-1.59/t/run_tests0000755000175000017500000000027513660015140015346 0ustar  autarchautarch#!/bin/bash
PERL_DL_NONLAZY=1 find . -type f -name "*.t" | sort | egrep -v '08-ah|12-taint|16-live_cgi' | xargs /usr/bin/perl -I../lib -e 'use Test::Harness qw(&runtests); runtests @ARGV;'
HTML-Mason-1.59/t/18-leak.t0000644000175000017500000001745713660015140014733 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;
use HTML::Mason::Tools qw(can_weaken);

BEGIN
{
    unless ( can_weaken )
    {
        print "Your installation does not include Scalar::Util::weaken\n";
        print "1..0\n";
        exit;
    }
}

my $tests = make_tests();
$tests->run;

{
    package InterpWatcher;
    my $_destroy_count = 0;
    
    use base qw(HTML::Mason::Interp);
    sub DESTROY { $_destroy_count++ }
    sub _destroy_count   { $_destroy_count   }
    sub _clear_destroy_count { $_destroy_count = 0 }
}

{
    package RequestWatcher;
    my $_destroy_count = 0;
    
    use base qw(HTML::Mason::Request);
    sub DESTROY { $_destroy_count++ }
    sub _destroy_count   { $_destroy_count   }
    sub _clear_destroy_count { $_destroy_count = 0 }
}

{
    # Unfortunately cannot override component class, even by setting
    # comp_class, because it is hardcoded in
    # Resolver/FileBased.pm. This works as long as Component.pm
    # doesn't have any of these methods.
    #
    package HTML::Mason::Component;
    my $_destroy_count = 0;
    
    sub DESTROY { $_destroy_count++ }
    sub _destroy_count   { $_destroy_count   }
    sub _clear_destroy_count { $_destroy_count = 0 }
}

{
    package SubcomponentWatcher;
    my $_destroy_count = 0;
    
    use base qw(HTML::Mason::Component::Subcomponent);
    sub DESTROY { $_destroy_count++ }
    sub _destroy_count   { $_destroy_count   }
    sub _clear_destroy_count { $_destroy_count = 0 }
}

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => '18-leak.t',
                                                      description => 'Tests that various memory leaks are no longer with us' );

    $group->add_test( name => 'interp_destroy',
                      description => 'Test that interps with components in cache still get destroyed',
                      component => <<'EOF',
<%perl>
{ 
    my $interp = InterpWatcher->new();
    my $comp = $interp->make_component( comp_source => 'foo' );
}
$m->print("destroy_count = " . InterpWatcher->_destroy_count . "\n");

{
    my $interp = InterpWatcher->new();
    my $comp = $interp->make_component( comp_source => 'foo' );
}
$m->print("destroy_count = " . InterpWatcher->_destroy_count . "\n");

EOF
                      expect => <<'EOF',
destroy_count = 1
destroy_count = 2
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => '/support/no_error_comp',
                         component => <<'EOF',
No error here.
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/compile_error_comp',
                         component => <<'EOF',
<%
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/runtime_error_comp',
                         component => <<'EOF',
% die "bleah";
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/recursive_caller_1',
                         component => <<'EOF',
<%perl>
$m->comp("recursive_caller_2", %ARGS);
return;

EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/support/recursive_caller_2',
                         component => <<'EOF',
<%perl>
my $anon_comp = $ARGS{anon_comp};
$m->comp($anon_comp, %ARGS) if $m->depth < 16;
return;

EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'request_destroy',
                      description => 'Test that requests get destroyed after top-level component error',
                      interp_params => { request_class => 'RequestWatcher' },
                      component => <<'EOF',
<%perl>
eval { $m->subexec('support/no_error_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");
eval { $m->subexec('support/compile_error_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");
eval { $m->subexec('support/not_found_comp') };
$m->print("destroy_count = " . RequestWatcher->_destroy_count . "\n");

EOF
                      expect => <<'EOF',
No error here.
destroy_count = 1
destroy_count = 2
destroy_count = 3
EOF
                    );

#------------------------------------------------------------

    $group->add_support( path => '/support/def_and_method',
                         component => <<'EOF',
<%init>
$m->comp('.def');
$m->comp('SELF:method');
return;


<%def .def>
This is a def


<%method method>
This is a method

EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'component_destroy',
                      description => 'Test that components get freed when cleared from the main cache',
                      interp_params => { code_cache_max_size => 0 },
                      component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
$m->subexec('support/no_error_comp');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
$m->subexec('support/no_error_comp');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
eval { $m->subexec('support/runtime_error_comp') };
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
eval { $m->subexec('support/runtime_error_comp') };
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");

EOF
                      expect => <<'EOF',
No error here.
destroy_count = 1
No error here.
destroy_count = 2
destroy_count = 3
destroy_count = 4
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'component_destroy_static_source',
                      description => 'Test that components get freed in static source mode',
                      interp_params => { static_source => 1 },
                      component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
my $anon_comp_text = q|
<%init>
$m->comp("/18-leak.t/support/recursive_caller_1", %ARGS);
return;

|;
my $anon_comp = $m->interp->make_component( comp_source => $anon_comp_text );
$m->subexec('support/recursive_caller_1', anon_comp=>$anon_comp);
$m->interp->flush_code_cache;
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");
$m->subexec('support/recursive_caller_1', anon_comp=>$anon_comp);
$m->interp->flush_code_cache;
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . "\n");

EOF
                      expect => <<'EOF',
destroy_count = 2
destroy_count = 4
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'subcomponent_destroy',
                      description => 'Test that defs and methods don\'t cause components to leak',
                      interp_params => { subcomp_class => 'SubcomponentWatcher',
                                         code_cache_max_size => 0 },
                      component => <<'EOF',
<%perl>
HTML::Mason::Component->_clear_destroy_count;
$m->subexec('support/def_and_method');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . ", " . SubcomponentWatcher->_destroy_count . "\n");
$m->subexec('support/def_and_method');
$m->print("destroy_count = " . HTML::Mason::Component->_destroy_count . ", " . SubcomponentWatcher->_destroy_count . "\n");

EOF
                      expect => <<'EOF',

This is a def

This is a method
destroy_count = 1, 2

This is a def

This is a method
destroy_count = 2, 4
EOF
                       );

#------------------------------------------------------------

    return $group;
}
HTML-Mason-1.59/t/04-misc.t0000644000175000017500000002136713660015140014740 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'misc',
                                                      description => 'autohandler and dhandler functionality' );


#------------------------------------------------------------

    $group->add_support( path => '/autohandler_test/autohandler',
                         component => <<'EOF',
<& header &>
Autohandler comp: <% $m->fetch_next->title %>
% my $buf;
% $m->call_next(b=>$a*2);
<& footer &>

<%args>
$a=>5

EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => '/autohandler_test/header',
                         component => <<'EOF',
>

The Site


<%args>
$bgcolor=>'white'

EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => '/autohandler_test/footer',
                         component => <<'EOF',


Copyright 1999 Schmoopie Inc.

EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'autohandler',
                      path => '/autohandler_test/hello',
                      call_path => '/autohandler_test/hello',
                      description => 'autohandler test',
                      component => <<'EOF',
Hello World!
The answer is <% $b %>.
<%args>
$b




EOF
                      expect => <<'EOF',


The Site



Autohandler comp: /misc/autohandler_test/hello
Hello World!
The answer is 10.





Copyright 1999 Schmoopie Inc.



EOF
                    );



#------------------------------------------------------------

    $group->add_support( path => '/dhandler_test/dhandler',
                         component => <<'EOF',
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => '/dhandler_test/subdir/dhandler',
                         component => <<'EOF',
% $m->decline if $m->dhandler_arg eq 'leaf3';
% $m->decline if $m->dhandler_arg eq 'slashes';
% $m->decline if $m->dhandler_arg eq 'buffers';
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => '/dhandler_test/subdir/autohandler',
                         component => <<'EOF',
Header
<% $m->call_next %>
EOF
                       );


#------------------------------------------------------------

    $group->add_support( path => '/dhandler_test/bar/dhandler',
                         component => <<'EOF',
dhandler = <% $m->current_comp->title %>
dhandler arg = <% $m->dhandler_arg %>
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/dhandler_test/buff/dhandler',
                         component => <<'EOF',
Buffer stack size: <% scalar $m->buffer_stack %>
EOF
                       );


#------------------------------------------------------------

    $group->add_test( name => 'dhandler1',
                      description => 'tests dhandler against nonexistent comp',
                      call_path => '/dhandler_test/foo/bar',
                      skip_component => 1,
                      expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = foo/bar

EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'dhandler2',
                      description => 'real comp to make sure the real comp is invoked, not the dhandler',
                      path => '/dhandler_test/subdir/leaf',
                      call_path => '/dhandler_test/subdir/leaf',
                      component => <<'EOF',
I'm leaf
EOF
                      expect => <<'EOF',
Header
I'm leaf

EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'dhandler3',
                      description => 'real comp declines the request to make sure the dhandler is invoked',
                      path => '/dhandler_test/subdir/leaf2',
                      call_path => '/dhandler_test/subdir/leaf2',
                      component => <<'EOF',
% $m->decline;
I'm leaf2

EOF
                      expect => <<'EOF',
Header
dhandler = /misc/dhandler_test/subdir/dhandler
dhandler arg = leaf2

EOF
                    );


#------------------------------------------------------------

    $group->add_test( name => 'dhandler4',
                      description => 'declines twice to make sure higher level dhandler is called',
                      path => '/dhandler_test/subdir/leaf3',
                      call_path => '/dhandler_test/subdir/leaf3',
                      component => <<'EOF',
% $m->decline;
I'm leaf3
EOF
                      expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = subdir/leaf3

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'dhandler5',
                      description => 'decline with doubled slash (//) in URL path',
                      path => '/dhandler_test/subdir/slashes',
                      call_path => '//dhandler_test//subdir//slashes',
                      component => <<'EOF',
% $m->decline;
I have many slashes!
EOF
                      expect => <<'EOF',
dhandler = /misc/dhandler_test/dhandler
dhandler arg = subdir/slashes

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'dhandler6',
                      description => 'test that a dhandler more than one directory up is found',
                      call_path => '/dhandler_test/bar/baz/quux/not_here',
                      skip_component => 1,
                      expect => <<'EOF',
dhandler = /misc/dhandler_test/bar/dhandler
dhandler arg = baz/quux/not_here

EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'accessor_validate',
                      description => 'test accessor parameter validation',
                      component => <<'EOF',
% $m->interp->ignore_warnings_expr([1]);
EOF
                      expect_error => qr/Parameter #1.*to .*? was an 'arrayref'/,
                    );

#------------------------------------------------------------

    $group->add_test( name => 'contained_accessor_validate',
                      description => 'test contained accessor parameter validation',
                      component => <<'EOF',
% $m->interp->autoflush([1]);
EOF
                      expect_error => qr/Parameter #1.*to .*? was an 'arrayref'/,
                    );

#------------------------------------------------------------

    # define /dhandler that sometimes declines. test framework should provide a
    # more supported way to define a top-level component!
    my $updir = File::Spec->updir;
    $group->add_support( path => "$updir/dhandler",
                         component => <<'EOF',
% if ($m->request_args->{decline_from_top}) {
%   $m->decline;
% } else {
top-level dhandler: path = <% $m->current_comp->path %>
% }
EOF
                       );

#------------------------------------------------------------

    $group->add_support( path => '/dhandler',
                         component => <<'EOF',
% $m->decline;
EOF
                       );

#------------------------------------------------------------

    $group->add_test( name => 'top_level_dhandler_handles',
                      description => 'make sure dhandler at /dhandler is called correctly after decline from lower-level dhandler',
                      path      => '/notused',
                      call_path => '/nonexistent',
                      component => <<'EOF',
not ever used
EOF
                      expect => <<'EOF',
top-level dhandler: path = /dhandler
EOF
                    );

#------------------------------------------------------------

    $group->add_test( name => 'top_level_dhandler_declines',
                      description => 'make sure /dhandler decline results in not-found error',
                      path      => '/notused2',
                      call_path => '/nonexistent',
                      call_args => { decline_from_top => 1 },
                      component => <<'EOF',
not ever used
EOF
                      expect_error => qr/could not find component for initial path/,
                    );

#------------------------------------------------------------

    return $group;
}
HTML-Mason-1.59/t/14a-fake_apache.t0000644000175000017500000001763713660015140016363 0ustar  autarchautarchuse strict;
use warnings;

use Test::More tests => 97;
use CGI qw(-no_debug);

BEGIN { use_ok('HTML::Mason::CGIHandler') }

# Create headers object.
ok( my $h = HTML::Mason::FakeTable->new, "Create new FakeTable" );

# Test direct hash access.
ok( $h->{Location} = 'foo', "Assing to Location" );
is( $h->{Location}, 'foo', "Location if 'foo'" );

# Test case-insensitivity.
is( $h->{location}, 'foo', "location if 'foo'" );
is( delete $h->{Location}, 'foo', "Delete location" );

# Test add().
ok( $h->{Hey} = 1, "Set 'Hey' to 1" );
ok( $h->add('Hey', 2), "Add another value to 'Hey'" );

# Fetch both values at once.
is_deeply( [$h->get('Hey')], [1,2], "Get array for 'Hey'" );
is( scalar $h->get('Hey'), 1, "Get first 'Hey' value only" );

# Try do(). The code ref should be executed twice, once for each value
# in the 'Hey' array reference.
my $i;
$h->do( sub {
    my ($k, $v) = @_;
    is( $k, 'Hey', "Check key in 'do'" );
    is( $v, ++$i, "Check value in 'do'" );
});

# Try short-circutiting do(). The code ref should be executed only once,
# because it returns a false value.
$h->do( sub {
    my ($k, $v) = @_;
    is( $k, 'Hey', "Check key in short 'do'" );
    is( $v, 1, "Check value in short 'do'" );
    return;
});

# Test set() and get().
ok( $h->set('Hey', 'bar'), "Set 'Hey' to 'bar'" );
is( $h->{Hey}, 'bar', "Get 'Hey'" );
is( $h->get('Hey'), 'bar', "Get 'Hey' with get()" );

# Try merge().
ok( $h->merge(Hey => 'you'), "Add 'you' to 'Hey'" );
is( $h->{Hey}, 'bar,you', "Get 'Hey'" );
is( $h->get('Hey'), 'bar,you', "Get 'Hey' with get()" );

# Try unset().
ok( $h->unset('Hey'), "Unset 'Hey'" );
ok( ! exists $h->{Hey}, "Hey doesn't exist" );
is( $h->{Hey}, undef, 'Hey is undef' );

# Try clear().
ok( $h->{Foo} = 'bar', "Add Foo value" );
$h->clear;
ok( ! exists $h->{Foo}, "Hey doesn't exist" );
is( $h->{Foo}, undef, 'Hey is undef' );

# Set up some environment variables.
%ENV = ( 'SCRIPT_NAME'          => '/login/welcome.html',
         'REQUEST_METHOD'       => 'GET',
         'HTTP_ACCEPT'          => 'text/html',
         'HTTP_USER_AGENT'      => 'Mozilla/5.0',
         'HTTP_CACHE_CONTROL'   => 'max-age=0',
         'HTTP_ACCEPT_LANGUAGE' => 'en-us,en;q=0.5',
         'HTTP_KEEP_ALIVE'      => '300',
         'GATEWAY_INTERFACE'    => 'CGI-Perl/1.1',
         'DOCUMENT_ROOT'        => '/usr/local/bricolage/comp',
         'HTTP_REFERER'         => 'http://localhost/',
         'HTTP_ACCEPT_ENCODING' => 'gzip,deflate',
         'HTTP_CONNECTION'      => 'keep-alive',
         'HTTP_ACCEPT_CHARSET'  => 'ISO-8859-1,utf-8;q=0.7,*;q=0.7',
         'HTTP_COOKIE'          => 'FOO=BAR; HEY=You',
         'HTTP_HOST'            => 'localhost',
         'AUTH_TYPE'            => 'Something',
         'CONTENT_TYPE'         => 'text/html',
         'CONTENT_LENGTH'       => 42,
         'REQUEST_METHOD'       => 'GET',
         'PATH_INFO'            => '/index.html',
         'QUERY_STRING'         => "foo=1&bar=2&you=3&you=4",
       );

# Now create a fake apache object.
ok( my $r = HTML::Mason::FakeApache->new, "Create new FakeApache" );

# Check its basic methods.
is( $r->method, $ENV{REQUEST_METHOD}, "Check request method" );
ok( $r->content_type('text/xml'), 'Set content type' );
is( $r->content_type, 'text/xml', 'Check content type' );

# Check the headers out.
ok( $h = $r->headers_out, "Get headers out" );
is( $h->{'Content-Type'}, 'text/xml', 'Check header content-type' );
is( $h->{'content-type'}, 'text/xml', 'Check lc header content-type' );

# Check with get().
is( $h->get('Content-Type'), 'text/xml', 'Check header content-type' );
is( $h->get('content-type'), 'text/xml', 'Check lc header content-type' );

# Try getting an array.
ok( my %h = $r->headers_out, "Get headers out" );
is( $h{'Content-Type'}, 'text/xml', 'Check header content-type' );
is( $h{'content-type'}, undef, 'List context returns new hash list' );

# Try assigning a new value via header_out().
ok( $r->header_out('Annoyance-Level' => 'high'), "Set annoyance level" );
is( $r->header_out('Annoyance-Level'), 'high', "Check annoyance level" );
is( $h->{'annoyance-level'}, 'high', "Check the hash directly" );
ok( $h->unset('annoyance-level'), 'Unset annoyance level' );
is( $r->header_out('Annoyance-Level'), undef, "Check annoyance level again" );
is( $h->{'annoyance-level'}, undef, "Check the hash directly again" );

# Add some cookies
ok( $r->headers_out()->add('Set-Cookie' => 'AF_SID=6e8834d8787ee57a; path=/'), "Set cookie" );
ok( $r->headers_out()->add('Set-Cookie' => 'uniq_id=5608074; path=/; expires=Tue, 26-Aug-2008 21:27:03 GMT'), "Set cookie" );

# Now check err_headers_out.
my $url = 'http://example.com/';
ok( my $e = $r->err_headers_out, "Get error headers out" );
is( scalar keys %$e, 0, "Check for no error headers out" );
ok( $r->err_header_out(Location => $url), "Set location header" );
is( $e->{Location}, $url, "Check Location" );
is( $e->{location}, $url, "Check location" );
is( $e->get('Location'), $url, "Get Location" );
is( $e->get('location'), $url, "Get location" );

# Now check headers_in().
is( $r->header_in('User-Agent'), $ENV{HTTP_USER_AGENT}, "Check user agent" );
ok( $h = $r->headers_in, "Get headers in table" );
is( $h->{Referer}, $ENV{HTTP_REFERER}, "Check referer" );
is( $h->get('Content-Type'), $ENV{CONTENT_TYPE}, "Check in content type" );

# Try notes().
ok( my $n = $r->notes, "Get notes" );
is( scalar keys %$n, 0, "No notes yet" );
ok( $r->notes( foo => 'bar'), "Set note 'foo'" );
is( $r->notes('foo'), 'bar', "Get note 'foo'" );
is( $r->notes('FOO'), 'bar', "Get note 'FOO'" );
is( $n->{foo}, 'bar', "Check note 'foo'" );
is( $n->{FOO}, 'bar', "Check uc note 'foo'" );
my $ref = [];
ok( $n->{bar} = $ref, "Set 'bar' to '$ref'" );
is( $n->{bar}, "$ref", "Check for stringified ref" );
is( $n->get('bar'), "$ref", "Get stringified ref" );

# Try pnotes().
ok( my $pn = $r->pnotes, "Get pnotes" );
is( scalar keys %$pn, 0, "No pnotes yet" );
ok( $r->pnotes( foo => 'bar'), "Set note 'foo'" );
is( $r->pnotes('foo'), 'bar', "Get note 'foo'" );
is( $pn->{foo}, 'bar', "Check note 'foo'" );
$ref = [];
ok( $pn->{bar} = $ref, "Set 'bar' to '$ref'" );
is( $pn->{bar}, $ref, "Check for stringified ref" );

# Check params()
ok( my $p = $r->params, "Get params" );
is( $p->{foo}, 1, "Check 'foo'" );
is( $p->{bar}, 2, "Check 'bar'" );
is_deeply( $p->{you}, [3, 4], "Check 'you'" );

# Check subprocess_env.
is( $r->subprocess_env('CONTENT_LENGTH'), 42, "Get CONTENT_LENGTH env" );
is( $r->subprocess_env('content_length'), 42, "Get content_length env" );
is( $r->subprocess_env->{CONTENT_LENGTH}, 42, "Check CONTENT_LENGTH env" );
is( $r->subprocess_env->{content_length}, 42, "Check content_length env" );
ok( $r->subprocess_env('CONTENT_LENGTH', 56), "Set CONTENT_LENGTH 56" );
is( $r->subprocess_env('CONTENT_LENGTH'), 56, "Check CONTENT_LENGTH env 56" );
is( $r->subprocess_env('content_length'), 56, "Check content_length env 56" );

# Reset subprocess_env.
ok( $r->subprocess_env, "Reset env" );
is( $r->subprocess_env('CONTENT_LENGTH'), 42, "Check CONTENT_LENGTH env again" );
is( $r->subprocess_env('content_length'), 42, "Check content_length env again" );

# Now see what CGI.pm does with the headers out.
ok( my $headers = $r->http_header, "Get http headers" );
like( $headers, qr/Status: 302 (?:Moved|Found)/i, "Check status" );
like( $headers, qr|Location: $url|i, "Check location" );
like( $headers, qr|Content-Type: text/xml(?:; charset=ISO-8859-1)?|i,
      "Check content type" );
like( $headers, qr|Set-Cookie: AF_SID=6e8834d8787ee57a; path=/|i,
      'Check first cookie');
like( $headers, qr|Set-Cookie: uniq_id=5608074; path=/; expires=Tue, 26-Aug-2008 21:27:03 GMT|i,
      'Check second cookie' );

is( $r->uri, '/login/welcome.html/index.html', 'test uri method' );
is( $r->path_info, '/index.html', 'test path_info method' );

SKIP:
{
    skip 'This test requires Test::Output', 1
        unless eval { require Test::Output; Test::Output->import; 1};

    stdout_is( sub { $r->print('Foo bar') }, 'Foo bar',
               'print does not include the object itself' );
}

__END__
HTML-Mason-1.59/t/21-escapes.t0000644000175000017500000000140513660015140015416 0ustar  autarchautarchuse strict;
use warnings;

use Test::More;

use HTML::Mason::Escapes;

plan tests => 3;


my $html = qq|<>"& \x{2202}|;
HTML::Mason::Escapes::basic_html_escape( \$html );
is( $html, "<>"& \x{2202}",
    'test basic HTML escape' );

SKIP:
{
    skip 'HTML::Entities does not escape utf8 properly under Perl < 5.8', 1
        if $] < 5.008;
    # Perl 5.6.2 totally borks this, thought it's probably just be a
    # bug in HTML::Entities
    my $html2 = qq|<>"& \x{2202}\x{20a5}|;
    HTML::Mason::Escapes::html_entities_escape( \$html2 );
    is( $html2, "<>"& ∂₥",
        'test HTML::Entities escape' );
}

my $url = qq|"=\x{2202}|;
HTML::Mason::Escapes::url_escape( \$url );
is( $url, '%22%3D%E2%88%82',
    'test url escape' );
HTML-Mason-1.59/t/20-plugins.t0000644000175000017500000004532613660015140015465 0ustar  autarchautarchuse strict;
use warnings;

use HTML::Mason::Tests;

package HTML::Mason::Plugin::TestBeforeAndAfterRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
    my ($self, $context) = @_;
    print "Before Request\n";
}
sub end_request_hook {
    print "After Request\n";
}

package HTML::Mason::Plugin::TestBeforeAndAfterComponent;
use base qw(HTML::Mason::Plugin);
sub start_component_hook {
    my ($self, $context) = @_;
    print "Before Component " . $context->comp->title . "\n";
}
sub end_component_hook {
    my ($self, $context) = @_;
    print "After Component " . $context->comp->title . "\n";
}

# test the ordering of plugin calls
package HTML::Mason::Plugin::TestAllCalls;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
    my ($self, $context) = @_;
    my $rcomp = $context->request->request_comp()->title;
    print "AllCalls Request Start on: $rcomp\n";
}
sub end_request_hook {
    my ($self, $context) = @_;
    my $rcomp = $context->request->request_comp()->title;
    print "AllCalls Request Finish on: $rcomp\n";
}
sub start_component_hook {
    my ($self, $context) = @_;
    print "AllCalls Before Component " . $context->comp->title . "\n";
}
sub end_component_hook {
    my ($self, $context) = @_;
    print "AllCalls After Component " . $context->comp->title . "\n";
}

package HTML::Mason::Plugin::TestResetEachRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
    my ($self, $context) = @_;
    my $rcomp = $context->request->request_comp->title();
    print "PreRequest: " . ++ $self->{count} . " : $rcomp\n";
}
sub end_request_hook {
    my ($self, $context) = @_;
    my $rcomp = $context->request->request_comp->title();
    print "PostRequest: " . ++ $self->{count} . " : $rcomp\n";
}
sub start_component_hook {
    my ($self, $context) = @_;
    print "PreComponent: " . ++ $self->{count} . " : " . $context->comp->title() ."\n";
}
sub end_component_hook {
    my ($self, $context) = @_;
    print "PostComponent: " . ++ $self->{count} . " : " . $context->comp->title() ."\n";
}

package HTML::Mason::Plugin::TestErrorStartRequest;
use base qw(HTML::Mason::Plugin);
sub start_request_hook {
    my ($self, $context) = @_;
    die("plugin error on start request " . $context->request->request_comp->title);
}

package HTML::Mason::Plugin::TestErrorEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
    my ($self, $context) = @_;
    die("plugin error on end request " . $context->request->request_comp->title);
}

package HTML::Mason::Plugin::TestErrorStartComponent;
use base qw(HTML::Mason::Plugin);
sub start_component_hook {
    my ($self, $context) = @_;
    die("plugin error on start component " . $context->comp->title);
}

package HTML::Mason::Plugin::TestErrorEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
    my ($self, $context) = @_;
    die("plugin error on end component " . $context->comp->title);
}

package HTML::Mason::Plugin::TestModifyReturnEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
    my ($self, $context) = @_;
    my $result = $context->result;
    if (defined($result->[0])) {
        $result->[0] = $result->[0] * 2;
    }
}

package HTML::Mason::Plugin::TestModifyReturnEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
    my ($self, $context) = @_;
    my $result = $context->result;
    if (defined($result->[0])) {
        $result->[0] = $result->[0] * 2;
    }
}

package HTML::Mason::Plugin::TestCatchErrorEndComponent;
use base qw(HTML::Mason::Plugin);
sub end_component_hook {
    my ($self, $context) = @_;
    my $error = $context->error;
    if (defined($$error)) {
        print "Caught error " . $$error . " and trapping it.\n";
        $$error = undef;
    }
}

package HTML::Mason::Plugin::TestCatchErrorEndRequest;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
    my ($self, $context) = @_;
    my $error = $context->error;
    if (defined($$error)) {
        print "Caught error " . $$error . " and trapping it.\n";
        $$error = undef;
    }
}

package HTML::Mason::Plugin::TestEndRequestModifyOutput;
use base qw(HTML::Mason::Plugin);
sub end_request_hook {
    my ($self, $context) = @_;
    my $content_ref = $context->output;
    $$content_ref = uc($$content_ref);
}

package main;

my $tests = make_tests();
$tests->run;

sub make_tests
{

  my $group = HTML::Mason::Tests->tests_class->new( name => 'plugins',
                                                    description => 'request and component plugin hooks'
                                                    );

#------------------------------------------------------------

  # comp A calls comp B two times.
  $group->add_support( path => '/support/A.m',
                       component => <<'EOF',
Component A Start
<& B.m &>
<& B.m &>
Component A Finish
EOF
                );

#------------------------------------------------------------


  $group->add_support( path => '/support/B.m',
                       component => <<'EOF',
Component B Start
Component B Finish
EOF
                );

#------------------------------------------------------------


  $group->add_support( path => '/support/error.m',
                       component => <<'EOF',
% die("uh oh");
EOF
                );


#------------------------------------------------------------

  $group->add_test( name => 'before_and_after_request',
                    description => 'a simple plugin for requests',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterRequest'],
                    },
                    component => '<& support/A.m &>',
                    expect => <<'EOF',
Before Request
Component A Start
Component B Start
Component B Finish

Component B Start
Component B Finish

Component A Finish
After Request
EOF
                    
                  );


#------------------------------------------------------------

  $group->add_test( name => 'before_and_after_component',
                    description => 'a simple plugin for components',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
                    },
                    component => '<& support/A.m &>',
                    expect => <<'EOF',
Before Component /plugins/before_and_after_component
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m

Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m

Component A Finish
After Component /plugins/support/A.m
After Component /plugins/before_and_after_component
EOF
                    
                  );

#------------------------------------------------------------

  $group->add_test( name => 'two_plugins',
                    description => 'using two different plugins',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent', 'HTML::Mason::Plugin::TestBeforeAndAfterRequest'],
                    },
                    component => '<& support/A.m &>',
                    expect =><<'EOF',
Before Request
Before Component /plugins/two_plugins
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m

Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m

Component A Finish
After Component /plugins/support/A.m
After Component /plugins/two_plugins
After Request
EOF
                  );

  $group->add_test( name => 'plugin_ordering',
                    description => 'make sure plugins are called in reverse order when ending',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestAllCalls','HTML::Mason::Plugin::TestBeforeAndAfterRequest', 'HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
                    },
                    component => '<& support/A.m &>',
                    expect =><<'EOF',
AllCalls Request Start on: /plugins/plugin_ordering
Before Request
AllCalls Before Component /plugins/plugin_ordering
Before Component /plugins/plugin_ordering
AllCalls Before Component /plugins/support/A.m
Before Component /plugins/support/A.m
Component A Start
AllCalls Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
AllCalls After Component /plugins/support/B.m

AllCalls Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
AllCalls After Component /plugins/support/B.m

Component A Finish
After Component /plugins/support/A.m
AllCalls After Component /plugins/support/A.m
After Component /plugins/plugin_ordering
AllCalls After Component /plugins/plugin_ordering
After Request
AllCalls Request Finish on: /plugins/plugin_ordering
EOF
                  );

#------------------------------------------------------------

  $group->add_test( name => 'two_of_the_same_plugin',
                    description => 'two_of_the_same_plugin',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestBeforeAndAfterComponent', 'HTML::Mason::Plugin::TestBeforeAndAfterComponent'],
                    },
                    component => '<& support/A.m &>',
                    expect =><<'EOF',
Before Component /plugins/two_of_the_same_plugin
Before Component /plugins/two_of_the_same_plugin
Before Component /plugins/support/A.m
Before Component /plugins/support/A.m
Component A Start
Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
After Component /plugins/support/B.m

Before Component /plugins/support/B.m
Before Component /plugins/support/B.m
Component B Start
Component B Finish
After Component /plugins/support/B.m
After Component /plugins/support/B.m

Component A Finish
After Component /plugins/support/A.m
After Component /plugins/support/A.m
After Component /plugins/two_of_the_same_plugin
After Component /plugins/two_of_the_same_plugin
EOF
                    );


  $group->add_test( name => 'reset_each_request',
                    description => 'use the same plugin twice, they should be different objects',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestResetEachRequest', 'HTML::Mason::Plugin::TestResetEachRequest'],
                    },
                    component => '<& support/A.m &>',
                    expect =><<'EOF',
PreRequest: 1 : /plugins/reset_each_request
PreRequest: 1 : /plugins/reset_each_request
PreComponent: 2 : /plugins/reset_each_request
PreComponent: 2 : /plugins/reset_each_request
PreComponent: 3 : /plugins/support/A.m
PreComponent: 3 : /plugins/support/A.m
Component A Start
PreComponent: 4 : /plugins/support/B.m
PreComponent: 4 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 5 : /plugins/support/B.m
PostComponent: 5 : /plugins/support/B.m

PreComponent: 6 : /plugins/support/B.m
PreComponent: 6 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 7 : /plugins/support/B.m
PostComponent: 7 : /plugins/support/B.m

Component A Finish
PostComponent: 8 : /plugins/support/A.m
PostComponent: 8 : /plugins/support/A.m
PostComponent: 9 : /plugins/reset_each_request
PostComponent: 9 : /plugins/reset_each_request
PostRequest: 10 : /plugins/reset_each_request
PostRequest: 10 : /plugins/reset_each_request
EOF
                    );
  

#------------------------------------------------------------

  $group->add_test( name => 'error_on_start_request',
                    description => 'a plugin that dies',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestErrorStartRequest'],
                    },
                    component => '<& support/A.m &>',
                    expect_error => 'plugin error on start request /plugins/error_on_start_request',
                  );


#------------------------------------------------------------

  $group->add_test( name => 'error_on_end_request',
                    description => 'a plugin that dies',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestErrorEndRequest'],
                    },
                    component => '<& support/A.m &>',
                    expect_error => 'plugin error on end request /plugins/error_on_end_request',
                  );


#------------------------------------------------------------

  $group->add_test( name => 'error_on_start_component',
                    description => 'a plugin that dies',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestErrorStartComponent'],
                    },
                    component => '<& support/A.m &>',
                    expect_error => 'plugin error on start component /plugins/error_on_start_component',
                  );

#------------------------------------------------------------

  $group->add_test( name => 'error_on_end_component',
                    description => 'a plugin that dies',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestErrorEndComponent'],
                    },
                    component => '<& support/A.m &>',
                    expect_error => 'plugin error on end component /plugins/error_on_end_component',
                  );

#------------------------------------------------------------

  $group->add_test( name => 'not_persistent_across_requests',
                    description => 'different plugin for each request',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestResetEachRequest'],
                    },
                    component => '% $m->subexec("support/A.m"); ',
                    expect =><<'EOF',
PreRequest: 1 : /plugins/not_persistent_across_requests
PreComponent: 2 : /plugins/not_persistent_across_requests
PreRequest: 1 : /plugins/support/A.m
PreComponent: 2 : /plugins/support/A.m
Component A Start
PreComponent: 3 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 4 : /plugins/support/B.m

PreComponent: 5 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 6 : /plugins/support/B.m

Component A Finish
PostComponent: 7 : /plugins/support/A.m
PostRequest: 8 : /plugins/support/A.m
PostComponent: 3 : /plugins/not_persistent_across_requests
PostRequest: 4 : /plugins/not_persistent_across_requests
EOF
                  );

#------------------------------------------------------------

  my $PersistentPlugin = HTML::Mason::Plugin::TestResetEachRequest->new();
  $group->add_test( name => 'persistent_across_requests',
                    description => 'same plugin across a subrequest',
                    interp_params => 
                    {
                     plugins => [$PersistentPlugin],
                    },
                    component => '% $m->subexec("support/A.m"); ',
                    expect =><<'EOF',
PreRequest: 1 : /plugins/persistent_across_requests
PreComponent: 2 : /plugins/persistent_across_requests
PreRequest: 3 : /plugins/support/A.m
PreComponent: 4 : /plugins/support/A.m
Component A Start
PreComponent: 5 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 6 : /plugins/support/B.m

PreComponent: 7 : /plugins/support/B.m
Component B Start
Component B Finish
PostComponent: 8 : /plugins/support/B.m

Component A Finish
PostComponent: 9 : /plugins/support/A.m
PostRequest: 10 : /plugins/support/A.m
PostComponent: 11 : /plugins/persistent_across_requests
PostRequest: 12 : /plugins/persistent_across_requests
EOF
                    );

#------------------------------------------------------------

  $group->add_support ( path => '/support/return_numbers',
                        component => <<'EOF',
<%def .five><%perl>return 5;
<%def .six><%perl>return 6;
% return $m->comp('.five') + $m->comp('.six');
EOF
                    );

  $group->add_test( name => 'modify_return_end_component',
                    description => 'an end_component plugin that modifies its return value',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestModifyReturnEndComponent'],
                    },
                    component => '<% $m->comp("support/return_numbers") %>',
                    expect => '44',
                  );

  $group->add_test( name => 'modify_return_end_request',
                    description => 'an end_request plugin that modifies its return value',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestModifyReturnEndRequest'],
                    },
                    component => '<% $m->subexec("support/return_numbers") %>',
                    expect => '22',
                  );

#------------------------------------------------------------

  $group->add_test( name => 'catch_error_end_component',
                    description => 'an end_component plugin that modifies its arguments to trap errors',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestCatchErrorEndComponent'],
                    },
                    component => '<& support/error.m &>',
                    expect => qr{Caught error uh oh},
                  );

  $group->add_test( name => 'catch_error_end_request',
                    description => 'an end_request plugin that modifies its arguments to trap errors',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestCatchErrorEndRequest'],
                    },
                    component => '<& support/error.m &>',
                    expect => qr{Caught error uh oh},
                  );

#------------------------------------------------------------

  $group->add_test( name => 'modify_content_end_request',
                    description => 'modify content at end of request',
                    interp_params => 
                    {
                     plugins => ['HTML::Mason::Plugin::TestEndRequestModifyOutput'],
                    },
                    component => '<%def .something>capitalizedI will be <& .something &>',
                    expect => <<'EOF',
I WILL BE CAPITALIZED
EOF
                  );

  return $group;

}
HTML-Mason-1.59/MANIFEST0000644000175000017500000000544113660015140014260 0ustar  autarchautarch# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.014.
CODE_OF_CONDUCT.md
CONTRIBUTING.md
CREDITS
Changes
INSTALL
LICENSE
MANIFEST
META.json
META.yml
Makefile.PL
README.md
UPGRADE
benchmarks/bench.pl
benchmarks/comps/comp.mas
benchmarks/comps/comp_helper.mas
benchmarks/comps/print.mas
benchmarks/multiple_benches.pl
bin/convert0.6.README
bin/convert0.6.pl
bin/convert0.8.README
bin/convert0.8.pl
bin/mason.pl
cpanfile
dist.ini
eg/MyApp/Mason.pm
eg/MyApp/MasonWithSession.pm
eg/httpd.conf
inc/Pod/Weaver/Section/SeeAlsoMason.pm
lib/HTML/Mason.pm
lib/HTML/Mason/Admin.pod
lib/HTML/Mason/Apache/Request.pm
lib/HTML/Mason/ApacheHandler.pm
lib/HTML/Mason/CGIHandler.pm
lib/HTML/Mason/Cache/BaseCache.pm
lib/HTML/Mason/Compiler.pm
lib/HTML/Mason/Compiler/ToObject.pm
lib/HTML/Mason/Component.pm
lib/HTML/Mason/Component/FileBased.pm
lib/HTML/Mason/Component/Subcomponent.pm
lib/HTML/Mason/ComponentSource.pm
lib/HTML/Mason/Devel.pod
lib/HTML/Mason/Escapes.pm
lib/HTML/Mason/Exceptions.pm
lib/HTML/Mason/FAQ.pod
lib/HTML/Mason/FakeApache.pm
lib/HTML/Mason/Handler.pm
lib/HTML/Mason/Interp.pm
lib/HTML/Mason/Lexer.pm
lib/HTML/Mason/MethodMaker.pm
lib/HTML/Mason/Params.pod
lib/HTML/Mason/Parser.pm
lib/HTML/Mason/Plugin.pm
lib/HTML/Mason/Plugin/Context.pm
lib/HTML/Mason/Request.pm
lib/HTML/Mason/Resolver.pm
lib/HTML/Mason/Resolver/File.pm
lib/HTML/Mason/Resolver/Null.pm
lib/HTML/Mason/Subclassing.pod
lib/HTML/Mason/Tests.pm
lib/HTML/Mason/Tools.pm
lib/HTML/Mason/Utils.pm
live-tests/live/CGIHandler.t
live-tests/live/apache-filter.t
live-tests/live/cgi-no-handler.t
live-tests/live/cgi-with-handler.t
live-tests/live/libapreq-no-handler.t
live-tests/live/libapreq-with-handler.t
live-tests/live/multi-conf.t
live-tests/live/no-config.t
live-tests/live/set-content-type.t
live-tests/live/single-level-server-root.t
live-tests/live/taint.t
samples/README
samples/dump-request
samples/show-env
t/00-report-prereqs.dd
t/00-report-prereqs.t
t/01-syntax.t
t/01a-comp-calls.t
t/02-sections.t
t/02a-filter.t
t/04-misc.t
t/05-request.t
t/05a-stack-corruption.t
t/06-compiler.t
t/06a-compiler_obj.t
t/06b-compiler-named-subs.t
t/06c-compiler-spaces-path.t
t/07-interp.t
t/07a-interp-mcr.t
t/07b-interp-static-source.t
t/09-component.t
t/09a-comp_content.t
t/10-cache.t
t/10a-cache-1.0x.t
t/10b-cache-chi.t
t/11-inherit.t
t/12-taint.t
t/13-errors.t
t/14-cgi.t
t/14a-fake_apache.t
t/15-subclass.t
t/17-print.t
t/18-leak.t
t/19-subrequest.t
t/20-plugins.t
t/21-escapes.t
t/22-path-security.t
t/23-leak2.t
t/24-tools.t
t/25-flush-in-content.t
t/25-log.t
t/lib/Apache/test.pm
t/lib/BadModule.pm
t/lib/LoadTest.pm
t/lib/Mason/ApacheTest.pm
t/run_one_test
t/run_tests
t/single_test.pl
t/taint.comp
weaver.ini
xt/author/mojibake.t
xt/author/no-tabs.t
xt/author/pod-spell.t
xt/author/pod-syntax.t
xt/author/test-version.t
xt/release/meta-json.t
HTML-Mason-1.59/INSTALL0000644000175000017500000000431613660015140014160 0ustar  autarchautarchThis is the Perl distribution HTML-Mason.

Installing HTML-Mason is straightforward.

## Installation with cpanm

If you have cpanm, you only need one line:

    % cpanm HTML::Mason

If it does not have permission to install modules to the current perl, cpanm
will automatically set up and install to a local::lib in your home directory.
See the local::lib documentation (https://metacpan.org/pod/local::lib) for
details on enabling it in your environment.

## Installing with the CPAN shell

Alternatively, if your CPAN shell is set up, you should just be able to do:

    % cpan HTML::Mason

## Manual installation

As a last resort, you can manually install it. Download the tarball, untar it,
install configure prerequisites (see below), then build it:

    % perl Makefile.PL
    % make && make test

Then install it:

    % make install

On Windows platforms, you should use `dmake` or `nmake`, instead of `make`.

If your perl is system-managed, you can create a local::lib in your home
directory to install modules to. For details, see the local::lib documentation:
https://metacpan.org/pod/local::lib

The prerequisites of this distribution will also have to be installed manually. The
prerequisites are listed in one of the files: `MYMETA.yml` or `MYMETA.json` generated
by running the manual build process described above.

## Configure Prerequisites

This distribution requires other modules to be installed before this
distribution's installer can be run.  They can be found under the
"configure_requires" key of META.yml or the
"{prereqs}{configure}{requires}" key of META.json.

## Other Prerequisites

This distribution may require additional modules to be installed after running
Makefile.PL.
Look for prerequisites in the following phases:

* to run make, PHASE = build
* to use the module code itself, PHASE = runtime
* to run tests, PHASE = test

They can all be found in the "PHASE_requires" key of MYMETA.yml or the
"{prereqs}{PHASE}{requires}" key of MYMETA.json.

## Documentation

HTML-Mason documentation is available as POD.
You can run `perldoc` from a shell to read the documentation:

    % perldoc HTML::Mason

For more information on installing Perl modules via CPAN, please see:
https://www.cpan.org/modules/INSTALL.html
HTML-Mason-1.59/dist.ini0000644000175000017500000000256213660015140014574 0ustar  autarchautarchname             = HTML-Mason
author           = Jonathan Swartz 
author           = Dave Rolsky 
author           = Ken Williams 
license          = Perl_5
copyright_year   = 1998
copyright_holder = Jonathan Swartz

version = 1.59

[FileFinder::Filter / SkipApacheHandler]
finder = :InstallModules
skip = lib/HTML/Mason/ApacheHandler.pm

[PkgVersion]
finder = SkipApacheHandler

[@DROLSKY]
dist = HTML-Mason
stopwords_file = .stopwords
use_github_issues = 1
-remove = AutoPrereqs
-remove = BumpVersionAfterRelease
-remove = DROLSKY::TidyAll
-remove = Git::CheckFor::MergeConflicts
-remove = MetaProvides::Package
-remove = Test::CleanNamespaces
-remove = Test::Compile
-remove = Test::CPAN::Changes
-remove = Test::EOL
-remove = Test::Pod::Coverage::Configurable
-remove = Test::Pod::LinkCheck
-remove = Test::Pod::No404s
-remove = Test::Portability
-remove = Test::Synopsis
-remove = Test::TidyAll
-remove = VersionFromMainModule

[MetaNoIndex]
directory = eg
file = lib/HTML/Mason/Tests.pm

[Prereqs / DevelopRequires]
CHI = 0.21
Test::Memory::Cycle = 0

[Prereqs / RuntimeRequires]
Cache::Cache     = 1.00
Class::Container = 0.07
CGI              = 2.46
Exception::Class = 1.15
File::Spec       = 0.8
HTML::Entities   = 0
Log::Any         = 0.08
Params::Validate = 0.70
Scalar::Util     = 1.01

[Prereqs / TestRequires]
Test::Deep = 0
HTML-Mason-1.59/bin/0000755000175000017500000000000013660015140013673 5ustar  autarchautarchHTML-Mason-1.59/bin/mason.pl0000755000175000017500000000401713660015140015352 0ustar  autarchautarch#!/usr/bin/perl

use strict;
use HTML::Mason '1.11';
use File::Basename qw(dirname basename);
use File::Spec ();
use Cwd        ();

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;
    }
}

my $interp = HTML::Mason::Interp->new(%$params);
$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;

        }
        else {
            my $comp = shift;
            return ( \%params, $comp, \@_ );
        }
    }

    die usage();
}

sub usage {
    return <]  [...]
-e : Exclude paths matching  case-insensitive. e.g. "(.gif|.jpg)$"
-h: Display help message and exit
-q: Quiet mode, do not report normal processing of files
-t: Do not actually change files, just report what changes would be made
EOF

my $helpmsg = <comp, \$m->file, etc.) See Commands.pod for
all the conversions to be performed.

2. References to request variable \$REQ are converted to \$m.

All directories will be traversed recursively.  We STRONGLY recommend
that you backup your components, and/or use the -t flag to preview,
before running this program for real.  Files are modified
destructively and no automatic backups are created.
EOF

my $warning = < ) !~ /[Yy]/ );
    }
    my $sub = sub {
        if ( -f $_ && -s _ ) {
            return
                if defined($EXCLUDE) && "$File::Find::dir/$_" =~ /$EXCLUDE/i;
            convert( $_, "$File::Find::dir/$_" );
        }
    };
    find( $sub, @dirs );
}

sub convert {
    my ( $file, $path ) = @_;
    my $buf;
    my $infh = new IO::File $file;
    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] ) };

    #
    # 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" );
        }
    }

    # 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)' ],
    );
    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 );
            }
        }
    }

    # Boilerplate substitutions for methods with arguments
    @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 );
            }
        }
    }

    # 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" );
        }
    }

    # 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, "" );
        }
    }

    #
    # 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" );
        }
    }

    # 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{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);
    }

    foreach my $failure (@failures) {
        print "** Warning: $failure; must fix manually\n";
    }

    print "\n" if ( ( $TEST && @changes ) || @failures );
}

main();
HTML-Mason-1.59/bin/convert0.8.README0000644000175000017500000000111013660015140016451 0ustar  autarchautarchconvert0.8.pl

This utility converts existing components to use new syntax
introduced in Mason 0.8.

1. Old-style mc_commands (mc_comp, mc_file, etc.) are converted to
new-style $m methods ($m->comp, $m->file, etc.) See Commands.pod for
all the conversions to be performed.

2. References to request variable $REQ are converted to $m.

All directories will be traversed recursively.  We STRONGLY recommend
that you backup your components, and/or use the -t flag to preview,
before running this program for real.  Files are modified
destructively and no automatic backups are created.
HTML-Mason-1.59/bin/convert0.6.README0000644000175000017500000000215513660015140016461 0ustar  autarchautarchconvert0.6.pl

This utility converts existing components to use two new syntactic
constructs introduced in Mason 0.6.

1.  Long section names (<%perl_init>, <%perl_args>, etc.) are
converted to short names (<%init>, <%args>, etc.) You have the option
of also standardizing to uppercase (with -u) or lowercase (with -l);
by default the case will be kept the same.

2. Component calls of the form
    <% mc_comp('path', args...) %>
are converted to
    <& path, args... &>
We try to recognize the most common variations; less common ones will
need to be converted manually.

Warning: If you use <% mc_comp(...) %> for components that *return*
HTML rather than outputting it, this will erroneously be converted to
<& &> (which discards the return value). Unfortunately there is no
easy way for us to detect this. Please be aware of this case and QA
your site carefully after conversion.

All directories will be traversed recursively.  We STRONGLY recommend
that you backup your components, and/or use the -t flag to preview,
before running this program for real.  Files are modified
destructively and no automatic backups are created.
HTML-Mason-1.59/bin/convert0.6.pl0000755000175000017500000001311413660015140016137 0ustar  autarchautarch#!/usr/bin/perl -w

use Data::Dumper;
use File::Find;
use Getopt::Std;
use IO::File;
use strict;

my ( $EXCLUDE, $HELP, $LOWER, $QUIET, $TEST, $UPPER );

my $usage = <]  [...]
-e : Exclude paths matching  case-insensitive. e.g. "(.gif|.jpg)$"
-h: Display help message and exit
-l: Write all section names as lowercase (<%init>, etc.)
-q: Quiet mode, do not report normal processing of files
-t: Do not actually change files, just report what changes would be made
-u: Write all section names as uppercase (<%INIT>, etc.)
EOF

my $helpmsg = <, <%perl_args>, etc.) are
converted to short names (<%init>, <%args>, etc.) You have the option
of also standardizing to uppercase (with -u) or lowercase (with -l);
by default the case will be kept the same.

2. Component calls of the form
    <% mc_comp('path', args...) %>
are converted to
    <& path, args... &>
We try to recognize the most common variations; less common ones will
need to be converted manually.

Warning: If you use <% mc_comp(...) %> for components that *return*
HTML rather than outputting it, this will erroneously be converted to
<& &> (which discards the return value). Unfortunately there is no
easy way for us to detect this. Please be aware of this case and QA
your site carefully after conversion.

All directories will be traversed recursively.  We STRONGLY recommend
that you backup your components, and/or use the -t flag to preview,
before running this program for real.  Files are modified
destructively and no automatic backups are created.
EOF

my $warning = < ) !~ /[Yy]/ );
    }
    my $sub = sub {
        if ( -f $_ && -s _ ) {
            return
                if defined($EXCLUDE) && "$File::Find::dir/$_" =~ /$EXCLUDE/i;
            convert( $_, "$File::Find::dir/$_" );
        }
    };
    find( $sub, @dirs );
}

sub convert {
    my ( $file, $path ) = @_;
    my $buf;
    my $infh = new IO::File $file;
    if ( !$infh ) { warn "cannot read $path: $!"; return }
    { local $/ = undef; $buf = <$infh> }

    my $c = 0;
    my @changes;
    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 ) . ">"
            );
        }
    }

    #
    # 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) {
        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);
    }
}

main();
HTML-Mason-1.59/UPGRADE0000644000175000017500000002033213660015140014135 0ustar  autarchautarchUPGRADE GUIDE for Mason

Hints about upgrading to various major revisions of Mason. To be
completely safe, always read carefully through the Changes file and
upgrade first on a test server.

VERSION 1.3x (1.4?)

- The minimum version of mod_perl is now 1.24.


VERSION 1.1x

Installation and Configuration

- *** Don't use PerlFreshRestart! *** Please see the FAQ, which
details a variety of error messages you might get when using
PerlFreshRestart.  Turn it off and check out Apache::Reload instead.

- The HTML::Mason::Parser class no longer exists.  If you were
creating one with the default options in your handler.pl file, you can
remove the Parser-related code entirely.  Otherwise see the
HTML::Mason::Compiler and HTML::Mason::Compiler::ToObject
documentation for more details.

- If you use a handler.pl that creates an Interp object and then
passes that object to the ApacheHandler constructor, this will no
longer work.  Instead, simply pass all of the parameters for both the
Interp and ApacheHandler to the ApacheHandler constructor.

So this:

  my $interp = HTML::Mason::Interp->new( comp_root => ..., data_dir =>... );

  my $ah = HTML::Mason::ApacheHandler->new( interp => $interp );

becomes this:

  my $ah = HTML::Mason::ApacheHandler->new( comp_root => ..., data_dir =>... );

- The use_reload_file parameter has been removed.  See the
documentation on the static_source parameter, which is intended to
provide a similar performance enhancement.

- Previous versions of Mason split the POD documentation into separate
.pod files from the code, which was in .pm files.  Now, these have
been combined into one file, the .pm file.  However, perldoc will look
for a .pod file before a .pm file.

During the install, we try to find these old .pod files and delete
them.  However, if that isn't successful, you may see the old
documentation for the following modules: HTML::Mason::Interp,
HTML::Mason::Request, HTML::Mason::ApacheHandler,
HTML::Mason::Component.  If you are experiencing this problem after
installing this new version of Mason, you will need to delete the old
.pod files manually.

- The taint_check parameter no longer exists in any form.  We
now automatically detect taint mode and act appropriately to untaint
component source and object files.

- The use_autohandlers, use_dhandlers, and
allow_recursive_autohandlers parameters have been removed, and the
autohandler_name and dhandler_name parameters no longer accept undef
as a valid value.

- The top_level_predicate parameter has been removed.  If you would
like to filter requests you can do this via the new prepare_request
method, which will give you a Request object that you can manipulate
before deciding to serve a request.

- The error_mode parameter has been replaced with two parameters,
error_format and error_mode, allowing more control over how errors are
processed.

- The args_method parameter has changed from being an import parameter, as in

  use HTML::Mason::ApacheHandler (args_method => 'mod_perl');

to a regular constructor parameter, as in

  my $ah = HTML::Mason::ApacheHandler->new(args_method => 'mod_perl');

You should preload the Apache::Request or CGI module in your handler
or httpd.conf, in order to save memory.

- The default HTTP argument processor is now Apache::Request instead
of CGI.pm. This entails several differences:

  - Apache::Request treats parameters case-insensitively for purposes
    of grouping. This would  only be a problem if you expect two arguments
    that differ only by case (e.g. "mode" and "MODE").

  - Apache::Request always parses the query string, even for POST requests.

- The out_mode parameter (batch vs. stream) has been replaced with
the autoflush parameter, which is a much simpler version of the same
idea.  See the Request class documentation for details.

- The ApacheHandler module now requires a minimum of mod_perl 1.22
(though using something more up to date is highly recommended).

- The ApacheHandler module will take care of chown'ing files created
during server startup, when needed. If you have a line like

   chown (Apache->server->uid, Apache->server->gid, $interp->files_written);

in your handler.pl, it is now unnecessary (but harmless).

- The MasonMultipleConfig parameter is no longer needed, and will
cause an error if given.  Mason can now figure out for itself whether
or not multiple ApacheHandler objects should be created.

- The debug file feature has been removed, as it could not accurately
support multiple versions of the Apache API. Use Apache::DB to run
your server through the debugger.

- The Previewer feature has been removed, as it relied on specific
internals that were changed. It will hopefully return better and
stronger in a future release.


Data Caching

Data caching has been completely rebuilt on top of Cache::Cache.
This means:

- The syntax of $m->cache and $m->cache_self have changed.  However,
the original API can still be used for a while by setting
data_cache_api to '1.0'.

- Cache files have a different pathname and format; old cache files
can be removed.

- The access_data_cache utility is no longer supported. See
"Accessing a Cache Externally" in the Developer's manual for
instructions on how to replace access_data_cache.


Semantics

- In older versions of Mason, calls to $m->flush_buffer were
ineffective when output needed to go through a <%filter>.  In 1.1x,
the filter may be called multiple times, each time with new output.


Component Syntax

- The "mc_" style commands, deprecated in 0.8, are no longer supported.
You will need to update to $m methods. The utility bin/convert0.8.pl
can help with this.

- The "perl_" prefix for Mason tags (like <%perl_args>), deprecated in 0.6,
is no longer supported. You will need to remove this prefix. The utility
bin/convert0.6.pl can help with this.

- The |h escape flag now uses HTML::Entities::encode instead of just
encoding <, >, ", and &.  This module escapes control and high-ascii
characters properly for ISO-8859-1 pages. However, it will wreak
havoc with different encodings. You can get the 1.0x behavior with

   $ah->interp->set_escape( h => \&HTML::Mason::Escapes::basic_html_escape );

- The backslash character now eliminates a newline at the end of
any line, not just before %-lines and section tags.

- The run_count and first_time component object methods have been
deprecated, as they cannot be implemented reliably (see bug #209).
Use a manual counter variable declared in <%once> instead.

- $m->top_args and $m->top_comp have been renamed to $m->request_args
and $m->request_comp, respectively.  The old method names have been
deprecated but will continue to work for a while.

- The Component class's create_time method has been renamed to
load_time, which better reflects its semantics. create_time is
deprecated but will continue to work for a while.

- The Interp class's time method and current_time parameters are
deprecated but will continue to work for a while.

VERSION 0.85

- Autohandlers are now recursive by default. If your site uses
directory-specific autohandlers depending on the default value of
allow_recursive_autohandlers=0, you must explicitly pass
allow_recursive_autohandlers=>0 when creating the Interp.

- All applicable autohandlers now get a chance to run. If your site
has multiple autohandlers in parent/child directories, you'll likely
get display problems when upgrading (e.g. multiple templates showing
up per page). For a short-term fix, place

    <%flags>
    inherit=>undef
    

in every autohandler. Ideally, in the long-term you'll be able to
make the autohandlers work well together.

- When calling components, base_comp now gets set to the called
components, _unless_ you call a component with a component object or
your component call starts with SELF: or PARENT:.  So a call like
this:

  <& /some/comp, foo => 1 &>

causes the return value of $m->base_comp to be the "/some/comp"
component object inside the "/some/comp" component.  But this:

  <& $some_comp_obj, foo => 1 &>

does not change what $m->base_comp returns.

VERSION 0.8

- Version 0.8 sports a new request API. $m now contains the current
request object, and all mc_ commands have been incorporated into $m
methods. The utility bin/convert0.8.pl converts existing components to
use the new syntax. See Commands.pod for a manual conversion guide and
a list of rare conversion problems.
HTML-Mason-1.59/live-tests/0000755000175000017500000000000013660015140015222 5ustar  autarchautarchHTML-Mason-1.59/live-tests/live/0000755000175000017500000000000013660015140016161 5ustar  autarchautarchHTML-Mason-1.59/live-tests/live/multi-conf.t0000644000175000017500000000042313660015140020422 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest qw( chmod_data_dir );

Mason::ApacheTest->run_tests(
    apache_define => 'multi_config',
    with_handler  => 0,
    test_sets     => [qw( multi_config )],
);
HTML-Mason-1.59/live-tests/live/single-level-server-root.t0000644000175000017500000000040513660015140023220 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest;

Mason::ApacheTest->run_tests(
    apache_define => 'single_level_serverroot',
    with_handler  => 0,
    test_sets     => [qw( standard )],
);
HTML-Mason-1.59/live-tests/live/cgi-with-handler.t0000644000175000017500000000042713660015140021477 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest qw( require_cgi );

require_cgi();

Mason::ApacheTest->run_tests(
    apache_define => 'CGI',
    with_handler  => 1,
    test_sets     => [qw( standard cgi )],
);
HTML-Mason-1.59/live-tests/live/libapreq-no-handler.t0000644000175000017500000000047413660015140022177 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest qw( require_libapreq );

require_libapreq();

Mason::ApacheTest->run_tests(
    apache_define => 'mod_perl_no_handler',
    with_handler  => 0,
    test_sets     => [qw( standard apache_request )],
);
HTML-Mason-1.59/live-tests/live/CGIHandler.t0000644000175000017500000000037313660015140020251 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest;

Mason::ApacheTest->run_tests(
    apache_define => 'CGIHandler',
    with_handler  => 0,
    test_sets     => [qw( cgi_handler )],
);
HTML-Mason-1.59/live-tests/live/taint.t0000644000175000017500000000036313660015140017467 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest;

Mason::ApacheTest->run_tests(
    apache_define => 'taint',
    with_handler  => 0,
    test_sets     => [qw( standard )],
);
HTML-Mason-1.59/live-tests/live/set-content-type.t0000644000175000017500000000046213660015140021572 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest qw( require_libapreq );

require_libapreq();

Mason::ApacheTest->run_tests(
    apache_define => 'set_content_type',
    with_handler  => 0,
    test_sets     => [qw( set_content_type )],
);
HTML-Mason-1.59/live-tests/live/cgi-no-handler.t0000644000175000017500000000044213660015140021135 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest qw( require_cgi );

require_cgi();

Mason::ApacheTest->run_tests(
    apache_define => 'CGI_no_handler',
    with_handler  => 0,
    test_sets     => [qw( standard cgi )],
);
HTML-Mason-1.59/live-tests/live/libapreq-with-handler.t0000644000175000017500000000046113660015140022532 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest qw( require_libapreq );

require_libapreq();

Mason::ApacheTest->run_tests(
    apache_define => 'mod_perl',
    with_handler  => 1,
    test_sets     => [qw( standard apache_request )],
);
HTML-Mason-1.59/live-tests/live/apache-filter.t0000644000175000017500000000052313660015140021052 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest qw( require_libapreq require_apache_filter );

require_libapreq();
require_apache_filter();

Mason::ApacheTest->run_tests(
    apache_define => 'filter_tests',
    with_handler  => 0,
    test_sets     => [qw( filter )],
);
HTML-Mason-1.59/live-tests/live/no-config.t0000644000175000017500000000044313660015140020226 0ustar  autarchautarchuse strict;
use warnings;

use File::Spec;
use lib 'lib', File::Spec->catdir( 't', 'lib' );

use Mason::ApacheTest qw( require_libapreq );

require_libapreq();

Mason::ApacheTest->run_tests(
    apache_define => 'no_config',
    with_handler  => 0,
    test_sets     => [qw( standard )],
);