view release on metacpan or  search on metacpan

lib/App.pm  view on Meta::CPAN

    $retval;
}

#############################################################################
# info()
#############################################################################

=head2 info()

    * Signature: $ident = App->info();
    * Param:     void
    * Return:    $ident     string
    * Throws:    App::Exception
    * Since:     0.01

Gets version info about the framework.

=cut

sub info {
    &App::sub_entry if ($App::trace);
    my $self = shift;
    my $retval = "App-Context ($App::VERSION)";
    &App::sub_exit($retval) if ($App::trace);
    return($retval);
}

#############################################################################
# Aspect-oriented programming support
#############################################################################
# NOTE: This can be done much more elegantly at the Perl language level,
# but it requires version-specific code.  I created these subroutines so that
# any method that is instrumented with them will enable aspect-oriented
# programming in Perl versions from 5.5.3 to the present.
#############################################################################

my $calldepth = 0;

#############################################################################
# sub_entry()
#############################################################################

=head2 sub_entry()

    * Signature: &App::sub_entry;
    * Signature: &App::sub_entry(@args);
    * Param:     @args        any
    * Return:    void
    * Throws:    none
    * Since:     0.01

This is called at the beginning of a subroutine or method (even before $self
may be shifted off).

=cut

sub sub_entry {
    if ($App::trace) {
        my ($stacklevel, $calling_package, $file, $line, $subroutine, $hasargs, $wantarray, $text);
        $stacklevel = 1;
        ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
        while (defined $subroutine && $subroutine eq "(eval)") {
            $stacklevel++;
            ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
        }
        my ($name, $obj, $class, $package, $sub, $method, $firstarg, $trailer);

        # split subroutine into its "package" and the "sub" within the package
        if ($subroutine =~ /^(.*)::([^:]+)$/) {
            $package = $1;
            $sub = $2;
        }

        # check if it might be a method call rather than a normal subroutine call
        if ($#_ >= 0) {
            $class = ref($_[0]);
            if ($class) {
                $obj = $_[0];
                $method = $sub if ($class ne "ARRAY" && $class ne "HASH");
            }
            else {
                $class = $_[0];
                if ($class =~ /^[A-Z][A-Za-z0-9_:]*$/ && $class->isa($package)) {
                    $method = $sub;  # the sub is a method call on the class
                }
                else {
                    $class = "";     # it wasn't really a class/method
                }
            }
        }

        if (%App::scope) {
            if ($App::scope_exclusive) {
                return if ($App::scope{$package} || $App::scope{"$package.$sub"});
            }
            else {
                return if (!$App::scope{$package} && !$App::scope{"$package.$sub"});
            }
        }

        if ($method) {
            if (ref($obj)) {  # dynamic method, called on an object
                if ($obj->isa("App::Service")) {
                    $text = ("| " x $calldepth) . "+-" . $obj->{name} . "->${method}(";
                }
                else {
                    $text = ("| " x $calldepth) . "+-" . $obj . "->${method}(";
                }
                $trailer = " [$package]";
            }
            else {   # static method, called on a class
                $text = ("| " x $calldepth) . "+-" . "${class}->${method}(";
                $trailer = ($class eq $package) ? "" : " [$package]";
            }
            $firstarg = 1;
        }
        else {
            $text = ("| " x $calldepth) . "+-" . $subroutine . "(";
            $firstarg = 0;
            $trailer = "";
        }
        my ($narg);
        for ($narg = $firstarg; $narg <= $#_; $narg++) {
            $text .= "," if ($narg > $firstarg);

lib/App.pm  view on Meta::CPAN

            }
            elsif (ref($_[$narg]) eq "") {
                $text .= $_[$narg];
            }
            elsif (ref($_[$narg]) eq "ARRAY") {
                $text .= ("[" . join(",", map { defined $_ ? $_ : "undef" } @{$_[$narg]}) . "]");
            }
            elsif (ref($_[$narg]) eq "HASH") {
                $text .= ("{" . join(",", map { defined $_ ? $_ : "undef" } %{$_[$narg]}) . "}");
            }
            else {
                $text .= $_[$narg];
            }
        }
        #$trailer .= " [package=$package sub=$sub subroutine=$subroutine class=$class method=$method]";
        $text .= ")";
        my $trailer_len = length($trailer);
        $text =~ s/\n/\\n/g;
        my $text_len = length($text);
        if ($App::trace_width) {
            if ($text_len + $trailer_len > $App::trace_width) {
                my $len = $App::trace_width - $trailer_len;
                $len = 1 if ($len < 1);
                print $App::DEBUG_FILE substr($text, 0, $len), $trailer, "\n";
            }
            elsif ($App::trace_justify) {
                my $len = $App::trace_width - $trailer_len - $text_len;
                $len = 0 if ($len < 0);  # should never happen
                print $App::DEBUG_FILE $text, ("." x $len), $trailer, "\n";
            }
            else {
                print $App::DEBUG_FILE $text, $trailer, "\n";
            }
        }
        else {
            print $App::DEBUG_FILE $text, $trailer, "\n";
        }
        $calldepth++;
    }
}

