init III

Perl OTRS/Kernel/cpan-lib/Devel/StackTrace/Frame.pm

@@ -0,0 +1,237 @@
+package Devel::StackTrace::Frame;
+
+use strict;
+use warnings;
+
+our $VERSION = '2.02';
+
+# Create accessor routines
+BEGIN {
+    ## no critic (TestingAndDebugging::ProhibitNoStrict)
+    no strict 'refs';
+    foreach my $f (
+        qw( package filename line subroutine hasargs
+        wantarray evaltext is_require hints bitmask args )
+        ) {
+        next if $f eq 'args';
+        *{$f} = sub { my $s = shift; return $s->{$f} };
+    }
+}
+
+{
+    my @fields = (
+        qw( package filename line subroutine hasargs wantarray
+            evaltext is_require hints bitmask )
+    );
+
+    sub new {
+        my $proto = shift;
+        my $class = ref $proto || $proto;
+
+        my $self = bless {}, $class;
+
+        @{$self}{@fields} = @{ shift() };
+
+        # fixup unix-style paths on win32
+        $self->{filename} = File::Spec->canonpath( $self->{filename} );
+
+        $self->{args} = shift;
+
+        $self->{respect_overload} = shift;
+
+        $self->{max_arg_length} = shift;
+
+        $self->{message} = shift;
+
+        $self->{indent} = shift;
+
+        return $self;
+    }
+}
+
+sub args {
+    my $self = shift;
+
+    return @{ $self->{args} };
+}
+
+sub as_string {
+    my $self  = shift;
+    my $first = shift;
+    my $p     = shift;
+
+    my $sub = $self->subroutine;
+
+    # This code stolen straight from Carp.pm and then tweaked. All
+    # errors are probably my fault  -dave
+    if ($first) {
+        $sub
+            = defined $self->{message}
+            ? $self->{message}
+            : 'Trace begun';
+    }
+    else {
+
+        # Build a string, $sub, which names the sub-routine called.
+        # This may also be "require ...", "eval '...' or "eval {...}"
+        if ( my $eval = $self->evaltext ) {
+            if ( $self->is_require ) {
+                $sub = "require $eval";
+            }
+            else {
+                $eval =~ s/([\\\'])/\\$1/g;
+                $sub = "eval '$eval'";
+            }
+        }
+        elsif ( $sub eq '(eval)' ) {
+            $sub = 'eval {...}';
+        }
+
+        # if there are any arguments in the sub-routine call, format
+        # them according to the format variables defined earlier in
+        # this file and join them onto the $sub sub-routine string
+        #
+        # We copy them because they're going to be modified.
+        #
+        if ( my @a = $self->args ) {
+            for (@a) {
+
+                # set args to the string "undef" if undefined
+                unless ( defined $_ ) {
+                    $_ = 'undef';
+                    next;
+                }
+
+                # hack!
+                ## no critic (Subroutines::ProtectPrivateSubs)
+                $_ = $self->Devel::StackTrace::_ref_to_string($_)
+                    if ref $_;
+                ## use critic;
+
+                ## no critic (Variables::RequireInitializationForLocalVars)
+                local $SIG{__DIE__};
+                local $@;
+                ## use critic;
+
+                ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
+                eval {
+                    my $max_arg_length
+                        = exists $p->{max_arg_length}
+                        ? $p->{max_arg_length}
+                        : $self->{max_arg_length};
+
+                    if ( $max_arg_length
+                        && length $_ > $max_arg_length ) {
+                        ## no critic (BuiltinFunctions::ProhibitLvalueSubstr)
+                        substr( $_, $max_arg_length ) = '...';
+                    }
+
+                    s/'/\\'/g;
+
+                    # 'quote' arg unless it looks like a number
+                    $_ = "'$_'" unless /^-?[\d.]+$/;
+
+                    # print control/high ASCII chars as 'M-<char>' or '^<char>'
+                    s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+                    s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+                };
+                ## use critic
+
+                if ( my $e = $@ ) {
+                    $_ = $e =~ /malformed utf-8/i ? '(bad utf-8)' : '?';
+                }
+            }
+
+            # append ('all', 'the', 'arguments') to the $sub string
+            $sub .= '(' . join( ', ', @a ) . ')';
+            $sub .= ' called';
+        }
+    }
+
+    # If the user opted into indentation (a la Carp::confess), pre-add a tab
+    my $tab = $self->{indent} && !$first ? "\t" : q{};
+
+    return "${tab}$sub at " . $self->filename . ' line ' . $self->line;
+}
+
+1;
+
+# ABSTRACT: A single frame in a stack trace
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Devel::StackTrace::Frame - A single frame in a stack trace
+
+=head1 VERSION
+
+version 2.02
+
+=head1 DESCRIPTION
+
+See L<Devel::StackTrace> for details.
+
+=for Pod::Coverage new
+
+=head1 METHODS
+
+See Perl's C<caller> documentation for more information on what these
+methods return.
+
+=head2 $frame->package
+
+=head2 $frame->filename
+
+=head2 $frame->line
+
+=head2 $frame->subroutine
+
+=head2 $frame->hasargs
+
+=head2 $frame->wantarray
+
+=head2 $frame->evaltext
+
+Returns undef if the frame was not part of an eval.
+
+=head2 $frame->is_require
+
+Returns undef if the frame was not part of a require.
+
+=head2 $frame->args
+
+Returns the arguments passed to the frame. Note that any arguments that are
+references are returned as references, not copies.
+
+=head2 $frame->hints
+
+=head2 $frame->bitmask
+
+=head2 $frame->as_string
+
+Returns a string containing a description of the frame.
+
+=head1 SUPPORT
+
+Bugs may be submitted through L<https://github.com/houseabsolute/Devel-StackTrace/issues>.
+
+I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
+
+=head1 AUTHOR
+
+Dave Rolsky <autarch@urth.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2000 - 2016 by David Rolsky.
+
+This is free software, licensed under:
+
+  The Artistic License 2.0 (GPL Compatible)
+
+=cut