CGI-Carp-Throw
1 match

 view release on metacpan or  search on metacpan

lib/CGI/Carp/Throw.pm  view on Meta::CPAN 

package CGI::Carp::Throw;

#####################################################################
# CGI::Carp::Throw
#
# Provide the ability to represent thrown exceptions as user oriented
# messages rather than obvious error messages with technical tracing
# information without losing any of the capabilities for providing
# error tracing from CGI::Carp.
#
#####################################################################

use strict;
use warnings;

use 5.006002;

our $VERSION = '0.04';

use Exporter;
# using !/ToBrowser/ on import doesn't work
use CGI::Carp (
    @CGI::Carp::EXPORT,
    (grep { ! /name=|^wrap$|ToBrowser/ } @CGI::Carp::EXPORT_OK)
);

use base qw(Exporter);

our @EXPORT = (qw(
    throw_browser
), @CGI::Carp::EXPORT);

our @EXPORT_OK = (qw(
    throw_browser_cloaked throw_format_sub
), @CGI::Carp::EXPORT_OK);

our %EXPORT_TAGS = (
    'all' => [ qw(
	throw_browser throw_browser_cloaked throw_format_sub
    ), @CGI::Carp::EXPORT, (grep { ! /\^name/ } @CGI::Carp::EXPORT_OK) ],
    'carp_browser' => [ qw(
        fatalsToBrowser warningsToBrowser throw_browser
    ) ]
);

*CGI::Carp::Throw::warningsToBrowser = *CGI::Carp::warningsToBrowser;

my $final_warn_browser;

#####################################################################
# Need to call CGI::Carp's import in a controlled manner and with
# a controlled environment.
#
# More complicated than I would like but guessing it's reasonably
# robust.
#####################################################################
sub import {
    my $pkg = shift;

    # this section mostly taken from CGI::Carp
    my @routines = grep { ! /^(?:name|:)/ } (@_, @EXPORT);
    my($oldlevel) = $Exporter::ExportLevel;
    $Exporter::ExportLevel = 1;
    Exporter::import($pkg,@routines);
    $Exporter::ExportLevel = $oldlevel;
    
    # already exported CGI:Carp methods but need to make sure
    # other CGI::Carp import/Exporter functionality sees its arguments
    my @forward_args = grep
        { /warningsToBrowser/ or not ($CGI::Carp::Throw::{ $_ } or /^:/) }
        @_;

    if (grep { /:(?:DEFAULT|carp_browser)/i } @_) {
        $final_warn_browser = 1;
        foreach my $to_brow (qw(fatalsToBrowser warningsToBrowser)) {
            push @forward_args, $to_brow
                unless (grep { /^$to_brow$/ } @forward_args);
        }
    }
    
    # compatibility with old CGI::Carp
    if ($CGI::Carp::VERSION =~ /(\d*\.?\d*)/ and $1 < 1.24) {
        @forward_args = grep { ! /^name=/ } @forward_args
    }

    # be a bit careful what we might (re?)import to Throw module
    local @CGI::Carp::EXPORT = ();
    CGI::Carp::import($pkg, @forward_args);    
}

my $throw_cloaked;

#####################################################################
# Do a little bit of message formatting where important.
# Basically get rid of some lines of confess information that reflect
# internal machinery and might be confusing and add a package marker.
#
# Add <html> <head> and <body> tags if they appear to be missing.
#####################################################################
sub massage_mess {
    my $mess = shift;

    unless ($throw_cloaked) {
        my $confess_mess = CGI::Carp::_longmess;
        $confess_mess =~ s/.*CGI::Carp(?!::Throw::)(?:.*?)line\s+\d*\s*//s;
        $confess_mess =~ s/\s*CGI::Carp::Throw::_throw(?:.*?)line\s+\d*\s*?\n//;
        # make package a variable
        $mess .= '<!-- ' . __PACKAGE__ . " tracing\n$confess_mess-->";
    }
    
    unless ($mess =~ /<\s*html\b/i) {
        unless ($mess =~ /<\s*body\b/i) {
            $mess = "\n<body>\n$mess\n</body>\n";
        }



( run in 1.426 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )