Re^2: ppiwx / wxPPI / wxppixregexp ppixregexplain.pl wxPPIxregexplain.pl PPIx::Regexp::xplain because YAPE::Regex::Explain is dead

[Anonymous Monk]

This version wxPPIxregexplain.pl uses PPIx::Regexp::xplain because YAPE::Regex::Explain is dead; file ppixregexplain.pl needs _desc.pl to add text explanation of regular expressions ... presentation format not the best, its a stalled work in progress (some notes in Re: Parsing and translating Perl Regexes ( PPIx::Regexp::xplain Regexp::Debugger ) )

#!/usr/bin/perl --
use utf8;
use strict;
use warnings;
use PPI;
use PPIx::Regexp;
use Wx 0.86 qw(  );
use Wx::AUI;

Main( @ARGV );
exit( 0 );

sub Main {
    my( @files ) = @_;
    
    @files or @files = ( \"#!/usr/bin/perl --\nuse strict;\nuse warnin
+gs;\nuse utf8;\nprint q{\nud hello is o\x{283}\x{283}\x{1DD}\x{265}\n
+ud o\x{283}\x{283}\x{1DD}\x{265} is hello\n}, 4 + 2 , \"\\n\";;;;\n\n
+qr{a\\s(\\d+)f}i;;\n\ns{a\\s(\\d+)f}{\$1}i;;\n\nm{a\\s(\\d+)f}i;;\n\n
+s{\n    hd_defect-\n    (\n        ([^\\.]+\$)\n        |\n        (?
+:\n            ([^\\.]+)\n            .\n            (.+\$)\n        
+)\n    )\n}{\n    \$3\n    ? uc(\"\$2-\$3\")\n    : uc \$1\n}sex;;;\n
+\n\nprint qx{echo echo}, \"\\n\";;;;\n\nmy \$scalar = 42;\nmy %hash;\
+nmy \@array;\n\nprint <<'SINGLE';\nsingle quoted\nSINGLE\n\nprint <<\
+"DOUBLE\";\ndouble quoted\nDOUBLE\n\nprint <<DOUBLE;\ndouble quoted\n
+DOUBLE\n\nprint <<`BACKTICK`;\necho backticks quoted\nBACKTICK\n\n=he
+ad1 HI\n\n=cut\n\n__END__\n\nthere\n\n=head1 YO\n\n=cut\n\n",,,, );;;
+;;
    
    my $app = Wx::SimpleApp->new ;
    for my $file ( @files ){
        my $frame = MyPP->new;
        $app->SetTopWindow( $frame );
        $frame->CenterOnScreen;
#~         $frame->Maximize(1);
        $frame->Show( 1 );
        $frame->readFile( $file );
        $app->MainLoop();
        $frame->pperspective();
    }
}

package MyPP;

use base qw/ Wx::Frame /;
sub new {
    my($class, @rest ) = @_;
    @rest or @rest = (
        undef, -1, "ppiwx / wxPPI / wxppixregexp ",
        [ -1,  -1 ],
        [ 555, 555 ],
        Wx::wxDEFAULT_FRAME_STYLE() | Wx::wxTAB_TRAVERSAL()
    );
    
    my $frame   = $class->SUPER::new( @rest );


    $frame->{auim} = Wx::AuiManager->new();
    $frame->{auim}->SetManagedWindow( $frame );
    
    my $Left = Wx::Panel->new( $frame, -1 );
    $Left->SetSizer( Wx::BoxSizer->new( Wx::wxHORIZONTAL() ) );
    my $codetext = MakeScintilla( $Left );
    
    $Left->GetSizer->Add( $codetext, 1, Wx::wxEXPAND(), );
    
    my $newLeft = Wx::Panel->new( $frame, -1 );
    my $newRight = Wx::Panel->new( $frame, -1, [ -1, 100 ] );
    $newLeft->SetSizer( Wx::BoxSizer->new( Wx::wxHORIZONTAL() ) );
    $newRight->SetSizer( Wx::BoxSizer->new( Wx::wxHORIZONTAL() ) );

    my $codetree = Wx::TreeCtrl->new(
        $newLeft, -1,
        [ -1, -1 ],
        [ -1, -1 ],
        Wx::wxTR_SINGLE() | Wx::wxTR_DEFAULT_STYLE()
    );
    
    $codetree->SetIndent(0);

    my $treetext = MakeScintilla( $newRight );

    $newLeft->GetSizer->Add( $codetree, 1, Wx::wxEXPAND(), );
    $newRight->GetSizer->Add( $treetext, 1, Wx::wxEXPAND(), );
    $frame->{codetext}    = $codetext;
    $frame->{codetree}    = $codetree;
    $frame->{treetext}    = $treetext;
    
    
    $codetext->SetModEventMask( Wx::wxSTC_MOD_INSERTTEXT() | Wx::wxSTC
+_MOD_DELETETEXT() );
    Wx::Event::EVT_STC_CHANGE( $frame, $codetext, \&on_build_tree );
    Wx::Event::EVT_TREE_SEL_CHANGED( $frame, $codetree, \&on_item_sel 
+);

    
    
    $frame->{auim}->AddPane( $newLeft, Wx::AuiPaneInfo->new->Name("aui
+_codetree")->Caption("ppi dom(click here)")->Center->Movable->Resizab
+le->Dockable->MinSize( 240,100 )->Left->Floatable->PinButton->CloseBu
+tton(0) );
    $frame->{auim}->AddPane( $Left, Wx::AuiPaneInfo->new->Name("aui_co
+detext")->Caption("input(paste here)")->Center->Movable->Resizable->D
+ockable->MinSize( 100,250 )->Center->Floatable->PinButton->CloseButto
+n(0) );
    $frame->{auim}->AddPane( $newRight, Wx::AuiPaneInfo->new->Name("au
+i_treetext")->Caption("ppi node")->Center->Movable->Resizable->Dockab
+le->MinSize( 50, 50 )->Center->Floatable->PinButton->CloseButton(0) )
+;
    $frame->{auim}->Update();
    0 and $frame->{auim}->LoadPerspective(q{layout2| name=aui_codetree
+; caption=ppi dom(click here); state=16779260; dir=4; layer=0; row=0;
+ pos=0; prop=100000; bestw=240; besth=100; minw=240; minh=100; maxw=-
+1; maxh=-1; floatx=-1; floaty=-1; floatw=-1; floath=-1| name=aui_code
+text; caption=input(paste here); state=16779260; dir=5; layer=0; row=
+0; pos=0; prop=100000; bestw=100; besth=250; minw=100; minh=250; maxw
+=-1; maxh=-1; floatx=-1; floaty=-1; floatw=-1; floath=-1| name=aui_tr
+eetext; caption=ppi node; state=16779260; dir=5; layer=0; row=0; pos=
+1; prop=100000; bestw=50; besth=50; minw=50; minh=50; maxw=-1; maxh=-
+1; floatx=-1; floaty=-1; floatw=-1; floath=-1| dock_size(4,0,0)=242| 
+dock_size(5,0,0)=102|});
    0 and $frame->{auim}->LoadPerspective(q{layout2| name=aui_codetree
+; caption=ppi dom(click here); state=16781308; dir=1; layer=0; row=1;
+ pos=0; prop=100000; bestw=240; besth=100; minw=240; minh=100; maxw=-
+1; maxh=-1; floatx=250; floaty=518; floatw=400; floath=493| name=aui_
+codetext; caption=input(paste here); state=16781308; dir=1; layer=0; 
+row=1; pos=1; prop=100000; bestw=100; besth=250; minw=100; minh=250; 
+maxw=-1; maxh=-1; floatx=7; floaty=290; floatw=400; floath=493| name=
+aui_treetext; caption=ppi node; state=16781308; dir=5; layer=0; row=0
+; pos=0; prop=100000; bestw=50; besth=50; minw=50; minh=50; maxw=-1; 
+maxh=-1; floatx=-1; floaty=-1; floatw=-1; floath=-1| dock_size(5,0,0)
+=102| dock_size(1,0,1)=574|});
    0 and $frame->{auim}->LoadPerspective(q{layout2| name=aui_codetree
+; ppi dom(click here); state=16779260; dir=2; layer=0; row=1; pos=0; 
+prop=100000; bestw=240; besth=100; minw=240; minh=100; maxw=-1; maxh=
+-1; floatx=8; floaty=17; floatw=400; floath=493| name=aui_codetext; c
+aption=input(paste here); state=16779260; dir=5; layer=0; row=0; pos=
+0; prop=145048; bestw=100; besth=250; minw=100; minh=250; maxw=-1; ma
+xh=-1; floatx=-1; floaty=-1; floatw=-1; floath=-1| name=aui_treetext;
+ caption=ppi node; state=16779260; dir=3; layer=0; row=1; pos=0; prop
+=54952; bestw=50; besth=50; minw=50; minh=50; maxw=-1; maxh=-1; float
+x=66; floaty=66; floatw=400; floath=493| dock_size(5,0,0)=102| dock_s
+ize(2,0,1)=360| dock_size(3,0,1)=133|});
    0 and $frame->{auim}->LoadPerspective(q{});
    $frame->{init_perspective} = $frame->{auim}->SavePerspective;
    $codetree->SetFocus;
    
    return $frame;
}

sub DESTROY { 
    my($frame) = @_;
    $frame->{auim}->UnInit();
    undef %{$frame};
    return;
}

sub pperspective {
    my($frame) = @_;
    my $i = $frame->{init_perspective};
    my $p = $frame->{auim}->SavePerspective;
    return if $i eq $p;
    $p =~ s{([\;\|])}{$1\n}g;
    print $p;
}


sub on_build_tree {
    my( $frame, $e ) = @_;
    
    my $codetext = $frame->{codetext} || die;
    my $codetextpos = $codetext->GetCurrentPos;
    my $tree = $frame->{codetree} || die;
    my $treetext = $frame->{treetext} || die;
    my $rawtext = $codetext->GetValue;
    
    my $focus = Wx::Window::FindFocus() || $tree;
    
    $_->Disable for $codetext, $tree, $treetext;
    $tree->Unselect;
    $tree->DeleteAllItems;
    
    
## need to keep PPI::Document alive, TreeItemData appears to use weake
+n
    $frame->{ppidocument} = 
    my $document = PPI::Document->new( \$rawtext );
    TreeAdd( $tree, $document->document );
    
    $tree->ExpandAll;
    $treetext->SetValue("");
    $_->Enable for $tree, $treetext, $codetext;
    $focus and $focus->SetFocus; ### important
    $focus and $codetext->GotoPos( $codetextpos ); ### important
    return;
}

sub PPI::Element::reff { my $ref = ref $_[0]; $ref =~ s/^PPI:://; $ref
+ }
sub PPIx::Regexp::Element::reff { my $ref = ref $_[0]; $ref =~ s/^PPIx
+::Regexp::/xRe::/; $ref }

sub Wx::StyledTextCtrl::SelectRowColLen {
    my( $self, $row, $col, $len ) = @_;
    $self->SetSelectionMode( Wx::wxSTC_SEL_STREAM() );
    $self->GotoLine( $row );
    my $cpos = $self->GetCurrentPos ;
    $self->GotoPos( $cpos + $col );
    $cpos = $self->GetCurrentPos ;
    $self->GotoPos( $cpos + $len  );
    $self->SetSelection( $cpos , $cpos + $len );
}



sub Wx::StyledTextCtrl::SelectRowColLenStartEnd {
    my( $self, $row, $col, $len , $start, $end ) = @_;
    my $canmultiple = eval { $self->SetMultipleSelection( 1 ); 1 };
    eval { $self->ClearSelections( ); };
    $self->GotoLine( $row );
    my $cpos = $self->GetCurrentPos ;
    $self->GotoPos( $cpos + $col );
    $cpos = $self->GetCurrentPos ;
    $self->GotoPos( $cpos + $len  );
    my $orig_pos = $self->GetCurrentPos;
    my $start_pos = $self->PositionFromLine( $start );;
    my $end_pos = $self->PositionFromLine( $end );
    
    $self->SetSelection( $cpos , $cpos + $len );
    return if not $canmultiple ;
    $self->AddSelection( $start_pos  , $end_pos );
}

sub on_item_sel {
    my( $frame, $e ) = @_;
    my $focus = Wx::Window::FindFocus() ;
    
    my $treetext = $frame->{treetext}                  || die;
    my $codetext = $frame->{codetext}                  || die;
    my $tree = $frame->{codetree}                  || die;
    
    
    my $curr_item = $tree->GetSelection ;
    
    my $data = $tree->GetItemData( $curr_item ) || return;
    
    my $dataobj = $data = $data->GetData;
    my $col = $data->column_number - 1 ;
    my $row = $data->line_number - 1 ;
    my $lengthdata = 0;
    

    if( $data->isa( 'PPI::Token::HereDoc' ) ){
#~         warn pp($dataobj);
        my $ndd = "$data";
        $lengthdata = length $ndd;
        $data = join '', $ndd, "\n", $data->heredoc, $data->terminator
+;
        $data = '#'.$dataobj->overload::StrVal."\n".$data;

        eval { $codetext->SetMultipleSelection( 1 ); };
        $codetext->SelectRowColLenStartEnd( $row, $col, $lengthdata, $
+dataobj->here_line_range );
        $treetext->SetValue( $data );
        return ;
    } else {
        ### ick
        my $data = $data->can( 'serialize' )
                  ? $data->serialize
                  : $data->can('content')
                    ? $data->content
                    : $data ;
        $lengthdata = length $data;
        
#~         warn "the data is $data of length $lengthdata at row $row a
+nd col $col";
        
        $data = '#'.$dataobj->overload::StrVal."\n".$data;
        
        eval { $codetext->SetMultipleSelection( 0 ); };
        $codetext->SelectRowColLen( $row, $col, $lengthdata );
#~         $treetext->SetValue( $data );
#~         2013-07-18-20:20:53 no caching of this yet
#~ 2013-07-18-20:29:16
#~ 2013-07-18-20:39:31 weird, eval hides the failure I guess, nope, IT
+S THE GIANT large regex
#~ right, on token whitespace, naturally :)
        BEGIN { require 'ppixregexplain.pl'; }
#~         my $xplain = eval { $dataobj->can('xplain') } ? MainXplain(
+ $dataobj ) : ();
#~         $xplain and $data = "$data\n__END__\n$xplain" ;
        if( my $xplain = eval { $dataobj->xplain } ){
            my $str ="";
            open my($virtual), '>:raw', \$str or die "IMPOSSIBLE $! $^
+E";
            use SelectSaver;
            my $saver = SelectSaver->new( $virtual );
            local $@="";
            eval { darntext( $xplain ); }; ## this is halfarsed, darnt
+ext doesn't deal with partials
#~             darntext( $xplain ); 
#~             $data .= "\n\n__END__\n\n$str\n";
            my $err = "$@" || "";
            $err =~ s/^/#/gm;
#~             $data = "$str\n\n$err\n\n$data";
            $data = "$str\n\n$err\n__END__\n$data";
        }
        $treetext->SetValue( $data );
#~         $treetext->GotoLine( -1 ); ## no work
#~         $treetext->GotoLine( 1000000 ); ## works but FEH! documente
+d as "could be first or last"
        $treetext->GotoPos( length $data );
        
        return;
    }
    
}

sub TreeAdd {
    my( $t, $d, $root ) = @_;

    if( not $root ) {
        $root = $t->AddRoot( $d->reff, -1, -1, Wx::TreeItemData->new( 
+$d ) );
    }
    my @chids = eval { $d->start };
    if( @chids ){
        @chids = ( @chids, eval { $d->type } );
    }
    @chids = ( @chids, eval { $d->children }, eval { $d->finish } );
    for my $kid ( @chids ) {
        my $ref_kid = ref($kid);
        if( eval { scalar $kid->children; } ) {
            my $newid = Wx::TreeItemData->new( $kid );
            my $item = eval { $t->AppendItem( $root, $kid->reff, -1, -
+1, $newid ) };
            $item or do {
                warn "failed to append kid(
$kid
)
to root(
@{[ $root->overload::StrVal ]} = $root
)
with newid(
$newid
)
because GRR $@ ";
                next;
            };
            TreeAdd( $t, $kid, $item );
            if( $kid->isa('PPI::Statement::Include') ){
                $t->SetItemTextColour( $item, Wx::Colour->new( '#00007
+F' ));
                $t->SetItemBold( $item, 1 );
            }elsif( $ref_kid =~ /Data|End/  ){
                $t->SetItemTextColour( $item, Wx::Colour->new( '#60000
+0' ));
                $t->SetItemBackgroundColour( $item, Wx::Colour->new( '
+#FFF0D8' ));
            }
        } else {
            my $newid = Wx::TreeItemData->new( $kid );
            my $item = eval { $t->AppendItem( $root, $kid->reff, -1, -
+1, $newid ) };
            $item or do {
                warn "failed to append kid($kid) to root($root) with n
+ewid($newid) because GRR $@ ";
                next;
            };
            if( $kid->isa('PPI::Token::HereDoc' ) ){
                my $heredoc = "$kid";
                my $fore = "";
                my $back = "";
                my $bold = 0;
                if( $heredoc =~ /'/ )   { $fore="#7F007F"; $back="#fee
+ffe"; $bold = 0; }
                elsif( $heredoc =~ /`/ ){ $fore="#FFFF00"; $back="#A08
+080"; $bold = 1; }
                else                    { $fore="#7F007F"; $back="#fee
+ffe"; $bold = 1; }
                $t->SetItemTextColour( $item, Wx::Colour->new( $fore )
+);
                $t->SetItemBackgroundColour( $item, Wx::Colour->new( $
+back ));
                $t->SetItemBold( $item, $bold );
            }elsif( $ref_kid =~ /PPI::Token::QuoteLike::Command/ ){
                $t->SetItemTextColour( $item, Wx::Colour->new( '#FFFF0
+0'));
                $t->SetItemBackgroundColour( $item, Wx::Colour->new( '
+#A08080'));
            }elsif( $ref_kid =~ /PPI::Token::Quote/ ){
                $t->SetItemTextColour( $item, Wx::Colour->new( '#7F007
+F'));
                if( $ref_kid eq 'PPI::Token::QuoteLike::Regexp'){     
+               
                    my $regex = xPPIx_Regexp_linecol_onize( $kid, $kid
+->line_number, $kid->column_number );
                    my $newid = Wx::TreeItemData->new( $regex );
                    my $regexitem = eval { $t->AppendItem( $item, $reg
+ex->reff, -1, -1, $newid ) };
                    TreeAdd( $t, $regex, $regexitem  );
                }
            }elsif( ref $kid eq 'PPI::Token::Pod' ){
                $t->SetItemTextColour( $item, Wx::Colour->new( '#00400
+0' ));
                $t->SetItemBackgroundColour( $item, Wx::Colour->new( '
+#C0FFC0' ));
            }elsif( ref $kid eq 'PPI::Token::Separator' ){
                $t->SetItemBackgroundColour( $item, Wx::Colour->new( '
+#FFF0D8' ));
            }elsif( ref $kid eq 'PPI::Token::Regexp::Substitute' ){
                $t->SetItemBackgroundColour( $item, Wx::Colour->new( '
+#F0E080' ));
                my $regex = xPPIx_Regexp_linecol_onize( $kid, $kid->li
+ne_number, $kid->column_number );
                my $newid = Wx::TreeItemData->new( $regex );
                my $regexitem = eval { $t->AppendItem( $item, $regex->
+reff, -1, -1, $newid ) };
                TreeAdd( $t, $regex, $regexitem  );
            }elsif( ref $kid eq 'PPI::Token::Regexp::Match' ){
                $t->SetItemBackgroundColour( $item, Wx::Colour->new( '
+#A0FFA0' ));
                
                my $regex = xPPIx_Regexp_linecol_onize( $kid, $kid->li
+ne_number, $kid->column_number );
                my $newid = Wx::TreeItemData->new( $regex );
                my $regexitem = eval { $t->AppendItem( $item, $regex->
+reff, -1, -1, $newid ) };
                TreeAdd( $t, $regex, $regexitem  );
            }elsif( ref $kid eq 'PPI::Token::Word' ){
                $t->SetItemTextColour( $item, Wx::Colour->new( '#00007
+F' ));
                $t->SetItemBold( $item, 1 );
            }elsif( ref $kid eq 'PPI::Token::Comment' ){
                $t->SetItemTextColour( $item, Wx::Colour->new( '#007F0
+0' ));
            }elsif( ref $kid eq 'PPI::Token::Number' ){
                $t->SetItemTextColour( $item, Wx::Colour->new( '#007F7
+F' ));
            }elsif( $ref_kid =~ /Operator|Structure/  ){
                $t->SetItemBold( $item, 1 );
            }elsif( $ref_kid =~ /PPI::Token::Magic|PPI::Token::Symbol/
+ ){
                my $symbol_type = $kid->symbol_type;
                my $back = '#FFE0E0' ;
                if( $symbol_type eq '@' ){    $back ='#FFFFE0'}
                elsif( $symbol_type eq '%' ){ $back ='#FFE0FF'}
                elsif( $symbol_type eq '*' ){ $back ='#E0E0E0'}
                $t->SetItemBackgroundColour( $item, Wx::Colour->new( $
+back ));
            }
        }
    }
    return $root;
}


sub MakeScintilla {
    my( $newRight ) = @_;
    my $treetext = Wx::StyledTextCtrl->new(
        $newRight, -1,
        [ -1, -1 ],
        [ -1, -1 ],
        Wx::wxTE_PROCESS_ENTER() | Wx::wxTE_MULTILINE() | &Wx::wxTE_NO
+HIDESEL
    );
    
    $treetext->SetCodePage(65001);
    $treetext->SetLexerLanguage( 'perl' );
    eval {
        my $font = Wx::Font->new(
            10,
            Wx::wxTELETYPE(),
            Wx::wxNORMAL(),
            Wx::wxNORMAL(),
            0,
            "DejaVu Sans Mono",
## fontmapper doesn'te detect its a UTF8 font,
## so it throws up a fontchooser dialog, known bug
#~             Wx::wxFONTENCODING_UTF8(),
        );
        $treetext->SetFont( $font );
        $treetext->StyleSetFont( Wx::wxSTC_STYLE_DEFAULT(), $font );
    };



    $treetext->StyleClearAll();
    $treetext->SetLexer( Wx::wxSTC_LEX_PERL() );
    $treetext->SetSelectionMode( Wx::wxSTC_SEL_LINES() );
    $treetext->StyleSetSpec( 0,"fore:#808080,font:DejaVu Sans Mono,siz
+e:11" ); # White space
    $treetext->StyleSetSpec( 1,"fore:#FFFF00,back:#FF0000" ); # Error
    $treetext->StyleSetSpec( 2,"fore:#007F00,font:DejaVu Sans Mono,siz
+e:11" ); # Comment
    $treetext->StyleSetSpec( 3,"fore:#004000,back:#E0FFE0,font:DejaVu 
+Sans Mono,size:11,eolfilled" ); # POD: = at beginning of line
    $treetext->StyleSetSpec( 4,"fore:#007F7F" ); # Number
    $treetext->StyleSetSpec( 5,"fore:#00007F,bold" ); # Keyword
    $treetext->StyleSetSpec( 6,"fore:#7F007F,font:DejaVu Sans Mono,siz
+e:11" ); # Double quoted string
    $treetext->StyleSetSpec( 7,"fore:#7F007F,font:DejaVu Sans Mono,siz
+e:11" ); # Single quoted string
    $treetext->StyleSetSpec( 8,"back:#FF0000," ); # Symbols / Punctuat
+ion. Currently not used by LexPerl.
    $treetext->StyleSetSpec( 9,"back:#FF0000," ); # Preprocessor. Curr
+ently not used by LexPerl.
    $treetext->StyleSetSpec( 10,"fore:#000000,bold" ); # Operators
    $treetext->StyleSetSpec( 11,"fore:#000000" ); # Identifiers (funct
+ions, etc.)
    $treetext->StyleSetSpec( 12,"fore:#000000,back:#FFE0E0" ); # Scala
+rs: $var
    $treetext->StyleSetSpec( 13,"fore:#000000,back:#FFFFE0" ); # Array
+: @var
    $treetext->StyleSetSpec( 14,"fore:#000000,back:#FFE0FF" ); # Hash:
+ %var
    $treetext->StyleSetSpec( 15,"fore:#000000,back:#E0E0E0" ); # Symbo
+l table: *var
    $treetext->StyleSetSpec( 17,"fore:#000000,back:#A0FFA0" ); # Regex
+: /re/ or m{re}
    $treetext->StyleSetSpec( 18,"fore:#000000,back:#F0E080" ); # Subst
+itution: s/re/ore/
    $treetext->StyleSetSpec( 19,"fore:#FFFF00,back:#8080A0" ); # Long 
+Quote (qq, qr, qw, qx) -- obsolete: replaced by qq, qx, qr, qw
    $treetext->StyleSetSpec( 20,"fore:#FFFF00,back:#A08080" ); # Back 
+Ticks
    $treetext->StyleSetSpec( 21,"fore:#600000,back:#FFF0D8,eolfilled" 
+); # Data Section: __DATA__ or __END__ at beginning of line
    $treetext->StyleSetSpec( 22,"fore:#000000,back:#feeffe" ); # Here-
+doc (delimiter)
    $treetext->StyleSetSpec( 23,"fore:#7F007F,back:#feeffe,eolfilled,n
+otbold" ); # Here-doc (single quoted, q)
    $treetext->StyleSetSpec( 24,"fore:#7F007F,back:#feeffe,eolfilled,b
+old" ); # Here-doc (double quoted, qq)
    $treetext->StyleSetSpec( 25,"fore:#FFFF00,back:#A08080,eolfilled,b
+old" ); # Here-doc (back ticks, qx)
    $treetext->StyleSetSpec( 26,"fore:#7F007F,font:DejaVu Sans Mono,si
+ze:11,notbold" ); # Single quoted string, generic
    $treetext->StyleSetSpec( 27,"fore:#7F007F,font:DejaVu Sans Mono,si
+ze:11" ); # qq = Double quoted string
    $treetext->StyleSetSpec( 28,"fore:#FFFF00,back:#A08080" ); # qx = 
+Back ticks
    $treetext->StyleSetSpec( 29,"fore:#000000,back:#A0FFA0" ); # qr = 
+Regex
    $treetext->StyleSetSpec( 30,"fore:#000000,back:#FFFFE0" ); # qw = 
+Array
    $treetext->StyleSetSpec( 31,"fore:#004000,back:#C0FFC0,font:DejaVu
+ Sans Mono,size:11,eolfilled" ); # POD: verbatim paragraphs
    $treetext->StyleSetSpec( 40,"fore:#000000,bold,italics" ); # subro
+utine prototype
    $treetext->StyleSetSpec( 41,"fore:#C000C0,bold" ); # format identi
+fier
    $treetext->StyleSetSpec( 42,"fore:#C000C0,back:#FFF0FF,eolfilled" 
+); # format body

    $treetext->SetMarginType(0, Wx::wxSTC_MARGIN_NUMBER() );
    $treetext->SetMarginWidth(0,50);
    $treetext->SetMarginWidth(1,0);
    
    
#~ perl.properties
    $treetext->SetKeyWords( 0, join ' ' , qw{NULL __FILE__ __LINE__ __
+PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE DESTROY END EQ GE GT I
+NIT LE LT NE CHECK abs accept alarm and atan2 bind binmode bless call
+er chdir chmod chomp chop chown chr chroot close closedir cmp connect
+ continue cos crypt dbmclose dbmopen defined delete die do dump each 
+else elsif endgrent endhostent endnetent endprotoent endpwent endserv
+ent eof eq eval exec exists exit exp fcntl fileno flock for foreach f
+ork format formline ge getc getgrent getgrgid getgrnam gethostbyaddr 
+gethostbyname gethostent getlogin getnetbyaddr getnetbyname getnetent
+ getpeername getpgrp getppid getpriority getprotobyname getprotobynum
+ber getprotoent getpwent getpwnam getpwuid getservbyname getservbypor
+t getservent getsockname getsockopt glob gmtime goto grep gt hex if i
+ndex int ioctl join keys kill last lc lcfirst le length link listen l
+ocal localtime lock log lstat lt map mkdir msgctl msgget msgrcv msgsn
+d my ne next no not oct open opendir or ord our pack package pipe pop
+ pos print printf prototype push quotemeta qu rand read readdir readl
+ine readlink readpipe recv redo ref rename require reset return rever
+se rewinddir rindex rmdir scalar seek seekdir select semctl semget se
+mop send setgrent sethostent setnetent setpgrp setpriority setprotoen
+t setpwent setservent setsockopt shift shmctl shmget shmread shmwrite
+ shutdown sin sleep socket socketpair sort splice split sprintf sqrt 
+srand stat study sub substr symlink syscall sysopen sysread sysseek s
+ystem syswrite tell telldir tie tied time times truncate uc ucfirst u
+mask undef unless unlink unpack unshift untie until use utime values 
+vec wait waitpid wantarray warn while write xor given when default sa
+y state UNITCHECK});
    $treetext->EnsureCaretVisible;
    return $treetext;
}


sub SelectTreeAtLine {
    my( $tree, $line, $child ) = @_;
    $child ||= $tree->GetRootItem;
    if( $tree->GetChildrenCount( $child ) ){
        my( $item, $cookie ) = $tree->GetFirstChild(  $child );
        while(1){        
            my $data = $tree->GetItemData( $item ) || die;
            my $dataobj = $data->GetData;
            my $col = $dataobj->column_number - 1 ;
            my $row = $dataobj->line_number - 1 ;
            if( $row == $line ){
                $tree->SelectItem( $tree->GetItemParent( $item ), 1 );
+ ## oy
                return 1;
            }
            ( $item, $cookie ) = $tree->GetNextChild(  $child, $cookie
+ );
            if( $tree->GetChildrenCount( $item )  ){
                last if SelectTreeAtLine( $tree, $line, $item );
            }
            last if not $item->IsOk;
        }
    }
}

sub readFile {
    my( $frame, $file ) = @_;
    open my($fh),'<', $file or die "$!\n$^E\n ";
    binmode $fh, ':encoding(UTF-8)';
    local $/;
    my $thesourcecode = readline $fh;
    close $fh;
    $thesourcecode =~ s/\x{FEFF}//g; ## nuke bom
    $frame->{codetext}->SetValue( $thesourcecode );
}



sub Wx::StyledTextCtrl::SetValue { shift->SetText( @_ ); }
sub Wx::StyledTextCtrl::GetValue { shift->GetText( @_ ); }


BEGIN {
    if( not eval { require Wx::STC; 1 } )
    {
        require Wx::Scintilla;
        @Wx::StyledTextCtrl::ISA = 'Wx::Scintilla::TextCtrl';
    }
}


sub PPI::Statement::serialize {
    my( $ppis ) = @_;
    my $ret = "$ppis";
    my $heredoc = "";
    for my $kid( $ppis->tokens ){
        if( $kid->isa( 'PPI::Token::HereDoc' )  ){
            $heredoc .= join '', $kid->heredoc, $kid->{_terminator_lin
+e};
        }
    }
    if ( $heredoc ){
        $ret .= "\n$heredoc";
    }
    return $ret;
}

sub PPI::Token::HereDoc::here_line_range { ## column_number / line_num
+ber for ->heredoc
    my( $ppih ) = @_;
    my $here_line_range = $ppih->{_here_line_range} ||= [];
    
    return @$here_line_range if @$here_line_range ;
    
    my $parent = $ppih->parent;
    my $ret = "$ppih";
    my $heredoc = "";
    my $line_range = my $line_range_start = $parent->line_number;
    my $line_range_end = $parent->line_number;
    for my $kid( $parent->tokens ){
        if( $kid->isa( 'PPI::Token::HereDoc' )  ){
            $kid == $ppih and $line_range_start = $line_range;
            $line_range++ for $kid->heredoc, $kid->terminator;
            $kid == $ppih and $line_range_end = $line_range;
        }
    }
    push @$here_line_range, $line_range_start, $line_range_end ;
    return ( $line_range_start, $line_range_end );
}

sub PPIx::Regexp::Element::line_number {
    my( $e ) = @_;
    my $oldparent = $e;
    my $line = eval { $oldparent->{__line_number} };
    
    return $line if defined $line;
    
    my $ix = 0;
    while( my $newparent = eval { $oldparent->_parent } ){
        $oldparent = $newparent;
        $line = eval { $newparent->{__line_number} };
        last if defined $line;
        $ix++;
        last if $ix > 1024;
    }
    
    return $line;
}


sub PPIx::Regexp::Element::column_number {
    my( $e ) = @_;
    my $oldparent = $e;
    my $column = eval { $oldparent->{__column_number} };
    
    return $column if defined $column;
    
    my $ix = 0;
    while( my $newparent = eval { $oldparent->_parent } ){
        $oldparent = $newparent;
        $column = eval { $newparent->{__line_number} };
        return $column if defined $column ;
        $ix++;
        last if $ix > 1024;
    }
    return $column ;
}




sub xPPIx_Regexp_linecol_onize {
    my( $re , $line, $col ) = @_;
    
    if( not ref $re  or  ref($re) =~ m{^(?: PPI::Token::QuoteLike::Reg
+exp | PPI::Token::Regexp::Match | PPI::Token::Regexp::Substitute )$}x
+s ){
        $re = PPIx::Regexp->new( $re )
            or Carp::croak( "Aww FUDGE ". PPIx::Regexp->errstr() );
    }
    
    $line ||= 1;
    $col  ||= 1;
    $re->{__line_number}   ||= $line ;
    $re->{__column_number} ||= $col  ;
    
    my $ref = ref $re;
    
    for my $start ( eval { $re->start } ){
        xPPIx_Regexp_linecol_onize( $start, $line, $col );
        $col += length $start->content;
    }
    
    if( eval { $re->start } ){
        for my $type ( eval { $re->type } ){
            xPPIx_Regexp_linecol_onize( $type, $line, $col );
            $col += length $type->content;
        }
    }
    
    
    for my $kid( eval { $re->children } ){
        my $rref = ref $kid;
        my $haskids = eval { scalar $kid->children } ;
        
        if( $rref =~ m{^PPIx::Regexp::Token} or not $haskids ){
            ## don't print PPIx::Regexp::Structure::Regexp
            ## don't print PPIx::Regexp::Structure::Replacement
            ## print its start/type/children/finish instead (they add 
+up to parent)
            xPPIx_Regexp_linecol_onize( $kid, $line, $col );
            $col += length $kid->content;
        }
        if( $haskids ){
            xPPIx_Regexp_linecol_onize( $kid, $line, $col );
            $col += length $kid->content;
        }
    }
    
    
    for my $finish ( eval { $re->finish } ){
        xPPIx_Regexp_linecol_onize( $finish, $line, $col );
        $col += length $finish->content;
    }
    
    return $re;
}

__END__


=head1 NAME

ppiwx - wxppi, display L<PPI> DOM in Wx::TreeCtrl, now with color

=head1 USAGE

    ppiwx utf8file.pl anotherutf8file.pl ...

=head1 EXPECTS

expects UTF-8 files, so whateveryou need to do :) 

    iconv -f UTF-16 -t UTF-8 < in > out 
    piconv -f UTF-16LE -t UTF-8 < in > out

=head1 PREREQUISITED

=head1 DEPENDENCIES

=head1 KNOWN TO WORK WITH

    AutoLoader             5.71
    Carp                   1.17
    Clone                  0.31
    Digest::MD5            2.51
    Digest::base           1.16
    DynaLoader             1.10
    Encode                 2.43
    Encode::Alias          2.14
    Encode::Config         2.05
    Encode::Encoding       2.05
    Exporter             5.64_01
    IO::String             1.08
    List::MoreUtils        0.32
    List::Util             1.23
    PPI                   1.215
    PPIx::Regexp          0.034
    PPI::Util             1.215
    Params::Util           1.04
    PerlIO                 1.06
    PerlIO::encoding       0.12
    PerlIO::scalar         0.08
    Scalar::Util           1.23
    Symbol                 1.07
    Tie::Handle             4.2
    Tie::StdHandle          4.2
    Wx                   0.9902
    Wx::AUI                0.01
    Wx::STC                0.01
    Wx::Wx_Exp                 
    XSLoader               0.15
    attributes             0.12
    base                   2.15
    bytes                  1.04
    constant               1.21
    overload               1.10
    utf8                   1.08
    vars                   1.01
    warnings               1.09
    warnings::register     1.01

=head1 AUTHOR

Anonymous Monk

=head1 LICENSE

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

=head1 SEE ALSO

L<http://ali.as/>
L<PPI>
L<Wx>
L<http://www.wxperl.it/>
L<http://wiki.wxperl.it/>
L<http://wiki.wxwidgets.org/>
L<http://forums.wxwidgets.org/>
L<http://docs.wxwidgets.org/>
L<http://www.scintilla.org/>
L<http://perl.org/>

=cut