ch13.059_prob_ex13.3

Perl Best Practices the source code

##############################################################################
## Example 13.3 (NOT RECOMMENDED) from Chapter 13 of "Perl Best Practices"  ##
##     Copyright (c) O'Reilly & Associates, 2005. All Rights Reserved.      ##
##  See: http://www.oreilly.com/pub/a/oreilly/ask_tim/2001/codepolicy.html  ##
##############################################################################


#  Example 13-3. Refactoring the X::EOF exception class


# Standard modules...
use strict;
use warnings;
use IO::Prompt;
use Carp;
use English qw( -no_match_vars );
use Data::Alias;
use Readonly;


# Abstract the common behaviours of all exception classes...
package X::Base;
use English qw( -no_match_vars );
 
# Make exception objects stringify to an appropriate string...
use overload (
    q{""} => sub {
        my ($self) = @_;
        return "$self->{message} $self->{caller_location }";
    },
    fallback => 1,
);
 
# Create the base object underlying any exception...
sub new {
    my ($class, $args_ref) = @_;
 
    # Allocate memory for the object and initialize it...
    my %self = %{$args_ref};
 
    # Make sure it has an error message, building one if necessary...
    if (! exists $self{message}) {
        $self{message} = "$class exception thrown";
    }
 
    # Ask Carp::shortmess()where croak() would report the error occurring
    # (but make sure Carp ignores whatever derived class called this 
    #  constructor, by temporarily  marking that class as being "internal" 
    #  and hence invisible to Carp)...
    local $Carp::Internal{caller()} = 1;
    if (!exists $self{caller_location}) {
        $self{caller_location} = Carp::shortmess();
    }
 
    # Add it to the class and send it on its way...
    return bless \%self, $class;
}
 
# Test whether the currently propagating exception is of this type...
sub caught {
    my ($this_class) = @_;
 
    use Scalar::Util qw( blessed );
    return if !blessed $EVAL_ERROR;
    return $EVAL_ERROR->isa($this_class);
}
 
# Define the X::EOF class, inheriting useful behaviours from X::Base...
package X::EOF;
use base qw( X::Base );
 
# Create a X::EOF exception...
sub new {
    my ($class, $args_ref) = @_;
    if (! exists $args_ref->{handle}) {
        $args_ref->{handle} = '(unknown)';
    }
 
    return $class->SUPER::new({ 
        handle   => $args_ref->{handle },
        message  => "Filehandle $args_ref->{handle} at EOF",
    });
}
 
# Give access to the handle that was passed into the constructor...
sub get_handle {
    my ($self) = @_;
    return $self->{handle};
}

use Carp;
croak( X::EOF->new({}) );