view release on metacpan or  search on metacpan

lib/App/Context.pm  view on Meta::CPAN

    foreach my $event_loop_extension (@{$self->{event_loop_extensions}}) {
        ($obj, $method, $args) = @$event_loop_extension;
        @args = ();
        @args = @$args if ($args);
        $args_str = join(",",@args);
        $state .= sprintf("   %s\n", "$obj->{name}.$method($args_str)");
    }

    &App::sub_exit($state) if ($App::trace);
    return($state);
}

#############################################################################
# dbg()
#############################################################################

=head2 dbg()

The dbg() method is used to check whether a given line of debug output
should be generated.  
It returns true or false (1 or 0).

If all three parameters are specified, this function
returns true only when the global debug level ($App::Context::DEBUG)
is at least equal to $level and when the debug scope
is set to debug this class and method.

    * Signature: $flag = $context->dbg($class,$method,$level);
    * Param:     $class       class   [in]
    * Param:     $method      string  [in]
    * Param:     $level       integer [in]
    * Return:    void
    * Throws:    App::Exception::Context
    * Since:     0.01

    Sample Usage: 

    $context->dbgprint("this is debug output")
        if ($App::DEBUG && $context->dbg(3));

    $context->dbgprint("this is debug output")
        if ($context->dbg(3));

The first usage is functionally identical to the second, but the check
of the global debug level explicitly reduces the runtime overhead to
eliminate any method calls when debugging is not turned on.

=cut

my %debug_scope;

sub dbg {
    my ($self, $level) = @_;
    return 0 if (! $App::DEBUG);
    $level = 1 if (!defined $level);
    return 0 if (defined $level && $App::DEBUG < $level);
    my ($debug_scope, $stacklevel);
    my ($package, $file, $line, $subroutine, $hasargs, $wantarray);
    $debug_scope = (ref($self) eq "") ? \%debug_scope : $self->{debug_scope};
    $stacklevel = 1;
    ($package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
    while (defined $subroutine && $subroutine eq "(eval)") {
        $stacklevel++;
        ($package, $file, $line, $subroutine, $hasargs, $wantarray) = caller($stacklevel);
    }
    return 1 if (! defined $debug_scope);
    return 1 if (! %$debug_scope);
    return 1 if (defined $debug_scope->{$package});
    return 1 if (defined $debug_scope->{$subroutine});
    return 0;
}

#############################################################################
# dbgprint()
#############################################################################

=head2 dbgprint()

The dbgprint() method is used to produce debug output.
The output goes to an output stream which is appropriate for
the runtime context in which it is called.

    * Signature: $flag = $context->dbgprint(@args);
    * Param:     @args        string  [in]
    * Return:    void
    * Throws:    App::Exception::Context
    * Since:     0.01

    Sample Usage: 

    $context->dbgprint("this is debug output")
        if ($App::DEBUG && $context->dbg(3));

=cut

sub dbgprint {
    my $self = shift;
    if (defined $App::options{debug_file}) {
        print $App::DEBUG_FILE $$, ": ", @_, "\n";
    }
    else {
        print STDERR "Debug: ", @_, "\n";
    }
}

#############################################################################
# dbglevel()
#############################################################################

=head2 dbglevel()

The dbglevel() method is used to set the debug level.
Setting the dbglevel to 0 turns off debugging output and is suitable
for production use.  Setting the dbglevel to 1 or higher turns on
increasingly verbose debug output.

    * Signature: $context->dbglevel($dbglevel);
    * Signature: $dbglevel = $context->dbglevel();
    * Param:     $dbglevel   integer
    * Return:    $dbglevel   integer
    * Throws:    App::Exception::Context
    * Since:     0.01

    Sample Usage: