Exception::Warning - Convert simple warn into real exception object

Exception-Warning documentation Contained in the Exception-Warning distribution.

Index

Code Index:

NAME

Top

Exception::Warning - Convert simple warn into real exception object

SYNOPSIS

Top

  # Convert warn into exception and throw it immediately
  use Exception::Warning '%SIG' => 'die';
  eval { warn "Boom!"; };
  print ref $@;        # "Exception::Warning"
  print $@->warning;   # "Boom!"

  # Convert warn into exception without die
  use Exception::Warning '%SIG' => 'warn', verbosity => 4;
  warn "Boom!";   # dumps full stack trace

  # Can be used in local scope only
  use Exception::Warning;
  {
      local $SIG{__WARN__} = \&Exception::Warning::__WARN__;
      warn "Boom!";   # warn via exception
  }
  warn "Boom!";       # standard warn

  # Run Perl with verbose warnings
  $ perl -MException::Warning=%SIG,warn,verbosity=>3 script.pl

  # Run Perl which dies on first warning
  $ perl -MException::Warning=%SIG,die,verbosity=>3 script.pl

  # Run Perl which ignores any warnings
  $ perl -MException::Warning=%SIG,warn,verbosity=>0 script.pl

  # Debugging with increased verbosity
  $ perl -MException::Warning=:debug script.pl

DESCRIPTION

Top

This class extends standard Exception::Base and converts warning into real exception object. The warning message is stored in warning attribute.

INHERITANCE

Top

CONSTANTS

Top

ATTRS : HashRef

Declaration of class attributes as reference to hash.

See Exception::Base for details.

ATTRIBUTES

Top

This class provides new attributes. See Exception::Base for other descriptions.

warning : Str {ro}

Contains the message which is set by $SIG{__WARN__} hook.

message : Str = "Unknown warning"

Contains the message of the exception. This class overrides the default value from Exception::Base class.

string_attributes : ArrayRef[Str] = ["message", "warning"]

Meta-attribute contains the format of string representation of exception object. This class overrides the default value from Exception::Base class.

default_attribute : Str = "warning"

Meta-attribute contains the name of the default attribute. This class overrides the default value from Exception::Base class.

IMPORTS

Top

use Exception::Warning '%SIG';
use Exception::Warning '%SIG' => 'warn';

Changes $SIG{__WARN__} hook to Exception::Warning::__WARN__.

use Exception::Warning '%SIG' => 'die';

Changes $SIG{__WARN__} hook to Exception::Warning::__DIE__ function.

use Exception::Warning ':debug';

Changes $SIG{__WARN__} hook to Exception::Warning::__WARN__ and sets verbosity level to 4 (maximum).

no Exception::Warning '%SIG';

Undefines $SIG{__DIE__} hook.

PERFORMANCE

Top

The Exception::Warning module can change $SIG{__WARN__} hook. It costs a speed for simple warn operation. It was tested against unhooked warn.

  -------------------------------------------------------
  | Module                              |         run/s |
  -------------------------------------------------------
  | undef $SIG{__WARN__}                |      276243/s |
  -------------------------------------------------------
  | $SIG{__WARN__} = sub { }            |      188215/s |
  -------------------------------------------------------
  | Exception::Warning '%SIG'           |        1997/s |
  -------------------------------------------------------
  | Exception::Warning '%SIG', verb.=>0 |       26934/s |
  -------------------------------------------------------

It means that Exception::Warning is significally slower than simple warn. It is usually used only for debugging purposes, so it shouldn't be an important problem.

SEE ALSO

Top

Exception::Base.

BUGS

Top

If you find the bug or want to implement new features, please report it at http://rt.cpan.org/NoAuth/Bugs.html?Dist=Exception-Warning

AUTHOR

Top

Piotr Roszatycki <dexter@cpan.org>

LICENSE

Top

Copyright (C) 2008, 2009 by Piotr Roszatycki <dexter@cpan.org>.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