#############################################################################
# sub_exit()
#############################################################################

=head2 sub_exit()

    * Signature: &App::sub_exit(@return);
    * Param:     @return      any
    * Return:    void
    * Throws:    none
    * Since:     0.01

This subroutine is called just before you return from a subroutine or method.
=cut

sub sub_exit {
    if ($App::trace) {
        my ($stacklevel, $calling_package, $file, $line, $subroutine, $hasargs, $wantarray, $text);
        $stacklevel = 1;
        ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
        while (defined $subroutine && $subroutine eq "(eval)") {
            $stacklevel++;
            ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
        }

        my ($package, $sub);
        # split subroutine into its "package" and the "sub" within the package
        if ($subroutine =~ /^(.*)::([^:]+)$/) {
            $package = $1;
            $sub = $2;
        }

        return if (%App::scope && !$App::scope{$package} && !$App::scope{"$package.$sub"});

        $calldepth--;
        $text = ("| " x $calldepth) . "+-> $sub()";
        my ($narg, $arg);
        for ($narg = 0; $narg <= $#_; $narg++) {
            $text .= $narg ? "," : " : ";
            $arg = $_[$narg];
            if (! defined $arg) {
                $text .= "undef";
            }
            elsif (ref($arg) eq "") {
                $text .= $arg;
            }
            elsif (ref($arg) eq "ARRAY") {
                $text .= ("[" . join(",", map { defined $_ ? $_ : "undef" } @$arg) . "]");
            }
            elsif (ref($arg) eq "HASH") {
                $text .= ("{" . join(",", map { defined $_ ? $_ : "undef" } %$arg) . "}");
            }
            else {
                $text .= defined $arg ? $arg : "undef";
            }
        }
        $text =~ s/\n/\\n/g;
        if ($App::trace_width && length($text) > $App::trace_width) {
            print $App::DEBUG_FILE substr($text, 0, $App::trace_width), "\n";
        }
        else {
            print $App::DEBUG_FILE $text, "\n";
        }
    }
    return(@_);
}

#############################################################################
# in_debug_scope()
#############################################################################

=head2 in_debug_scope()

    * Signature: &App::in_debug_scope
    * Signature: App->in_debug_scope
    * Param:     <no arg list supplied>
    * Return:    void
    * Throws:    none
    * Since:     0.01

This is called within a subroutine or method in order to see if debug output
should be produced.

  if ($App::debug && &App::in_debug_scope) {
      print "This is debug output\n";
  }

Note: The App::in_debug_scope subroutine also checks $App::debug, but checking
it in your code allows you to skip the subroutine call if you are not debugging.

  if (&App::in_debug_scope) {
      print "This is debug output\n";
  }

=cut

sub in_debug_scope {
    if ($App::debug) {
        my ($stacklevel, $calling_package, $file, $line, $subroutine, $hasargs, $wantarray, $text);
        $stacklevel = 1;
        ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
        while (defined $subroutine && $subroutine eq "(eval)") {
            $stacklevel++;
            ($calling_package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
        }
        my ($package, $sub);

        # split subroutine into its "package" and the "sub" within the package
        if ($subroutine =~ /^(.*)::([^:]+)$/) {
            $package = $1;
            $sub = $2;
        }

        if (%App::scope) {
            if ($App::scope_exclusive) {
                return(undef) if ($App::scope{$package} || $App::scope{"$package.$sub"});
            }
            else {
                return(undef) if (!$App::scope{$package} && !$App::scope{"$package.$sub"});
            }
        }
        return(1);
    }
    return(undef);
}

#############################################################################
# debug_indent()
#############################################################################

=head2 debug_indent()

    * Signature: &App::debug_indent()
    * Signature: App->debug_indent()
    * Param:     void
    * Return:    $indent_str     string
    * Throws:    none
    * Since:     0.01

This subroutine returns the $indent_str string which should be printed
before all debug lines if you wish to line the debug output up with the
nested/indented trace output.

=cut

sub debug_indent {
    my $text = ("| " x $calldepth) . "  * ";
    return($text);
}

=head1 ACKNOWLEDGEMENTS

 * Author:  Stephen Adkins <spadkins@gmail.com>
 * License: This is free software. It is licensed under the same terms as Perl itself.

=head1 SEE ALSO

=cut

1;