The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
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 = <DATA>;
    }

    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 "<script>eidolonDebug.addWarning('$phase warning', '$message');</script>";
}

# ------------------------------------------------------------------------------
# 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 "<script>eidolonDebug.addError('$phase error', '$message', [";

    # don't print stack on compile errors
    if (defined $^S) 
    {
        print_stack(get_stack);
    }

    print "]);</script>";

    exit;
}

1;

=pod

=head1 NAME

Eidolon::Debug - Eidolon debugging facility.

=head1 SYNOPSIS

In CGI/FCGI gateway of your application (C<index.cgi>/C<index.fcgi>) write:

    use Eidolon::Debug;

=head1 DESCRIPTION

The I<Eidolon::Debug> package provides an easy way to avoid a confusing 
I<Internal Server Error> 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<Internal Server Error> 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<Eidolon::Debug> is included in applications by default.

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

While used, I<Eidolon::Debug> hooks global C<die> and C<warn> 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<get_stack()> 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<Eidolon>, L<Eidolon::Application>

=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<lt>abel@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (c) 2009, Atma 7, L<http://www.atma7.com>

=cut

__DATA__
<body>
<div id="eidolon-console" style="background-color: #F0F0F0; border: 1px solid #909090; position: absolute; top: 10px; left: 10px; width: 800px; font-family: Verdana, Tahoma; font-size: 12px; text-align: left;"></div>
<script>
    EidolonConsole = function ()
    {
        this.errors   = [];
        this.warnings = [];
        this.details  = 0;
    }

    EidolonConsole.prototype.addError = function (title, message, stack)
    {
        this.errors.push( { "title": title, "message": message, "stack": stack } );
        this.redraw();
    }

    EidolonConsole.prototype.addWarning = function (title, message)
    {
        this.warnings.push( { "title": title, "message": message } );
        this.redraw();
    }

    EidolonConsole.prototype.redraw = function ()
    {
        var obj, i, html, item, k, frame;

        obj = document.getElementById("eidolon-console");
        html = '<div id="eidolon-title" style="background-color: #7B84B0; color: white; padding: 10px; cursor: pointer;" onclick="eidolonDebug.toggleDetails();"><b>Eidolon::Debug</b> - ' + 
            this.errors.length + ' errors, ' + this.warnings.length + ' warnings</div>';

        html += '<div id="eidolon-details" style="display: none; padding: 10px; color: #606060;"></div>';

        obj.innerHTML = html;
        obj = document.getElementById("eidolon-details");
        html = "";

        for (i = 0; i < this.errors.length; i++)
        {
            item = this.errors[i];
            html += '<div style="border-left: 4px solid red; padding: 0 10px 0 10px; margin-bottom: 10px;"><b>' + item.title + ":</b> " + item.message + 
                    '<div style="font-size: 12px;"><pre>';
            
            for (k = 0; k < item.stack.length; k++)
            {
                frame = item.stack[k];

                if (frame)
                    html += frame.line + " " + frame.sub + " " + frame.file + "\n";
            }

            html += "</pre></div></div>";
        }

        for (i = 0; i < this.warnings.length; i++)
        {
            item = this.warnings[i];
            html += '<div style="border-left: 4px solid #7B84B0; padding: 0 10px 0 10px; margin-bottom: 10px;"><b>' + item.title + ":</b> " + item.message + "</div>";
        }

        obj.innerHTML = html;
    }

    EidolonConsole.prototype.toggleDetails = function ()
    {
        var obj = document.getElementById("eidolon-details");

        if (this.details)
        {
            this.details = 0;
            obj.style.display = "none";
        }
        else
        {
            this.details = 1;
            obj.style.display = "block";
        }
    }

    var eidolonDebug = new EidolonConsole();
</script>