diff options
Diffstat (limited to 'perllib')
| -rw-r--r-- | perllib/Catalyst/Engine.pm | 738 | ||||
| -rw-r--r-- | perllib/Catalyst/Log.pm | 329 | ||||
| -rw-r--r-- | perllib/FixMyStreet.pm | 1 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App.pm | 3 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App/Controller/Dashboard.pm | 3 | ||||
| -rw-r--r-- | perllib/FixMyStreet/App/Controller/Reports.pm | 2 | ||||
| -rw-r--r-- | perllib/FixMyStreet/Cobrand/Bromley.pm | 2 | ||||
| -rw-r--r-- | perllib/FixMyStreet/DB/RABXColumn.pm | 18 | ||||
| -rw-r--r-- | perllib/FixMyStreet/DB/ResultSet/Problem.pm | 2 | ||||
| -rw-r--r-- | perllib/FixMyStreet/Email.pm | 3 | ||||
| -rw-r--r-- | perllib/FixMyStreet/Script/Alerts.pm | 1 | ||||
| -rw-r--r-- | perllib/FixMyStreet/TestAppProve.pm | 2 | ||||
| -rw-r--r-- | perllib/FixMyStreet/TestMech.pm | 2 | ||||
| -rw-r--r-- | perllib/Template/Document.pm | 539 |
14 files changed, 18 insertions, 1627 deletions
diff --git a/perllib/Catalyst/Engine.pm b/perllib/Catalyst/Engine.pm deleted file mode 100644 index 236713976..000000000 --- a/perllib/Catalyst/Engine.pm +++ /dev/null @@ -1,738 +0,0 @@ -package Catalyst::Engine; - -use Moose; -with 'MooseX::Emulate::Class::Accessor::Fast'; - -use CGI::Simple::Cookie; -use Data::Dump qw/dump/; -use Errno 'EWOULDBLOCK'; -use HTML::Entities; -use HTTP::Body; -use HTTP::Headers; -use URI::QueryParam; -use Plack::Loader; -use Catalyst::EngineLoader; -use Encode (); -use utf8; - -use namespace::clean -except => 'meta'; - -# Amount of data to read from input on each pass -our $CHUNKSIZE = 64 * 1024; - -# XXX - this is only here for compat, do not use! -has env => ( is => 'rw', writer => '_set_env' ); -my $WARN_ABOUT_ENV = 0; -around env => sub { - my ($orig, $self, @args) = @_; - if(@args) { - warn "env as a writer is deprecated, you probably need to upgrade Catalyst::Engine::PSGI" - unless $WARN_ABOUT_ENV++; - return $self->_set_env(@args); - } - return $self->$orig; -}; - -# XXX - Only here for Engine::PSGI compat -sub prepare_connection { - my ($self, $ctx) = @_; - $ctx->request->prepare_connection; -} - -=head1 NAME - -Catalyst::Engine - The Catalyst Engine - -=head1 SYNOPSIS - -See L<Catalyst>. - -=head1 DESCRIPTION - -=head1 METHODS - - -=head2 $self->finalize_body($c) - -Finalize body. Prints the response output. - -=cut - -sub finalize_body { - my ( $self, $c ) = @_; - my $body = $c->response->body; - no warnings 'uninitialized'; - if ( blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) { - my $got; - do { - $got = read $body, my ($buffer), $CHUNKSIZE; - $got = 0 unless $self->write( $c, $buffer ); - } while $got > 0; - - close $body; - } - else { - $self->write( $c, $body ); - } - - my $res = $c->response; - $res->_writer->close; - $res->_clear_writer; - - return; -} - -=head2 $self->finalize_cookies($c) - -Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as -response headers. - -=cut - -sub finalize_cookies { - my ( $self, $c ) = @_; - - my @cookies; - my $response = $c->response; - - foreach my $name (keys %{ $response->cookies }) { - - my $val = $response->cookies->{$name}; - - my $cookie = ( - blessed($val) - ? $val - : CGI::Simple::Cookie->new( - -name => $name, - -value => $val->{value}, - -expires => $val->{expires}, - -domain => $val->{domain}, - -path => $val->{path}, - -secure => $val->{secure} || 0, - -httponly => $val->{httponly} || 0, - ) - ); - if (!defined $cookie) { - $c->log->warn("undef passed in '$name' cookie value - not setting cookie") - if $c->debug; - next; - } - - push @cookies, $cookie->as_string; - } - - for my $cookie (@cookies) { - $response->headers->push_header( 'Set-Cookie' => $cookie ); - } -} - -=head2 $self->finalize_error($c) - -Output an appropriate error message. Called if there's an error in $c -after the dispatch has finished. Will output debug messages if Catalyst -is in debug mode, or a `please come back later` message otherwise. - -=cut - -sub _dump_error_page_element { - my ($self, $i, $element) = @_; - my ($name, $val) = @{ $element }; - - # This is fugly, but the metaclass is _HUGE_ and demands waaay too much - # scrolling. Suggestions for more pleasant ways to do this welcome. - local $val->{'__MOP__'} = "Stringified: " - . $val->{'__MOP__'} if ref $val eq 'HASH' && exists $val->{'__MOP__'}; - - my $text = encode_entities( dump( $val )); - sprintf <<"EOF", $name, $text; -<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2> -<div id="dump_$i"> - <pre wrap="">%s</pre> -</div> -EOF -} - -sub finalize_error { - my ( $self, $c ) = @_; - - $c->res->content_type('text/html; charset=utf-8'); - my $name = ref($c)->config->{name} || join(' ', split('::', ref $c)); - - # Prevent Catalyst::Plugin::Unicode::Encoding from running. - # This is a little nasty, but it's the best way to be clean whether or - # not the user has an encoding plugin. - - if ($c->can('encoding')) { - $c->{encoding} = ''; - } - - my ( $title, $error, $infos ); - if ( $c->debug ) { - - # For pretty dumps - $error = join '', map { - '<p><code class="error">' - . encode_entities($_) - . '</code></p>' - } @{ $c->error }; - $error ||= 'No output'; - $error = qq{<pre wrap="">$error</pre>}; - $title = $name = "$name on Catalyst $Catalyst::VERSION"; - $name = "<h1>$name</h1>"; - - # Don't show context in the dump - $c->res->_clear_context; - - # Don't show body parser in the dump - $c->req->_clear_body; - - my @infos; - my $i = 0; - for my $dump ( $c->dump_these ) { - push @infos, $self->_dump_error_page_element($i, $dump); - $i++; - } - $infos = join "\n", @infos; - } - else { - $title = $name; - $error = ''; - $infos = <<""; -<pre> -(en) Please come back later -(fr) SVP veuillez revenir plus tard -(de) Bitte versuchen sie es spaeter nocheinmal -(at) Konnten's bitt'schoen spaeter nochmal reinschauen -(no) Vennligst prov igjen senere -(dk) Venligst prov igen senere -(pl) Prosze sprobowac pozniej -(pt) Por favor volte mais tarde -(ru) Попробуйте еще раз позже -(ua) Спробуйте ще раз пізніше -</pre> - - $name = ''; - } - $c->res->body( <<"" ); -<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> -<head> - <meta http-equiv="Content-Language" content="en" /> - <meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> - <title>$title</title> - <script type="text/javascript"> - <!-- - function toggleDump (dumpElement) { - var e = document.getElementById( dumpElement ); - if (e.style.display == "none") { - e.style.display = ""; - } - else { - e.style.display = "none"; - } - } - --> - </script> - <style type="text/css"> - body { - font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana, - Tahoma, Arial, helvetica, sans-serif; - color: #333; - background-color: #eee; - margin: 0px; - padding: 0px; - } - :link, :link:hover, :visited, :visited:hover { - color: #000; - } - div.box { - position: relative; - background-color: #ccc; - border: 1px solid #aaa; - padding: 4px; - margin: 10px; - } - div.error { - background-color: #cce; - border: 1px solid #755; - padding: 8px; - margin: 4px; - margin-bottom: 10px; - } - div.infos { - background-color: #eee; - border: 1px solid #575; - padding: 8px; - margin: 4px; - margin-bottom: 10px; - } - div.name { - background-color: #cce; - border: 1px solid #557; - padding: 8px; - margin: 4px; - } - code.error { - display: block; - margin: 1em 0; - overflow: auto; - } - div.name h1, div.error p { - margin: 0; - } - h2 { - margin-top: 0; - margin-bottom: 10px; - font-size: medium; - font-weight: bold; - text-decoration: underline; - } - h1 { - font-size: medium; - font-weight: normal; - } - /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */ - /* Browser specific (not valid) styles to make preformatted text wrap */ - pre { - white-space: pre-wrap; /* css-3 */ - white-space: -moz-pre-wrap; /* Mozilla, since 1999 */ - white-space: -pre-wrap; /* Opera 4-6 */ - white-space: -o-pre-wrap; /* Opera 7 */ - word-wrap: break-word; /* Internet Explorer 5.5+ */ - } - </style> -</head> -<body> - <div class="box"> - <div class="error">$error</div> - <div class="infos">$infos</div> - <div class="name">$name</div> - </div> -</body> -</html> - - # Trick IE. Old versions of IE would display their own error page instead - # of ours if we'd give it less than 512 bytes. - $c->res->{body} .= ( ' ' x 512 ); - - $c->res->{body} = Encode::encode("UTF-8", $c->res->{body}); - - # Return 500 - $c->res->status(500); -} - -=head2 $self->finalize_headers($c) - -Allows engines to write headers to response - -=cut - -sub finalize_headers { - my ($self, $ctx) = @_; - - $ctx->finalize_headers unless $ctx->response->finalized_headers; - return; -} - -=head2 $self->finalize_uploads($c) - -Clean up after uploads, deleting temp files. - -=cut - -sub finalize_uploads { - my ( $self, $c ) = @_; - - # N.B. This code is theoretically entirely unneeded due to ->cleanup(1) - # on the HTTP::Body object. - my $request = $c->request; - foreach my $key (keys %{ $request->uploads }) { - my $upload = $request->uploads->{$key}; - unlink grep { -e $_ } map { $_->tempname } - (ref $upload eq 'ARRAY' ? @{$upload} : ($upload)); - } - -} - -=head2 $self->prepare_body($c) - -sets up the L<Catalyst::Request> object body using L<HTTP::Body> - -=cut - -sub prepare_body { - my ( $self, $c ) = @_; - - $c->request->prepare_body; -} - -=head2 $self->prepare_body_chunk($c) - -Add a chunk to the request body. - -=cut - -# XXX - Can this be deleted? -sub prepare_body_chunk { - my ( $self, $c, $chunk ) = @_; - - $c->request->prepare_body_chunk($chunk); -} - -=head2 $self->prepare_body_parameters($c) - -Sets up parameters from body. - -=cut - -sub prepare_body_parameters { - my ( $self, $c ) = @_; - - $c->request->prepare_body_parameters; -} - -=head2 $self->prepare_parameters($c) - -Sets up parameters from query and post parameters. -If parameters have already been set up will clear -existing parameters and set up again. - -=cut - -sub prepare_parameters { - my ( $self, $c ) = @_; - - $c->request->_clear_parameters; - return $c->request->parameters; -} - -=head2 $self->prepare_path($c) - -abstract method, implemented by engines. - -=cut - -sub prepare_path { - my ($self, $ctx) = @_; - - my $env = $ctx->request->env; - - my $scheme = $ctx->request->secure ? 'https' : 'http'; - my $host = $env->{HTTP_HOST} || $env->{SERVER_NAME}; - my $port = $env->{SERVER_PORT} || 80; - my $base_path = $env->{SCRIPT_NAME} || "/"; - - # set the request URI - my $path; - if (!$ctx->config->{use_request_uri_for_path}) { - my $path_info = $env->{PATH_INFO}; - if ( exists $env->{REDIRECT_URL} ) { - $base_path = $env->{REDIRECT_URL}; - $base_path =~ s/\Q$path_info\E$//; - } - $path = $base_path . $path_info; - $path =~ s{^/+}{}; - $path =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; - $path =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE - } - else { - my $req_uri = $env->{REQUEST_URI}; - $req_uri =~ s/\?.*$//; - $path = $req_uri; - $path =~ s{^/+}{}; - } - - # Using URI directly is way too slow, so we construct the URLs manually - my $uri_class = "URI::$scheme"; - - # HTTP_HOST will include the port even if it's 80/443 - $host =~ s/:(?:80|443)$//; - - if ($port !~ /^(?:80|443)$/ && $host !~ /:/) { - $host .= ":$port"; - } - - my $query = $env->{QUERY_STRING} ? '?' . $env->{QUERY_STRING} : ''; - my $uri = $scheme . '://' . $host . '/' . $path . $query; - - $ctx->request->uri( (bless \$uri, $uri_class)->canonical ); - - # set the base URI - # base must end in a slash - $base_path .= '/' unless $base_path =~ m{/$}; - - my $base_uri = $scheme . '://' . $host . $base_path; - - $ctx->request->base( bless \$base_uri, $uri_class ); - - return; -} - -=head2 $self->prepare_request($c) - -=head2 $self->prepare_query_parameters($c) - -process the query string and extract query parameters. - -=cut - -sub prepare_query_parameters { - my ($self, $c) = @_; - - my $env = $c->request->env; - my $query_string = exists $env->{QUERY_STRING} - ? $env->{QUERY_STRING} - : ''; - - # Check for keywords (no = signs) - # (yes, index() is faster than a regex :)) - if ( index( $query_string, '=' ) < 0 ) { - $c->request->query_keywords( $self->unescape_uri($query_string) ); - return; - } - - my %query; - - # replace semi-colons - $query_string =~ s/;/&/g; - - my @params = grep { length $_ } split /&/, $query_string; - - for my $item ( @params ) { - - my ($param, $value) - = map { $self->unescape_uri($_) } - split( /=/, $item, 2 ); - - $param = $self->unescape_uri($item) unless defined $param; - - if ( exists $query{$param} ) { - if ( ref $query{$param} ) { - push @{ $query{$param} }, $value; - } - else { - $query{$param} = [ $query{$param}, $value ]; - } - } - else { - $query{$param} = $value; - } - } - $c->request->query_parameters( \%query ); -} - -=head2 $self->prepare_read($c) - -Prepare to read by initializing the Content-Length from headers. - -=cut - -sub prepare_read { - my ( $self, $c ) = @_; - - # Initialize the amount of data we think we need to read - $c->request->_read_length; -} - -=head2 $self->prepare_request(@arguments) - -Populate the context object from the request object. - -=cut - -sub prepare_request { - my ($self, $ctx, %args) = @_; - $ctx->log->psgienv($args{env}) if $ctx->log->can('psgienv'); - $ctx->request->_set_env($args{env}); - $self->_set_env($args{env}); # Nasty back compat! - $ctx->response->_set_response_cb($args{response_cb}); -} - -=head2 $self->prepare_uploads($c) - -=cut - -sub prepare_uploads { - my ( $self, $c ) = @_; - - my $request = $c->request; - return unless $request->_body; - - my $uploads = $request->_body->upload; - my $parameters = $request->parameters; - foreach my $name (keys %$uploads) { - my $files = $uploads->{$name}; - my @uploads; - for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) { - my $headers = HTTP::Headers->new( %{ $upload->{headers} } ); - my $u = Catalyst::Request::Upload->new - ( - size => $upload->{size}, - type => scalar $headers->content_type, - headers => $headers, - tempname => $upload->{tempname}, - filename => $upload->{filename}, - ); - push @uploads, $u; - } - $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0]; - - # support access to the filename as a normal param - my @filenames = map { $_->{filename} } @uploads; - # append, if there's already params with this name - if (exists $parameters->{$name}) { - if (ref $parameters->{$name} eq 'ARRAY') { - push @{ $parameters->{$name} }, @filenames; - } - else { - $parameters->{$name} = [ $parameters->{$name}, @filenames ]; - } - } - else { - $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0]; - } - } -} - -=head2 $self->write($c, $buffer) - -Writes the buffer to the client. - -=cut - -sub write { - my ( $self, $c, $buffer ) = @_; - - $c->response->write($buffer); -} - -=head2 $self->read($c, [$maxlength]) - -Reads from the input stream by calling C<< $self->read_chunk >>. - -Maintains the read_length and read_position counters as data is read. - -=cut - -sub read { - my ( $self, $c, $maxlength ) = @_; - - $c->request->read($maxlength); -} - -=head2 $self->read_chunk($c, \$buffer, $length) - -Each engine implements read_chunk as its preferred way of reading a chunk -of data. Returns the number of bytes read. A return of 0 indicates that -there is no more data to be read. - -=cut - -sub read_chunk { - my ($self, $ctx) = (shift, shift); - return $ctx->request->read_chunk(@_); -} - -=head2 $self->run($app, $server) - -Start the engine. Builds a PSGI application and calls the -run method on the server passed in, which then causes the -engine to loop, handling requests.. - -=cut - -sub run { - my ($self, $app, $psgi, @args) = @_; - # @args left here rather than just a $options, $server for back compat with the - # old style scripts which send a few args, then a hashref - - # They should never actually be used in the normal case as the Plack engine is - # passed in got all the 'standard' args via the loader in the script already. - - # FIXME - we should stash the options in an attribute so that custom args - # like Gitalist's --git_dir are possible to get from the app without stupid tricks. - my $server = pop @args if (scalar @args && blessed $args[-1]); - my $options = pop @args if (scalar @args && ref($args[-1]) eq 'HASH'); - # Back compat hack for applications with old (non Catalyst::Script) scripts to work in FCGI. - if (scalar @args && !ref($args[0])) { - if (my $listen = shift @args) { - $options->{listen} ||= [$listen]; - } - } - if (! $server ) { - $server = Catalyst::EngineLoader->new(application_name => ref($self))->auto(%$options); - # We're not being called from a script, so auto detect what backend to - # run on. This should never happen, as mod_perl never calls ->run, - # instead the $app->handle method is called per request. - $app->log->warn("Not supplied a Plack engine, falling back to engine auto-loader (are your scripts ancient?)") - } - $app->run_options($options); - $server->run($psgi, $options); -} - -=head2 build_psgi_app ($app, @args) - -Builds and returns a PSGI application closure. (Raw, not wrapped in middleware) - -=cut - -sub build_psgi_app { - my ($self, $app, @args) = @_; - - return sub { - my ($env) = @_; - - return sub { - my ($respond) = @_; - confess("Did not get a response callback for writer, cannot continiue") unless $respond; - $app->handle_request(env => $env, response_cb => $respond); - }; - }; -} - -=head2 $self->unescape_uri($uri) - -Unescapes a given URI using the most efficient method available. Engines such -as Apache may implement this using Apache's C-based modules, for example. - -=cut - -sub unescape_uri { - my ( $self, $str ) = @_; - - $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg; - - return $str; -} - -=head2 $self->finalize_output - -<obsolete>, see finalize_body - -=head2 $self->env - -Hash containing environment variables including many special variables inserted -by WWW server - like SERVER_*, REMOTE_*, HTTP_* ... - -Before accessing environment variables consider whether the same information is -not directly available via Catalyst objects $c->request, $c->engine ... - -BEWARE: If you really need to access some environment variable from your Catalyst -application you should use $c->engine->env->{VARNAME} instead of $ENV{VARNAME}, -as in some environments the %ENV hash does not contain what you would expect. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/perllib/Catalyst/Log.pm b/perllib/Catalyst/Log.pm deleted file mode 100644 index d72ee162f..000000000 --- a/perllib/Catalyst/Log.pm +++ /dev/null @@ -1,329 +0,0 @@ -package Catalyst::Log; - -use Moose; -with 'MooseX::Emulate::Class::Accessor::Fast'; - -use Data::Dump; -use Class::MOP (); -use Carp qw/ cluck /; - -our %LEVELS = (); # Levels stored as bit field, ergo debug = 1, warn = 2 etc -our %LEVEL_MATCH = (); # Stored as additive, thus debug = 31, warn = 30 etc - -has level => (is => 'rw'); -has _body => (is => 'rw'); -has abort => (is => 'rw'); -has _psgi_logger => (is => 'rw', predicate => '_has_psgi_logger', clearer => '_clear_psgi_logger'); -has _psgi_errors => (is => 'rw', predicate => '_has_psgi_errors', clearer => '_clear_psgi_errors'); - -sub clear_psgi { - my $self = shift; - $self->_clear_psgi_logger; - $self->_clear_psgi_errors; -} - -sub psgienv { - my ($self, $env) = @_; - - $self->_psgi_logger($env->{'psgix.logger'}) if $env->{'psgix.logger'}; - $self->_psgi_errors($env->{'psgi.errors'}) if $env->{'psgi.errors'}; -} - - -{ - my @levels = qw[ debug info warn error fatal ]; - - my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__); - my $summed_level = 0; - for ( my $i = $#levels ; $i >= 0 ; $i-- ) { - - my $name = $levels[$i]; - - my $level = 1 << $i; - $summed_level |= $level; - - $LEVELS{$name} = $level; - $LEVEL_MATCH{$name} = $summed_level; - - $meta->add_method($name, sub { - my $self = shift; - - if ( $self->level & $level ) { - $self->_log( $name, @_ ); - } - }); - - $meta->add_method("is_$name", sub { - my $self = shift; - return $self->level & $level; - });; - } -} - -around new => sub { - my $orig = shift; - my $class = shift; - my $self = $class->$orig; - - $self->levels( scalar(@_) ? @_ : keys %LEVELS ); - - return $self; -}; - -sub levels { - my ( $self, @levels ) = @_; - $self->level(0); - $self->enable(@levels); -} - -sub enable { - my ( $self, @levels ) = @_; - my $level = $self->level; - for(map { $LEVEL_MATCH{$_} } @levels){ - $level |= $_; - } - $self->level($level); -} - -sub disable { - my ( $self, @levels ) = @_; - my $level = $self->level; - for(map { $LEVELS{$_} } @levels){ - $level &= ~$_; - } - $self->level($level); -} - -our $HAS_DUMPED; -sub _dump { - my $self = shift; - unless ($HAS_DUMPED++) { - cluck("Catalyst::Log::_dump is deprecated and will be removed. Please change to using your own Dumper.\n"); - } - $self->info( Data::Dump::dump(@_) ); -} - -sub _log { - my $self = shift; - my $level = shift; - my $message = join( "\n", @_ ); - if ($self->can('_has_psgi_logger') and $self->_has_psgi_logger) { - $self->_psgi_logger->({ - level => $level, - message => $message, - }); - } else { - $message .= "\n" unless $message =~ /\n$/; - my $body = $self->_body; - $body .= sprintf( "[%s] %s", $level, $message ); - $self->_body($body); - } -} - -sub _flush { - my $self = shift; - if ( $self->abort || !$self->_body ) { - $self->abort(undef); - } - else { - $self->_send_to_log( $self->_body ); - } - $self->_body(undef); -} - -sub _send_to_log { - my $self = shift; - if ($self->can('_has_psgi_errors') and $self->_has_psgi_errors) { - $self->_psgi_errors->print(@_); - } else { - print STDERR @_; - } -} - -# 5.7 compat code. -# Alias _body to body, add a before modifier to warn.. -my $meta = __PACKAGE__->meta; # Calling meta method here fine as we happen at compile time. -$meta->add_method('body', $meta->get_method('_body')); -my %package_hash; # Only warn once per method, per package. - # I haven't provided a way to disable them, patches welcome. -$meta->add_before_method_modifier('body', sub { - my $class = blessed(shift); - $package_hash{$class}++ || do { - warn("Class $class is calling the deprecated method Catalyst::Log->body method,\n" - . "this will be removed in Catalyst 5.81"); - }; -}); -# End 5.70 backwards compatibility hacks. - -no Moose; -__PACKAGE__->meta->make_immutable(inline_constructor => 0); - -1; - -__END__ - -=for stopwords psgienv - -=head1 NAME - -Catalyst::Log - Catalyst Log Class - -=head1 SYNOPSIS - - $log = $c->log; - $log->debug($message); - $log->info($message); - $log->warn($message); - $log->error($message); - $log->fatal($message); - - if ( $log->is_debug ) { - # expensive debugging - } - - -See L<Catalyst>. - -=head1 DESCRIPTION - -This module provides the default, simple logging functionality for Catalyst. -If you want something different set C<< $c->log >> in your application module, -e.g.: - - $c->log( MyLogger->new ); - -Your logging object is expected to provide the interface described here. -Good alternatives to consider are Log::Log4Perl and Log::Dispatch. - -If you want to be able to log arbitrary warnings, you can do something along -the lines of - - $SIG{__WARN__} = sub { MyApp->log->warn(@_); }; - -however this is (a) global, (b) hairy and (c) may have unexpected side effects. -Don't say we didn't warn you. - -=head1 LOG LEVELS - -=head2 debug - - $log->is_debug; - $log->debug($message); - -=head2 info - - $log->is_info; - $log->info($message); - -=head2 warn - - $log->is_warn; - $log->warn($message); - -=head2 error - - $log->is_error; - $log->error($message); - -=head2 fatal - - $log->is_fatal; - $log->fatal($message); - -=head1 METHODS - -=head2 new - -Constructor. Defaults to enable all levels unless levels are provided in -arguments. - - $log = Catalyst::Log->new; - $log = Catalyst::Log->new( 'warn', 'error' ); - -=head2 level - -Contains a bitmask of the currently set log levels. - -=head2 levels - -Set log levels - - $log->levels( 'warn', 'error', 'fatal' ); - -=head2 enable - -Enable log levels - - $log->enable( 'warn', 'error' ); - -=head2 disable - -Disable log levels - - $log->disable( 'warn', 'error' ); - -=head2 is_debug - -=head2 is_error - -=head2 is_fatal - -=head2 is_info - -=head2 is_warn - -Is the log level active? - -=head2 abort - -Should Catalyst emit logs for this request? Will be reset at the end of -each request. - -*NOTE* This method is not compatible with other log apis, so if you plan -to use Log4Perl or another logger, you should call it like this: - - $c->log->abort(1) if $c->log->can('abort'); - -=head2 _send_to_log - - $log->_send_to_log( @messages ); - -This protected method is what actually sends the log information to STDERR. -You may subclass this module and override this method to get finer control -over the log output. - -=head2 psgienv $env - - $log->psgienv($env); - -NOTE: This is not meant for public consumption. - -Set the PSGI environment for this request. This ensures logs will be sent to -the right place. If the environment has a C<psgix.logger>, it will be used. If -not, we will send logs to C<psgi.errors> if that exists. As a last fallback, we -will send to STDERR as before. - -=head2 clear_psgi - -Clears the PSGI environment attributes set by L</psgienv>. - -=head2 meta - -=head1 SEE ALSO - -L<Catalyst>. - -=head1 AUTHORS - -Catalyst Contributors, see Catalyst.pm - -=head1 COPYRIGHT - -This library is free software. You can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -__PACKAGE__->meta->make_immutable; - -1; diff --git a/perllib/FixMyStreet.pm b/perllib/FixMyStreet.pm index d10ce93aa..f698b1610 100644 --- a/perllib/FixMyStreet.pm +++ b/perllib/FixMyStreet.pm @@ -154,7 +154,6 @@ sub dbic_connect_info { my $dbi_args = { AutoCommit => 1, - pg_enable_utf8 => 1, }; my $local_time_zone = local_time_zone(); my $dbic_args = { diff --git a/perllib/FixMyStreet/App.pm b/perllib/FixMyStreet/App.pm index 36f736cd2..aa8d04988 100644 --- a/perllib/FixMyStreet/App.pm +++ b/perllib/FixMyStreet/App.pm @@ -21,7 +21,6 @@ use URI::QueryParam; use Catalyst ( 'Static::Simple', - 'Unicode::Encoding', 'Session', 'Session::Store::DBIC', 'Session::State::Cookie', # FIXME - we're using our own override atm @@ -46,8 +45,6 @@ __PACKAGE__->config( name => 'FixMyStreet::App', - encoding => 'UTF-8', - # Disable deprecated behavior needed by old applications disable_component_resolution_regex_fallback => 1, diff --git a/perllib/FixMyStreet/App/Controller/Dashboard.pm b/perllib/FixMyStreet/App/Controller/Dashboard.pm index bd60f8570..495e47c2a 100644 --- a/perllib/FixMyStreet/App/Controller/Dashboard.pm +++ b/perllib/FixMyStreet/App/Controller/Dashboard.pm @@ -487,9 +487,6 @@ sub generate_csv : Private { } $csv->print($c->response, [ - map { - $_ = encode('UTF-8', $_) if $_; - } @{$hashref}{ @{$c->stash->{csv}->{columns}} }, diff --git a/perllib/FixMyStreet/App/Controller/Reports.pm b/perllib/FixMyStreet/App/Controller/Reports.pm index 49bdce379..b352b049e 100644 --- a/perllib/FixMyStreet/App/Controller/Reports.pm +++ b/perllib/FixMyStreet/App/Controller/Reports.pm @@ -563,7 +563,7 @@ sub load_and_group_problems : Private { my $body = $c->stash->{body}; # Might be undef my $filter = { - order_by => $c->stash->{sort_order}, + order_by => [ $c->stash->{sort_order}, { -desc => 'me.id' } ], rows => $c->cobrand->reports_per_page, }; if ($c->user_exists && $body) { diff --git a/perllib/FixMyStreet/Cobrand/Bromley.pm b/perllib/FixMyStreet/Cobrand/Bromley.pm index 341fb6a30..986836b2f 100644 --- a/perllib/FixMyStreet/Cobrand/Bromley.pm +++ b/perllib/FixMyStreet/Cobrand/Bromley.pm @@ -430,7 +430,7 @@ sub munge_load_and_group_problems { my $params = { map { my $n = $_; s/me\./problem\./; $_ => $where->{$n} } keys %$where }; my @c = $c->model('DB::Comment')->to_body($self->body)->search({ %$params, - 'me.user_id' => { -not_in => [ $c->user->id, $self->body->comment_user_id ] }, + 'me.user_id' => { -not_in => [ $c->user->id, $self->body->comment_user_id || () ] }, 'me.state' => 'confirmed', }, { columns => 'problem_id', diff --git a/perllib/FixMyStreet/DB/RABXColumn.pm b/perllib/FixMyStreet/DB/RABXColumn.pm index d14b48dc8..76eb21030 100644 --- a/perllib/FixMyStreet/DB/RABXColumn.pm +++ b/perllib/FixMyStreet/DB/RABXColumn.pm @@ -52,6 +52,8 @@ set_filtered_column behaviour to not trust the cache. sub rabx_column { my ($class, $col) = @_; + my $data_type = $class->column_info($col)->{data_type}; + # Apply the filtering for this column $class->filter_column( $col => { @@ -59,6 +61,10 @@ sub rabx_column { my $self = shift; my $ser = shift; return undef unless defined $ser; + # Some RABX columns are text, when they should be bytea. For + # these we must re-encode the string returned from the + # database, so that it is decoded again by RABX. + utf8::encode($ser) if $data_type ne 'bytea'; my $h = new IO::String($ser); return RABX::wire_rd($h); }, @@ -68,6 +74,10 @@ sub rabx_column { my $ser = ''; my $h = new IO::String($ser); RABX::wire_wr( $data, $h ); + # Some RABX columns are text, when they should be bytea. For + # these, we must re-decode the string encoded by RABX, so that + # it is encoded again when saved to the db. + utf8::decode($ser) if $data_type ne 'bytea'; return $ser; }, } @@ -77,14 +87,6 @@ sub rabx_column { $RABX_COLUMNS{ _get_class_identifier($class) }{$col} = 1; } -# The underlying column should always be UTF-8 encoded bytes. -sub get_column { - my ($self, $col) = @_; - my $res = $self->next::method ($col); - utf8::encode($res) if $RABX_COLUMNS{_get_class_identifier($self)}{$col} && utf8::is_utf8($res); - return $res; -} - sub set_filtered_column { my ($self, $col, $val) = @_; diff --git a/perllib/FixMyStreet/DB/ResultSet/Problem.pm b/perllib/FixMyStreet/DB/ResultSet/Problem.pm index 37fc34057..dae946816 100644 --- a/perllib/FixMyStreet/DB/ResultSet/Problem.pm +++ b/perllib/FixMyStreet/DB/ResultSet/Problem.pm @@ -273,7 +273,7 @@ sub categories_summary { sub include_comment_counts { my $rs = shift; my $order_by = $rs->{attrs}{order_by}; - return $rs unless ref $order_by eq 'HASH' && $order_by->{-desc} eq 'comment_count'; + return $rs unless ref $order_by eq 'ARRAY' && ref $order_by->[0] eq 'HASH' && $order_by->[0]->{-desc} eq 'comment_count'; $rs->search({}, { '+select' => [ { "" => \'(select count(*) from comment where problem_id=me.id and state=\'confirmed\')', diff --git a/perllib/FixMyStreet/Email.pm b/perllib/FixMyStreet/Email.pm index 2b72b5c63..49098b40d 100644 --- a/perllib/FixMyStreet/Email.pm +++ b/perllib/FixMyStreet/Email.pm @@ -357,8 +357,9 @@ sub construct_email ($) { } } - if ($p->{_attachments_}) { + if (@{$p->{_attachments_}}) { push @$parts, map { _mime_create(%$_) } @{$p->{_attachments_}}; + $overall_type = 'multipart/mixed'; } my $email = Email::MIME->create( diff --git a/perllib/FixMyStreet/Script/Alerts.pm b/perllib/FixMyStreet/Script/Alerts.pm index 55f4b3db5..3d2d784b8 100644 --- a/perllib/FixMyStreet/Script/Alerts.pm +++ b/perllib/FixMyStreet/Script/Alerts.pm @@ -333,7 +333,6 @@ sub _get_address_from_geocode { my $geocode = shift; return '' unless defined $geocode; - utf8::encode($geocode) if utf8::is_utf8($geocode); my $h = new IO::String($geocode); my $data = RABX::wire_rd($h); diff --git a/perllib/FixMyStreet/TestAppProve.pm b/perllib/FixMyStreet/TestAppProve.pm index 0329bcfde..3786efaac 100644 --- a/perllib/FixMyStreet/TestAppProve.pm +++ b/perllib/FixMyStreet/TestAppProve.pm @@ -104,6 +104,8 @@ sub run { my $config_out = $class->get_config({ config_file => $config_file, db_config_file => $db_config_file }); local $ENV{FMS_OVERRIDE_CONFIG} = $config_out; + # Don't warn over use of Regex dispatch type + local $ENV{CATALYST_NOWARN_DEPRECATE} = 1; my $prove = App::Prove->new; $prove->process_args(@ARGV); diff --git a/perllib/FixMyStreet/TestMech.pm b/perllib/FixMyStreet/TestMech.pm index 3ecb13b6a..848025e8a 100644 --- a/perllib/FixMyStreet/TestMech.pm +++ b/perllib/FixMyStreet/TestMech.pm @@ -718,7 +718,7 @@ sub encoded_content { sub content_as_csv { my $self = shift; - open my $data_handle, '<', \$self->content; + open my $data_handle, '<:encoding(utf-8)', \$self->encoded_content; my $csv = Text::CSV->new({ binary => 1 }); my @rows; while (my $row = $csv->getline($data_handle)) { diff --git a/perllib/Template/Document.pm b/perllib/Template/Document.pm deleted file mode 100644 index 8fc66deea..000000000 --- a/perllib/Template/Document.pm +++ /dev/null @@ -1,539 +0,0 @@ -##============================================================= -*-Perl-*- -# -# Template::Document -# -# DESCRIPTION -# Module defining a class of objects which encapsulate compiled -# templates, storing additional block definitions and metadata -# as well as the compiled Perl sub-routine representing the main -# template content. -# -# AUTHOR -# Andy Wardley <abw@wardley.org> -# -# COPYRIGHT -# Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. -# -# This module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -#============================================================================ - -package Template::Document; - -use strict; -use warnings; -use base 'Template::Base'; -use Template::Constants; - -our $VERSION = 2.79; -our $DEBUG = 0 unless defined $DEBUG; -our $ERROR = ''; -our ($COMPERR, $AUTOLOAD, $UNICODE); - -BEGIN { - # UNICODE is supported in versions of Perl from 5.008 onwards - if ($UNICODE = $] > 5.007 ? 1 : 0) { - if ($] > 5.008) { - # utf8::is_utf8() available from Perl 5.8.1 onwards - *is_utf8 = \&utf8::is_utf8; - } - elsif ($] == 5.008) { - # use Encode::is_utf8() for Perl 5.8.0 - require Encode; - *is_utf8 = \&Encode::is_utf8; - } - } -} - - -#======================================================================== -# ----- PUBLIC METHODS ----- -#======================================================================== - -#------------------------------------------------------------------------ -# new(\%document) -# -# Creates a new self-contained Template::Document object which -# encapsulates a compiled Perl sub-routine, $block, any additional -# BLOCKs defined within the document ($defblocks, also Perl sub-routines) -# and additional $metadata about the document. -#------------------------------------------------------------------------ - -sub new { - my ($class, $doc) = @_; - my ($block, $defblocks, $variables, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS VARIABLES METADATA ) }; - $defblocks ||= { }; - $metadata ||= { }; - - # evaluate Perl code in $block to create sub-routine reference if necessary - unless (ref $block) { - local $SIG{__WARN__} = \&catch_warnings; - $COMPERR = ''; - - # DON'T LOOK NOW! - blindly untainting can make you go blind! - $block =~ /(.*)/s; - $block = $1; - - $block = eval $block; - return $class->error($@) - unless defined $block; - } - - # same for any additional BLOCK definitions - @$defblocks{ keys %$defblocks } = - # MORE BLIND UNTAINTING - turn away if you're squeamish - map { - ref($_) - ? $_ - : ( /(.*)/s && eval($1) or return $class->error($@) ) - } values %$defblocks; - - bless { - %$metadata, - _BLOCK => $block, - _DEFBLOCKS => $defblocks, - _VARIABLES => $variables, - _HOT => 0, - }, $class; -} - - -#------------------------------------------------------------------------ -# block() -# -# Returns a reference to the internal sub-routine reference, _BLOCK, -# that constitutes the main document template. -#------------------------------------------------------------------------ - -sub block { - return $_[0]->{ _BLOCK }; -} - - -#------------------------------------------------------------------------ -# blocks() -# -# Returns a reference to a hash array containing any BLOCK definitions -# from the template. The hash keys are the BLOCK nameand the values -# are references to Template::Document objects. Returns 0 (# an empty hash) -# if no blocks are defined. -#------------------------------------------------------------------------ - -sub blocks { - return $_[0]->{ _DEFBLOCKS }; -} - - -#----------------------------------------------------------------------- -# variables() -# -# Returns a reference to a hash of variables used in the template. -# This requires the TRACE_VARS option to be enabled. -#----------------------------------------------------------------------- - -sub variables { - return $_[0]->{ _VARIABLES }; -} - -#------------------------------------------------------------------------ -# process($context) -# -# Process the document in a particular context. Checks for recursion, -# registers the document with the context via visit(), processes itself, -# and then unwinds with a large gin and tonic. -#------------------------------------------------------------------------ - -sub process { - my ($self, $context) = @_; - my $defblocks = $self->{ _DEFBLOCKS }; - my $output; - - - # check we're not already visiting this template - return $context->throw(Template::Constants::ERROR_FILE, - "recursion into '$self->{ name }'") - if $self->{ _HOT } && ! $context->{ RECURSION }; ## RETURN ## - - $context->visit($self, $defblocks); - - $self->{ _HOT } = 1; - eval { - my $block = $self->{ _BLOCK }; - $output = &$block($context); - }; - $self->{ _HOT } = 0; - - $context->leave(); - - die $context->catch($@) - if $@; - - return $output; -} - - -#------------------------------------------------------------------------ -# AUTOLOAD -# -# Provides pseudo-methods for read-only access to various internal -# members. -#------------------------------------------------------------------------ - -sub AUTOLOAD { - my $self = shift; - my $method = $AUTOLOAD; - - $method =~ s/.*:://; - return if $method eq 'DESTROY'; -# my ($pkg, $file, $line) = caller(); -# print STDERR "called $self->AUTOLOAD($method) from $file line $line\n"; - return $self->{ $method }; -} - - -#======================================================================== -# ----- PRIVATE METHODS ----- -#======================================================================== - - -#------------------------------------------------------------------------ -# _dump() -# -# Debug method which returns a string representing the internal state -# of the object. -#------------------------------------------------------------------------ - -sub _dump { - my $self = shift; - my $dblks; - my $output = "$self : $self->{ name }\n"; - - $output .= "BLOCK: $self->{ _BLOCK }\nDEFBLOCKS:\n"; - - if ($dblks = $self->{ _DEFBLOCKS }) { - foreach my $b (keys %$dblks) { - $output .= " $b: $dblks->{ $b }\n"; - } - } - - return $output; -} - - -#======================================================================== -# ----- CLASS METHODS ----- -#======================================================================== - -#------------------------------------------------------------------------ -# as_perl($content) -# -# This method expects a reference to a hash passed as the first argument -# containing 3 items: -# METADATA # a hash of template metadata -# BLOCK # string containing Perl sub definition for main block -# DEFBLOCKS # hash containing further subs for addional BLOCK defs -# It returns a string containing Perl code which, when evaluated and -# executed, will instantiate a new Template::Document object with the -# above data. On error, it returns undef with an appropriate error -# message set in $ERROR. -#------------------------------------------------------------------------ - -sub as_perl { - my ($class, $content) = @_; - my ($block, $defblocks, $metadata) = @$content{ qw( BLOCK DEFBLOCKS METADATA ) }; - - #$block =~ s/\n(?!#line)/\n /g; - $block =~ s/\s+$//; - - $defblocks = join('', map { - my $code = $defblocks->{ $_ }; - # $code =~ s/\n(?!#line)/\n /g; - $code =~ s/\s*$//; - " '$_' => $code,\n"; - } keys %$defblocks); - $defblocks =~ s/\s+$//; - - $metadata = join('', map { - my $x = $metadata->{ $_ }; - $x =~ s/(['\\])/\\$1/g; - " '$_' => '$x',\n"; - } keys %$metadata); - $metadata =~ s/\s+$//; - - return <<EOF -#------------------------------------------------------------------------ -# Compiled template generated by the Template Toolkit version $Template::VERSION -#------------------------------------------------------------------------ - -$class->new({ - METADATA => { -$metadata - }, - BLOCK => $block, - DEFBLOCKS => { -$defblocks - }, -}); -EOF -} - - -#------------------------------------------------------------------------ -# write_perl_file($filename, \%content) -# -# This method calls as_perl() to generate the Perl code to represent a -# compiled template with the content passed as the second argument. -# It then writes this to the file denoted by the first argument. -# -# Returns 1 on success. On error, sets the $ERROR package variable -# to contain an error message and returns undef. -#------------------------------------------------------------------------ - -sub write_perl_file { - my ($class, $file, $content) = @_; - my ($fh, $tmpfile); - - return $class->error("invalid filename: $file") - unless $file =~ /^(.+)$/s; - - eval { - require File::Temp; - require File::Basename; - ($fh, $tmpfile) = File::Temp::tempfile( - DIR => File::Basename::dirname($file) - ); - my $perlcode = $class->as_perl($content) || die $!; - - if ($UNICODE && is_utf8($perlcode)) { - $perlcode = "use utf8;\n\n$perlcode"; - binmode $fh, ":utf8"; - } - print $fh $perlcode; - close($fh); - }; - return $class->error($@) if $@; - return rename($tmpfile, $file) - || $class->error($!); -} - - -#------------------------------------------------------------------------ -# catch_warnings($msg) -# -# Installed as -#------------------------------------------------------------------------ - -sub catch_warnings { - $COMPERR .= join('', @_); -} - - -1; - -__END__ - -=head1 NAME - -Template::Document - Compiled template document object - -=head1 SYNOPSIS - - use Template::Document; - - $doc = Template::Document->new({ - BLOCK => sub { # some perl code; return $some_text }, - DEFBLOCKS => { - header => sub { # more perl code; return $some_text }, - footer => sub { # blah blah blah; return $some_text }, - }, - METADATA => { - author => 'Andy Wardley', - version => 3.14, - } - }) || die $Template::Document::ERROR; - - print $doc->process($context); - -=head1 DESCRIPTION - -This module defines an object class whose instances represent compiled -template documents. The L<Template::Parser> module creates a -C<Template::Document> instance to encapsulate a template as it is compiled -into Perl code. - -The constructor method, L<new()>, expects a reference to a hash array -containing the C<BLOCK>, C<DEFBLOCKS> and C<METADATA> items. - -The C<BLOCK> item should contain a reference to a Perl subroutine or a textual -representation of Perl code, as generated by the L<Template::Parser> module. -This is then evaluated into a subroutine reference using C<eval()>. - -The C<DEFLOCKS> item should reference a hash array containing further named -C<BLOCK>s which may be defined in the template. The keys represent C<BLOCK> -names and the values should be subroutine references or text strings of Perl -code as per the main C<BLOCK> item. - -The C<METADATA> item should reference a hash array of metadata items relevant -to the document. - -The L<process()> method can then be called on the instantiated -C<Template::Document> object, passing a reference to a L<Template::Context> -object as the first parameter. This will install any locally defined blocks -(C<DEFBLOCKS>) in the C<BLOCKS> cache in the context (via a call to -L<visit()|Template::Context#visit()>) so that they may be subsequently -resolved by the context. The main C<BLOCK> subroutine is then executed, -passing the context reference on as a parameter. The text returned from the -template subroutine is then returned by the L<process()> method, after calling -the context L<leave()|Template::Context#leave()> method to permit cleanup and -de-registration of named C<BLOCKS> previously installed. - -An C<AUTOLOAD> method provides access to the C<METADATA> items for the -document. The L<Template::Service> module installs a reference to the main -C<Template::Document> object in the stash as the C<template> variable. This allows -metadata items to be accessed from within templates, including C<PRE_PROCESS> -templates. - -header: - - <html> - <head> - <title>[% template.title %] - </head> - ... - -C<Template::Document> objects are usually created by the L<Template::Parser> -but can be manually instantiated or sub-classed to provide custom -template components. - -=head1 METHODS - -=head2 new(\%config) - -Constructor method which accept a reference to a hash array containing the -structure as shown in this example: - - $doc = Template::Document->new({ - BLOCK => sub { # some perl code; return $some_text }, - DEFBLOCKS => { - header => sub { # more perl code; return $some_text }, - footer => sub { # blah blah blah; return $some_text }, - }, - METADATA => { - author => 'Andy Wardley', - version => 3.14, - } - }) || die $Template::Document::ERROR; - -C<BLOCK> and C<DEFBLOCKS> items may be expressed as references to Perl subroutines -or as text strings containing Perl subroutine definitions, as is generated -by the L<Template::Parser> module. These are evaluated into subroutine references -using C<eval()>. - -Returns a new C<Template::Document> object or C<undef> on error. The -L<error()|Template::Base#error()> class method can be called, or the C<$ERROR> -package variable inspected to retrieve the relevant error message. - -=head2 process($context) - -Main processing routine for the compiled template document. A reference to a -L<Template::Context> object should be passed as the first parameter. The -method installs any locally defined blocks via a call to the context -L<visit()|Template::Context#visit()> method, processes its own template, -(passing the context reference as a parameter) and then calls -L<leave()|Template::Context#leave()> in the context to allow cleanup. - - print $doc->process($context); - -Returns a text string representing the generated output for the template. -Errors are thrown via C<die()>. - -=head2 block() - -Returns a reference to the main C<BLOCK> subroutine. - -=head2 blocks() - -Returns a reference to the hash array of named C<DEFBLOCKS> subroutines. - -=head2 variables() - -Returns a reference to a hash of variables used in the template. -This requires the L<TRACE_VARS|Template::Manual::Config#TRACE_VARS> -option to be enabled. - -=head2 AUTOLOAD - -An autoload method returns C<METADATA> items. - - print $doc->author(); - -=head1 CLASS METHODS - -These methods are used internally. - -=head2 as_perl($content) - -This method generate a Perl representation of the template. - - my $perl = Template::Document->as_perl({ - BLOCK => $main_block, - DEFBLOCKS => { - foo => $foo_block, - bar => $bar_block, - }, - METADATA => { - name => 'my_template', - } - }); - -=head2 write_perl_file(\%config) - -This method is used to write compiled Perl templates to disk. If the -C<COMPILE_EXT> option (to indicate a file extension for saving compiled -templates) then the L<Template::Parser> module calls this subroutine before -calling the L<new()> constructor. At this stage, the parser has a -representation of the template as text strings containing Perl code. We can -write that to a file, enclosed in a small wrapper which will allow us to -susequently C<require()> the file and have Perl parse and compile it into a -C<Template::Document>. Thus we have persistence of compiled templates. - -=head1 INTERNAL FUNCTIONS - -=head2 catch_warnings() - -This is a simple handler used to catch any errors that arise when the -compiled Perl template is first evaluated (that is, evaluated by Perl to -create a template subroutine at compile, rather than the template being -processed at runtime). - -=head2 is_utf8() - -This is mapped to C<utf8::is_utf8> for versions of Perl that have it (> 5.008) -or to C<Encode::is_utf8> for Perl 5.008. Earlier versions of Perl are not -supported. - -=head1 AUTHOR - -Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> - -=head1 COPYRIGHT - -Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. - -This module is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=head1 SEE ALSO - -L<Template>, L<Template::Parser> - -=cut - -# Local Variables: -# mode: perl -# perl-indent-level: 4 -# indent-tabs-mode: nil -# End: -# -# vim: expandtab shiftwidth=4: |