File Coverage

blib/lib/Eidolon/Debug.pm

Criterion	Covered	Total	%
statement	26	47	55.3
branch	4	16	25.0
condition	1	3	33.3
subroutine	5	8	62.5
pod	5	5	100.0
total	41	79	51.9

package Eidolon::Debug;
# ==============================================================================
#
#   Eidolon
#   Copyright (c) 2009, Atma 7
#   ---
#   Eidolon/Debug.pm - debugging facility
#
# ==============================================================================

use warnings;
use strict;

our $VERSION         = "0.02"; # 2009-05-12 05:50:18
my  $console_started = 0;

# ------------------------------------------------------------------------------
# BEGIN()
# package initialization
# ------------------------------------------------------------------------------
BEGIN
{
    $SIG{"__WARN__"} = \&warn;
    $SIG{"__DIE__"}  = \¨
}

# ------------------------------------------------------------------------------
# start_console()
# start debug console
# ------------------------------------------------------------------------------
sub start_console
{
    my $script;

    # print HTTP header
    print "Content-Type: text/html; charset=UTF-8\n\n";

    {
        local $/;
        $script = ;
    }

    print $script;
    $console_started = 1;
}

# ------------------------------------------------------------------------------
# \@ get_stack()
# get call stack
# ------------------------------------------------------------------------------
sub get_stack
{
    my (@stack, $package, $file, $line, $sub, $level);

    # we don't need this function in stack
    $level = 1;

    # walk stack
    while (($package, $file, $line, $sub) = caller($level))
    {
        push @stack,
        {
            "package" => $package,
            "file"    => $file,
            "line"    => $line,
            "sub"     => $sub
        };

        $level++;
    }

    return \@stack;
}

# ------------------------------------------------------------------------------
# print_stack(@$stack)
# print call stack
# ------------------------------------------------------------------------------
sub print_stack
{
    my ($stack, $level, $sublen, $sub);

    $stack = shift;
    $sublen = 0;

    # count fields width
    $sublen = length($_->{"sub"}) > $sublen ? length($_->{"sub"}) : $sublen foreach (@$stack);

    # print stack
    foreach (reverse @$stack)
    {
        printf
        (
            "{ line: '%05d', sub: '%-${sublen}s', file: '%s' },",
            $_->{"line"},
            $sub ? $sub : "main",
            $_->{"file"}
        );

        $sub = $_->{"sub"};
    }
}

# ------------------------------------------------------------------------------
# warn($message)
# warning handler
# ------------------------------------------------------------------------------
sub warn
{
    my ($message, $stack, $phase);

    $message = shift;
    $phase = defined $^S ? "Runtime" : "Compile";

    start_console unless $console_started;

    $message =~ s/[\r\n]//g;
    $message =~ s/'/\\'/g;

    printf "eidolonDebug.addWarning('$phase warning', '$message');";
}

# ------------------------------------------------------------------------------
# die($message)
# die handler
# ------------------------------------------------------------------------------
sub die
{
    my ($message, $stack, $phase);

    $message = shift;
    $phase = defined $^S ? "Runtime" : "Compile";

    # call original die if called from eval block
    CORE::die($message) if (defined $^S && $^S == 1);

    start_console unless $console_started;

    $message =~ s/[\r\n]//g;
    $message =~ s/'/\\'/g;

    print "eidolonDebug.addError('$phase error', '$message', ["; </td>
</tr>

<tr>
<td  class="h" >
<a name="143">143</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> &nbsp; </td>
</tr>

<tr>
<td  class="h" >
<a name="144">144</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     # don't print stack on compile errors </td>
</tr>

<tr>
<td  class="h" >
<a name="145">145</a>
</td>

<td  class="c3" >

1

</td>

<td  class="c0" >
 <a href="blib-lib-Eidolon-Debug-pm--branch.html#145-1"> 
 50
 </a> 
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

12

</td>

<td class="s">     if (defined $^S)  </td>
</tr>

<tr>
<td  class="h" >
<a name="146">146</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     { </td>
</tr>

<tr>
<td  class="h" >
<a name="147">147</a>
</td>

<td  class="c0" >

0

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

0

</td>

<td class="s">         print_stack(get_stack); </td>
</tr>

<tr>
<td  class="h" >
<a name="148">148</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">     } </td>
</tr>

<tr>
<td  class="h" >
<a name="149">149</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> &nbsp; </td>
</tr>

<tr>
<td  class="h" >
<a name="150">150</a>
</td>

<td  class="c3" >

1

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

8

</td>

<td class="s">     print "]);";

    exit;
}

1;

=pod

=head1 NAME

Eidolon::Debug - Eidolon debugging facility.

=head1 SYNOPSIS

In CGI/FCGI gateway of your application (C/C) write:

    use Eidolon::Debug;

=head1 DESCRIPTION

The I package provides an easy way to avoid a confusing
I web server message. It sends HTTP header before
displaying an error, so you don't need to dig web-server's log to find the cause
of the error anymore. Obviously, it will do nothing if error is in your
web-server configuration, so if I message still remains,
check your web-server configuration. Also, this package displays a stack trace
when application dies. It is very useful in application development, so
I is included in applications by default.

This package doesn't depend on any other I package, so you can use it
outside I applications too.

While used, I hooks global C and C subroutines, so be
careful using other packages, that modify or depend on C<$SIG{"__DIE__"}> and
C<$SIG{"__WARN__"}> handlers.

=head1 METHODS

=head2 start_console()

Start a javascript debugging console. Prints a minimal HTTP header and javascript
code, so further error and warning messages could be displayed in nice-looking
form.

=head2 get_stack()

Get subroutine call stack. Returns reference to array of hashrefs, each hashref
stands for one level of the call stack. This hashref contains the following
data:

=over 4

=item * package

Package name, where error has been occured.

=item * file

File name, where error has been occured.

=item * line

Line number, which caused program to die.

=item * sub

Subroutine name, where error has been occured.

=back

=head2 print_stack($stack)

Prints the call stack in nice preformatted table. C<$stack> - reference to
array of call stack hashrefs (result, returned by C subroutine).

=head2 warn($message)

Custom warning handler. C<$message> - warning message to be displayed.

=head2 die($message)

Custom error handler. C<$message> - error message to be displayed.

=head1 SEE ALSO

L, L

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 AUTHOR

Anton Belousov, [e-mail]

=head1 COPYRIGHT

Copyright (c) 2009, Atma 7, L

=cut

__DATA__