aboutsummaryrefslogtreecommitdiffstats
path: root/perllib
diff options
context:
space:
mode:
Diffstat (limited to 'perllib')
-rw-r--r--perllib/Catalyst/Engine.pm738
-rw-r--r--perllib/Catalyst/Log.pm329
-rw-r--r--perllib/FixMyStreet.pm1
-rw-r--r--perllib/FixMyStreet/App.pm3
-rw-r--r--perllib/FixMyStreet/App/Controller/Dashboard.pm3
-rw-r--r--perllib/FixMyStreet/App/Controller/Reports.pm2
-rw-r--r--perllib/FixMyStreet/Cobrand/Bromley.pm2
-rw-r--r--perllib/FixMyStreet/DB/RABXColumn.pm18
-rw-r--r--perllib/FixMyStreet/DB/ResultSet/Problem.pm2
-rw-r--r--perllib/FixMyStreet/Email.pm3
-rw-r--r--perllib/FixMyStreet/Script/Alerts.pm1
-rw-r--r--perllib/FixMyStreet/TestAppProve.pm2
-rw-r--r--perllib/FixMyStreet/TestMech.pm2
-rw-r--r--perllib/Template/Document.pm539
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: