diff options
| -rw-r--r-- | perllib/Catalyst/Engine.pm | 738 | ||||
| -rw-r--r-- | perllib/Catalyst/Log.pm | 329 |
2 files changed, 1067 insertions, 0 deletions
diff --git a/perllib/Catalyst/Engine.pm b/perllib/Catalyst/Engine.pm new file mode 100644 index 000000000..236713976 --- /dev/null +++ b/perllib/Catalyst/Engine.pm @@ -0,0 +1,738 @@ +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 new file mode 100644 index 000000000..d72ee162f --- /dev/null +++ b/perllib/Catalyst/Log.pm @@ -0,0 +1,329 @@ +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; |