wth.pm

package wth;

# what the heck is going on?

use strict;
use warnings;

use lib '/data/WebGUI/lib';
use lib '/data/WebGUI/t/lib';

use Carp;
use Scalar::Util 'blessed';

use WebGUI::Test;
use WebGUI::Session;
use WebGUI::User;

use WebGUI::Asset;

use Data::Dumper;

# no warnings 'UNIVERSAL::isa';

sub wth {

    my $error_msg = join '', @_;

    # generate a stack trace annotated with asset information and cross referenced to an asset dump

    # some of this was adapted from Carp.pm
    my $mess;
    my $i;
    
    package DB;

    my @asset_footnotes;

    while (1) {

        $i++;

        my %call_info;

        my $line;
    
        @call_info{
          qw(pack file line sub has_args wantarray evaltext is_require)
        } = do { no strict 'refs'; defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i) };
                
        last if ! defined $call_info{pack};
        
        my $sub_name = Carp::get_subname(\%call_info); 

        $call_info{stack_frame} = $i;

        #if ($call_info{has_args}) {
        #  my @args = map {Carp::format_arg($_)} @DB::args;
        #  if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
        #    $#args = $MaxArgNums;
        #    push @args, '...';
        #  }
        #  # Push the args onto the subroutine
        #  $sub_name .= '(' . join (', ', @args) . ')';
        #} 
        $call_info{sub_name} = $sub_name;
    
        if(@DB::args and Scalar::Util::blessed($DB::args[0]) and $DB::args[0]->isa('WebGUI::Asset') ) {
            my $asset = $DB::args[0];
            $call_info{asset_title} = $asset->get('title');
            $call_info{asset_id} = $asset->getId;
            $call_info{asset_class} = ref $asset;
        }
    
        if(length $mess) {
            $line .= "$call_info{stack_frame}: $call_info{sub_name} called at $call_info{file} line $call_info{line}";
        } else {
            $line .= "$call_info{stack_frame}: error ``$error_msg'' in $call_info{file} line $call_info{line}";
        }
        if($call_info{asset_id}) {
            $line .= " AssetID: $call_info{asset_id} Class: $call_info{asset_class} Title: ``$call_info{asset_title}''";
        }

        $call_info{line} = $line;
        push @asset_footnotes, \%call_info if $call_info{asset_id};

        $mess .= $line . "\n";
      
    }

    # return $mess;

    my $session = WebGUI::Test->session;
    # $session->user( { userId => 3 } ); # become root
    my $assets = WebGUI::Asset->getRoot($session)->getLineage(['descendants'], {returnObjects=>1});

    my $tree = { };
    
    for my $asset (@$assets) {
        my $lineage = $asset->get('lineage');
        my @parts = $lineage =~ m/(.{6})/g;
        # warn "asset:  $asset lineage: $lineage parts: @parts";
        my $node = $tree;
        while(@parts) {
            my $part = shift @parts;
            $node->{$part} ||= { };
            $node = $node->{$part};
        }
        # $node->{_asset} =  { id => $asset->getId, title =>  $asset->get('title'), class => ref $asset };
        $node->{_asset} =  [ $asset->getId, $asset->get('title'), ref $asset ];
    }
    
    my $show_tree; $show_tree = sub {
        my $node = shift;
        my @vertical_lines = @{ shift() || [] };
        my $depth= shift || 0;
        my $ret;
        if( my $asset_stuff = $node->{_asset} )  {
            $vertical_lines[-1] = '+-' if @vertical_lines;
            $ret .= join ' ', join('', @vertical_lines),  @$asset_stuff;
            my ($call_info) = grep $_->{asset_id} eq $asset_stuff->[0], @asset_footnotes;
            if($call_info) {
                $ret .= "      <----- $call_info->{line}";
            }
            $ret .= "\n";
            $vertical_lines[-1] = '|  ' if @vertical_lines;
        }
        my @child_nodes = sort { $a cmp $b } grep $_ ne '_asset', keys %$node;
        while (@child_nodes) {
            my $child_node = shift @child_nodes;
            my $bar_continues_on_down = @child_nodes ? '| ' : '  ';
            $ret .= $show_tree->($node->{$child_node}, [ @vertical_lines, $bar_continues_on_down, ]);
        }
        return $ret;
    };

    $mess .= $show_tree->($tree);

    # return $mess;
    die $mess;
   
}

our $MaxArgNums = 3;

1;