Initial Commit

database/perl/vendor/lib/Exception/Class.pm

@@ -0,0 +1,569 @@
+package Exception::Class;
+
+use 5.008001;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.44';
+
+use Exception::Class::Base;
+use Scalar::Util qw( blessed reftype );
+
+our $BASE_EXC_CLASS;
+BEGIN { $BASE_EXC_CLASS ||= 'Exception::Class::Base'; }
+
+our %CLASSES;
+
+sub import {
+    my $class = shift;
+
+    ## no critic (Variables::ProhibitPackageVars)
+    local $Exception::Class::Caller = caller();
+
+    my %c;
+
+    my %needs_parent;
+    while ( my $subclass = shift ) {
+        my $def = ref $_[0] ? shift : {};
+        $def->{isa}
+            = $def->{isa}
+            ? ( ref $def->{isa} ? $def->{isa} : [ $def->{isa} ] )
+            : [];
+
+        $c{$subclass} = $def;
+    }
+
+    # We need to sort by length because if we check for keys in the
+    # Foo::Bar:: stash, this creates a "Bar::" key in the Foo:: stash!
+MAKE_CLASSES:
+    foreach my $subclass ( sort { length $a <=> length $b } keys %c ) {
+        my $def = $c{$subclass};
+
+        # We already made this one.
+        next if $CLASSES{$subclass};
+
+        {
+            ## no critic (TestingAndDebugging::ProhibitNoStrict)
+            no strict 'refs';
+            foreach my $parent ( @{ $def->{isa} } ) {
+                unless ( keys %{"$parent\::"} ) {
+                    $needs_parent{$subclass} = {
+                        parents => $def->{isa},
+                        def     => $def
+                    };
+                    next MAKE_CLASSES;
+                }
+            }
+        }
+
+        $class->_make_subclass(
+            subclass => $subclass,
+            def      => $def || {},
+        );
+    }
+
+    foreach my $subclass ( keys %needs_parent ) {
+
+        # This will be used to spot circular references.
+        my %seen;
+        $class->_make_parents( \%needs_parent, $subclass, \%seen );
+    }
+}
+
+sub _make_parents {
+    my $class    = shift;
+    my $needs    = shift;
+    my $subclass = shift;
+    my $seen     = shift;
+    my $child    = shift;    # Just for error messages.
+
+    ## no critic (TestingAndDebugging::ProhibitNoStrict, TestingAndDebugging::ProhibitProlongedStrictureOverride)
+    no strict 'refs';
+
+    # What if someone makes a typo in specifying their 'isa' param?
+    # This should catch it. Either it's been made because it didn't
+    # have missing parents OR it's in our hash as needing a parent.
+    # If neither of these is true then the _only_ place it is
+    # mentioned is in the 'isa' param for some other class, which is
+    # not a good enough reason to make a new class.
+    die
+        "Class $subclass appears to be a typo as it is only specified in the 'isa' param for $child\n"
+        unless exists $needs->{$subclass}
+        || $CLASSES{$subclass}
+        || keys %{"$subclass\::"};
+
+    foreach my $c ( @{ $needs->{$subclass}{parents} } ) {
+
+        # It's been made
+        next if $CLASSES{$c} || keys %{"$c\::"};
+
+        die "There appears to be some circularity involving $subclass\n"
+            if $seen->{$subclass};
+
+        $seen->{$subclass} = 1;
+
+        $class->_make_parents( $needs, $c, $seen, $subclass );
+    }
+
+    return if $CLASSES{$subclass} || keys %{"$subclass\::"};
+
+    $class->_make_subclass(
+        subclass => $subclass,
+        def      => $needs->{$subclass}{def}
+    );
+}
+
+sub _make_subclass {
+    my $class = shift;
+    my %p     = @_;
+
+    my $subclass = $p{subclass};
+    my $def      = $p{def};
+
+    my $isa;
+    if ( $def->{isa} ) {
+        $isa = ref $def->{isa} ? join q{ }, @{ $def->{isa} } : $def->{isa};
+    }
+    $isa ||= $BASE_EXC_CLASS;
+
+    my $version_name = 'VERSION';
+
+    my $code = <<"EOPERL";
+package $subclass;
+
+use base qw($isa);
+
+our \$$version_name = '1.1';
+
+1;
+
+EOPERL
+
+    if ( $def->{description} ) {
+        ( my $desc = $def->{description} ) =~ s/([\\\'])/\\$1/g;
+        $code .= <<"EOPERL";
+sub description
+{
+    return '$desc';
+}
+EOPERL
+    }
+
+    my @fields;
+    if ( my $fields = $def->{fields} ) {
+        @fields
+            = ref $fields && reftype $fields eq 'ARRAY' ? @$fields : $fields;
+
+        $code
+            .= 'sub Fields { return ($_[0]->SUPER::Fields, '
+            . join( ', ', map {"'$_'"} @fields )
+            . ") }\n\n";
+
+        foreach my $field (@fields) {
+            $code .= sprintf( "sub %s { \$_[0]->{%s} }\n", $field, $field );
+        }
+    }
+
+    if ( my $alias = $def->{alias} ) {
+        ## no critic (Variables::ProhibitPackageVars)
+        die 'Cannot make alias without caller'
+            unless defined $Exception::Class::Caller;
+
+        ## no critic (TestingAndDebugging::ProhibitNoStrict)
+        no strict 'refs';
+        *{"$Exception::Class::Caller\::$alias"}
+            = sub { $subclass->throw(@_) };
+    }
+
+    if ( my $defaults = $def->{defaults} ) {
+        $code
+            .= "sub _defaults { return shift->SUPER::_defaults, our \%_DEFAULTS }\n";
+        ## no critic (TestingAndDebugging::ProhibitNoStrict)
+        no strict 'refs';
+        *{"$subclass\::_DEFAULTS"} = {%$defaults};
+    }
+
+    ## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
+    eval $code;
+    die $@ if $@;
+
+    ( my $filename = "$subclass.pm" ) =~ s{::}{/}g;
+    $INC{$filename} = __FILE__;
+
+    $CLASSES{$subclass} = 1;
+}
+
+sub caught {
+    my $e = $@;
+
+    return $e unless $_[1];
+
+    return unless blessed($e) && $e->isa( $_[1] );
+    return $e;
+}
+
+sub Classes { sort keys %Exception::Class::CLASSES }
+
+1;
+
+# ABSTRACT: A module that allows you to declare real exception classes in Perl
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Exception::Class - A module that allows you to declare real exception classes in Perl
+
+=head1 VERSION
+
+version 1.44
+
+=head1 SYNOPSIS
+
+  use Exception::Class (
+      'MyException',
+
+      'AnotherException' => { isa => 'MyException' },
+
+      'YetAnotherException' => {
+          isa         => 'AnotherException',
+          description => 'These exceptions are related to IPC'
+      },
+
+      'ExceptionWithFields' => {
+          isa    => 'YetAnotherException',
+          fields => [ 'grandiosity', 'quixotic' ],
+          alias  => 'throw_fields',
+      },
+  );
+  use Scalar::Util qw( blessed );
+  use Try::Tiny;
+
+  try {
+      MyException->throw( error => 'I feel funny.' );
+  }
+  catch {
+      die $_ unless blessed $_ && $_->can('rethrow');
+
+      if ( $_->isa('Exception::Class') ) {
+          warn $_->error, "\n", $_->trace->as_string, "\n";
+          warn join ' ', $_->euid, $_->egid, $_->uid, $_->gid, $_->pid, $_->time;
+
+          exit;
+      }
+      elsif ( $_->isa('ExceptionWithFields') ) {
+          if ( $_->quixotic ) {
+              handle_quixotic_exception();
+          }
+          else {
+              handle_non_quixotic_exception();
+          }
+      }
+      else {
+          $_->rethrow;
+      }
+  };
+
+  # without Try::Tiny
+  eval { ... };
+  if ( my $e = Exception::Class->caught ) { ... }
+
+  # use an alias - without parens subroutine name is checked at
+  # compile time
+  throw_fields error => "No strawberry", grandiosity => "quite a bit";
+
+=head1 DESCRIPTION
+
+B<RECOMMENDATION 1>: If you are writing modern Perl code with L<Moose> or
+L<Moo> I highly recommend using L<Throwable> instead of this module.
+
+B<RECOMMENDATION 2>: Whether or not you use L<Throwable>, you should use
+L<Try::Tiny>.
+
+Exception::Class allows you to declare exception hierarchies in your modules
+in a "Java-esque" manner.
+
+It features a simple interface allowing programmers to 'declare' exception
+classes at compile time. It also has a base exception class,
+L<Exception::Class::Base>, that can be easily extended.
+
+It is designed to make structured exception handling simpler and better by
+encouraging people to use hierarchies of exceptions in their applications, as
+opposed to a single catch-all exception class.
+
+This module does not implement any try/catch syntax. Please see the "OTHER
+EXCEPTION MODULES (try/catch syntax)" section for more information on how to
+get this syntax.
+
+You will also want to look at the documentation for L<Exception::Class::Base>,
+which is the default base class for all exception objects created by this
+module.
+
+=for Pod::Coverage     Classes
+    caught
+
+=head1 DECLARING EXCEPTION CLASSES
+
+Importing C<Exception::Class> allows you to automagically create
+L<Exception::Class::Base> subclasses. You can also create subclasses via the
+traditional means of defining your own subclass with C<@ISA>.  These two
+methods may be easily combined, so that you could subclass an exception class
+defined via the automagic import, if you desired this.
+
+The syntax for the magic declarations is as follows:
+
+  'MANDATORY CLASS NAME' => \%optional_hashref
+
+The hashref may contain the following options:
+
+=over 4
+
+=item * isa
+
+This is the class's parent class. If this isn't provided then the class name
+in C<$Exception::Class::BASE_EXC_CLASS> is assumed to be the parent (see
+below).
+
+This parameter lets you create arbitrarily deep class hierarchies.  This can
+be any other L<Exception::Class::Base> subclass in your declaration I<or> a
+subclass loaded from a module.
+
+To change the default exception class you will need to change the value of
+C<$Exception::Class::BASE_EXC_CLASS> I<before> calling C<import>. To do this
+simply do something like this:
+
+  BEGIN { $Exception::Class::BASE_EXC_CLASS = 'SomeExceptionClass'; }
+
+If anyone can come up with a more elegant way to do this please let me know.
+
+CAVEAT: If you want to automagically subclass an L<Exception::Class::Base>
+subclass loaded from a file, then you I<must> compile the class (via use or
+require or some other magic) I<before> you import C<Exception::Class> or
+you'll get a compile time error.
+
+=item * fields
+
+This allows you to define additional attributes for your exception class. Any
+field you define can be passed to the C<throw> or C<new> methods as additional
+parameters for the constructor. In addition, your exception object will have
+an accessor method for the fields you define.
+
+This parameter can be either a scalar (for a single field) or an array
+reference if you need to define multiple fields.
+
+Fields will be inherited by subclasses.
+
+=item * alias
+
+Specifying an alias causes this class to create a subroutine of the specified
+name in the I<caller's> namespace. Calling this subroutine is equivalent to
+calling C<< <class>->throw(@_) >> for the given exception class.
+
+Besides convenience, using aliases also allows for additional compile time
+checking. If the alias is called I<without parentheses>, as in C<throw_fields
+"an error occurred">, then Perl checks for the existence of the
+C<throw_fields> subroutine at compile time. If instead you do C<<
+ExceptionWithFields->throw(...) >>, then Perl checks the class name at
+runtime, meaning that typos may sneak through.
+
+=item * description
+
+Each exception class has a description method that returns a fixed
+string. This should describe the exception I<class> (as opposed to any
+particular exception object). This may be useful for debugging if you start
+catching exceptions you weren't expecting (particularly if someone forgot to
+document them) and you don't understand the error messages.
+
+=back
+
+The C<Exception::Class> magic attempts to detect circular class hierarchies
+and will die if it finds one. It also detects missing links in a chain, for
+example if you declare Bar to be a subclass of Foo and never declare Foo.
+
+=head1 L<Try::Tiny>
+
+If you are interested in adding try/catch/finally syntactic sugar to your code
+then I recommend you check out L<Try::Tiny>. This is a great module that helps
+you ignore some of the weirdness with C<eval> and C<$@>. Here's an example of
+how the two modules work together:
+
+  use Exception::Class ( 'My::Exception' );
+  use Scalar::Util qw( blessed );
+  use Try::Tiny;
+
+  try {
+      might_throw();
+  }
+  catch {
+      if ( blessed $_ && $_->isa('My::Exception') ) {
+          handle_it();
+      }
+      else {
+          die $_;
+      }
+  };
+
+Note that you B<cannot> use C<< Exception::Class->caught >> with L<Try::Tiny>.
+
+=head1 Catching Exceptions Without L<Try::Tiny>
+
+C<Exception::Class> provides some syntactic sugar for catching exceptions in a
+safe manner:
+
+  eval {...};
+
+  if ( my $e = Exception::Class->caught('My::Error') ) {
+      cleanup();
+      do_something_with_exception($e);
+  }
+
+The C<caught> method takes a class name and returns an exception object if the
+last thrown exception is of the given class, or a subclass of that class. If
+it is not given any arguments, it simply returns C<$@>.
+
+You should B<always> make a copy of the exception object, rather than using
+C<$@> directly. This is necessary because if your C<cleanup> function uses
+C<eval>, or calls something which uses it, then C<$@> is overwritten. Copying
+the exception preserves it for the call to C<do_something_with_exception>.
+
+Exception objects also provide a caught method so you can write:
+
+  if ( my $e = My::Error->caught ) {
+      cleanup();
+      do_something_with_exception($e);
+  }
+
+=head2 Uncatchable Exceptions
+
+Internally, the C<caught> method will call C<isa> on the exception object. You
+could make an exception "uncatchable" by overriding C<isa> in that class like
+this:
+
+ package Exception::Uncatchable;
+
+ sub isa { shift->rethrow }
+
+Of course, this only works if you always call C<< Exception::Class->caught >>
+after an C<eval>.
+
+=head1 USAGE RECOMMENDATION
+
+If you're creating a complex system that throws lots of different types of
+exceptions, consider putting all the exception declarations in one place. For
+an app called Foo you might make a C<Foo::Exceptions> module and use that in
+all your code. This module could just contain the code to make
+C<Exception::Class> do its automagic class creation. Doing this allows you to
+more easily see what exceptions you have, and makes it easier to keep track of
+them.
+
+This might look something like this:
+
+  package Foo::Bar::Exceptions;
+
+  use Exception::Class (
+      Foo::Bar::Exception::Senses =>
+          { description => 'sense-related exception' },
+
+      Foo::Bar::Exception::Smell => {
+          isa         => 'Foo::Bar::Exception::Senses',
+          fields      => 'odor',
+          description => 'stinky!'
+      },
+
+      Foo::Bar::Exception::Taste => {
+          isa         => 'Foo::Bar::Exception::Senses',
+          fields      => [ 'taste', 'bitterness' ],
+          description => 'like, gag me with a spoon!'
+      },
+
+      ...
+  );
+
+You may want to create a real module to subclass L<Exception::Class::Base> as
+well, particularly if you want your exceptions to have more methods.
+
+=head2 Subclassing Exception::Class::Base
+
+As part of your usage of C<Exception::Class>, you may want to create your own
+base exception class which subclasses L<Exception::Class::Base>. You should
+feel free to subclass any of the methods documented above. For example, you
+may want to subclass C<new> to add additional information to your exception
+objects.
+
+=head1 Exception::Class FUNCTIONS
+
+The C<Exception::Class> method offers one function, C<Classes>, which is not
+exported. This method returns a list of the classes that have been created by
+calling the C<Exception::Class> C<import> method.  Note that this is I<all>
+the subclasses that have been created, so it may include subclasses created by
+things like CPAN modules, etc. Also note that if you simply define a subclass
+via the normal Perl method of setting C<@ISA> or C<use base>, then your
+subclass will not be included.
+
+=head1 SUPPORT
+
+Bugs may be submitted at L<https://github.com/houseabsolute/Exception-Class/issues>.
+
+I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
+
+=head1 SOURCE
+
+The source code repository for Exception-Class can be found at L<https://github.com/houseabsolute/Exception-Class>.
+
+=head1 DONATIONS
+
+If you'd like to thank me for the work I've done on this module, please
+consider making a "donation" to me via PayPal. I spend a lot of free time
+creating free software, and would appreciate any support you'd care to offer.
+
+Please note that B<I am not suggesting that you must do this> in order for me
+to continue working on this particular software. I will continue to do so,
+inasmuch as I have in the past, for as long as it interests me.
+
+Similarly, a donation made in this way will probably not make me work on this
+software much more, unless I get so many donations that I can consider working
+on free software full time (let's all have a chuckle at that together).
+
+To donate, log into PayPal and send money to autarch@urth.org, or use the
+button at L<http://www.urth.org/~autarch/fs-donation.html>.
+
+=head1 AUTHOR
+
+Dave Rolsky <autarch@urth.org>
+
+=head1 CONTRIBUTORS
+
+=for stopwords Alexander Batyrshin Leon Timmermans Ricardo Signes
+
+=over 4
+
+=item *
+
+Alexander Batyrshin <0x62ash@gmail.com>
+
+=item *
+
+Leon Timmermans <fawaka@gmail.com>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2017 by Dave Rolsky.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+The full text of the license can be found in the
+F<LICENSE> file included with this distribution.
+
+=cut