See http://www.perl.com/perl/misc/Artistic.html

Exception-Warning documentation Contained in the Exception-Warning distribution. 
#!/usr/bin/perl -c

package Exception::Warning;


use 5.006;

use strict;
use warnings;

our $VERSION = '0.0401';



# Extend Exception::Base class
BEGIN {


    my %ATTRS = ();
    my @ATTRS_RO = ();


    push @ATTRS_RO, 'warning';


    $ATTRS{message} = 'Unknown warning';


    $ATTRS{string_attributes} = [ 'message', 'warning' ];


    $ATTRS{default_attribute} = 'warning';

    use Exception::Base 0.21;
    Exception::Base->import(
        'Exception::Warning' => {
            has   => { ro => \@ATTRS_RO },
            %ATTRS,
        },
        '+ignore_package' => [ 'Carp' ],
    );
};


## no critic qw(RequireArgUnpacking)
## no critic qw(RequireCarping)


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

    my @params;

    while (defined $args[0]) {
        my $name = shift @args;
        if ($name eq ':debug') {
            $name = '%SIG';
            @args = ('warn', 'verbosity', 4, @args);
        };
        if ($name eq '%SIG') {
            my $type = 'warn';
            if (defined $args[0] and $args[0] =~ /^(die|warn)$/) {
                $type = shift @args;
            };
            # Handle warn hook
            if ($type eq 'warn') {
                # is 'warn'
                ## no critic qw(RequireLocalizedPunctuationVars)
                $SIG{__WARN__} = \&__WARN__;
            }
            else {
                # must be 'die'
                ## no critic qw(RequireLocalizedPunctuationVars)
                $SIG{__WARN__} = \&__DIE__;
            };
        }
        else {
            # Other parameters goes to SUPER::import
            push @params, $name;
            push @params, shift @args if defined $args[0] and ref $args[0] eq 'HASH';
        };
    };

    if (@params) {
        return $pkg->SUPER::import(@params);
    };

    return 1;
};



sub unimport {
    my $pkg = shift;

    while (my $name = shift @_) {
        if ($name eq '%SIG') {
            # Undef die hook
            ## no critic qw(RequireLocalizedPunctuationVars)
            $SIG{__WARN__} = '';
        };
    };

    return 1;
};


# Warning hook with die
sub __DIE__ {
    if (not ref $_[0]) {
        # Do not recurse on Exception::Died & Exception::Warning
        die $_[0] if $_[0] =~ /^Exception::(Died|Warning): /;

        # Simple warn: recover warning message
        my $message = $_[0];
        $message =~ s/\t\.\.\.caught at (?!.*\bat\b.*).* line \d+( thread \d+)?\.\n?$//s;
        while ($message =~ s/\t\.\.\.propagated at (?!.*\bat\b.*).* line \d+( thread \d+)?\.\n$//s) { };
        $message =~ s/( at (?!.*\bat\b.*).* line \d+( thread \d+)?\.)?\n$//s;

        my $e = __PACKAGE__->new;
        $e->{warning} = $message;
        die $e;
    }
    # Otherwise: throw unchanged exception
    die $_[0];
};


# Warning hook with warn
sub __WARN__ {
    if (not ref $_[0]) {
        # Some optimalization
        return if __PACKAGE__->ATTRS->{verbosity}->{default} == 0;

        # Simple warn: recover warning message
        my $message = $_[0];
        $message =~ s/\t\.\.\.caught at (?!.*\bat\b.*).* line \d+( thread \d+)?\.$//s;
        while ($message =~ s/\t\.\.\.propagated at (?!.*\bat\b.*).* line \d+( thread \d+)?\.\n$//s) { };
        $message =~ s/( at (?!.*\bat\b.*).* line \d+( thread \d+)?\.)?\n$//s;

        my $e = __PACKAGE__->new;
        $e->{warning} = $message;
        warn $e;
    }
    else {
        # Otherwise: throw unchanged exception
        warn $_[0];
    };
    return;
};


1;