#!perl -w
use strict;
our $VERSION = '2.2';
use Tk;
use Tk::ROText;
use Tk::LabFrame;
use Tk::Pane;
use Tk::Balloon;
use Tk::HistEntry;
use Tk::NumEntry;
use Cwd;
use FindBin;
use File::Spec;
use Data::Dumper;
use Pod::Simple::Text;
use PAR::Packer;
my $optref = PAR::Packer::OPTIONS;
our ( @opts, @type, @def, @chkd, @value );
our ( $source_file, $output_file, $log_file_ref, %hist_refs );
my $mw = MainWindow->new( -title => "gpp $VERSION - gui for pp" );
my $default_size = '500x500'; # for $mw, $hw and $lw
$mw->geometry($default_size);
$mw->minsize( 250, 250 );
$mw->setPalette('cornsilk3');
$mw->optionAdd( '*font' => 'Courier 10' );
my $entry_font_color = 'blue';
my $balloon_font = 'Courier 8';
my $balloon_color = 'yellow';
my $dots_font = 'Courier 5';
my $pl_types = [ [ 'pp source', [ '.par', '.pl', '.ptk', '.pm' ] ], [ 'All files', '*' ] ];
my $gpp_types = [ [ 'gpp options', ['.gpp'] ], [ 'All files', '*' ] ];
my $default_gpp_ext = '.gpp';
my $pp = find_pp();
if ( !$pp ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "Can't find pp !!",
-type => 'OK'
);
exit(1);
}
if ( !open PP, "<$pp" ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "Can't open $pp: $!",
-type => 'OK'
);
exit(1);
}
my $pp_text;
{
undef $/;
$pp_text = <PP>;
}
close PP;
@opts = sort {
lc( substr( $a, 0, index( $a, '|' ) ) ) cmp lc( substr( $b, 0, index( $b, '|' ) ) )
|| $a cmp $b
} keys %$optref;
for (@opts) { push @def, $$optref{$_} }
# parse option specifiers
for ( 0 .. $#opts ) {
my ($short) = ( $opts[$_] =~ /([^|]+)/ );
$type[$_] = '';
$type[$_] = $1 if $opts[$_] =~ /([=:].*)/;
$opts[$_] = $short;
$chkd[$_] = 0;
$value[$_] = 0 if $type[$_] =~ /i/;
$value[$_] = '' if $type[$_] =~ /[fs]/;
$log_file_ref = \$value[$_] if $opts[$_] eq 'L';
}
my $f = $mw->Frame( -borderwidth => 5 )->pack( -expand => 1, -fill => 'both' );
my $fb = $f->Frame()->pack( -fill => 'x' );
my $fb1 = $fb->Frame()->pack( -side => 'left', -expand => 'y', -fill => 'x' );
$fb1->Button( -text => 'Pack', -command => sub { run_pp() } )->pack( -expand => 1, -fill => 'x' );
$fb1->Button( -text => 'View Log', -command => sub { view_log() } )
->pack( -expand => 1, -fill => 'x' );
my $fb2 = $fb->Frame()->pack( -side => 'left', -expand => 'y', -fill => 'x' );
$fb2->Button( -text => 'Open Opts',
-command => sub { open_opts(); }
)->pack( -expand => 1, -fill => 'x' );
$fb2->Button( -text => 'Save Opts',
-command => sub { save_opts(); }
)->pack( -expand => 1, -fill => 'x' );
my $fb3 = $fb->Frame()->pack( -side => 'left', -expand => 'y', -fill => 'x' );
$fb3->Button( -text => 'Exit', -command => sub { save_hist() } )
->pack( -expand => 1, -fill => 'x' );
$fb3->Button( -text => 'Help', -command => sub { help() } )->pack( -expand => 1, -fill => 'x' );
my $ff = $f->Frame( -borderwidth => 5, )->pack( -fill => 'x' );
my $fn = $ff->Frame()->pack( -side => 'left' );
$fn->Label( -text => 'Source File:' )->pack( -anchor => 'e' );
$fn->Label( -text => 'Output File:' )->pack( -anchor => 'e' );
my $fe = $ff->Frame()->pack( -side => 'left', -expand => 1, -fill => 'x' );
my $source_entry = $fe->HistEntry( -textvariable => \$source_file,
-width => 1,
-fg => $entry_font_color,
-selectbackground => $entry_font_color,
-dup => 0,
-case => 0, # works opposite of pod
-match => 1,
-limit => 10,
-command => sub { }
)->pack( -expand => 1, -fill => 'x' );
$source_entry->Subwidget('slistbox')->configure( -bg => 'white' );
my $output_entry = $fe->HistEntry( -textvariable => \$output_file,
-width => 1,
-fg => $entry_font_color,
-selectbackground => $entry_font_color,
-dup => 0,
-case => 0, # works opposite of pod
-match => 1,
-limit => 10,
-command => sub { }
)->pack( -expand => 1, -fill => 'x' );
$output_entry->Subwidget('slistbox')->configure( -bg => 'white' );
my $fg = $ff->Frame()->pack( -side => 'left', -fill => 'y' );
$fg->Button(
-text => '...',
-font => $dots_font,
-command => sub {
my $file = $mw->getOpenFile( -filetypes => $pl_types );
if ($file) {
$source_file = $file;
$source_file = '"' . $source_file . '"' if $source_file =~ / / and $^O =~ /win32/i;
$source_entry->xview('end');
$source_entry->historyAdd();
}
}
)->pack(-expand => 'y', -fill => 'y');
$fg->Button(
-text => '...',
-font => $dots_font,
-command => sub {
my $file = $mw->getSaveFile();
if ($file) {
$output_file = $file;
$output_file = '"' . $output_file . '"' if $output_file =~ / / and $^O =~ /win32/i;
$output_entry->xview('end');
$output_entry->historyAdd();
}
}
)->pack(-expand => 'y', -fill => 'y');
my $fo =
$f->LabFrame( -label => 'Options', -labelside => 'acrosstop' )
->pack( -expand => 1, -fill => 'both' );
my $p = $fo->Scrolled( 'Pane',
-scrollbars => 'osw',
-sticky => 'we',
)->pack( -expand => 1, -fill => 'both' );
for ( 0 .. $#opts ) {
next if $opts[$_] =~ /^[oh]$/;
my $fp = $p->Frame()->pack( -expand => 'y', -fill => 'both' );
my $c = $fp->Checkbutton( -text => $opts[$_],
-variable => \$chkd[$_],
-selectcolor => 'white'
)->pack( -side => 'left' );
$fp->Balloon( -bg => $balloon_color, -font => $balloon_font )
->attach( $c, -balloonmsg => $def[$_] );
if ( $type[$_] =~ /[@%]/ ) {
if ( $type[$_] =~ /=/ ) {
$fp->Label( -text => '+' )->pack( -side => 'left' );
}
else {
$fp->Label( -text => '*' )->pack( -side => 'left' );
}
}
else {
$fp->Label( -text => ' ' )->pack( -side => 'left' );
}
my $he;
if ( $type[$_] =~ /[fs]/ ) {
$he = $fp->HistEntry( -textvariable => \$value[$_],
-width => 1,
-fg => $entry_font_color,
-selectbackground => $entry_font_color,
-dup => 0,
-case => 0, # works opposite of pod
-match => 1,
-limit => 10,
-command => sub { },
)->pack( -side => 'left', -expand => 'y', -fill => 'x' );
$he->Subwidget('slistbox')->configure( -bg => 'white' );
$hist_refs{ $opts[$_] } = $he;
}
if ( $type[$_] =~ /f/ ) {
$he->Subwidget('entry')->configure( -validate => 'key' );
$he->Subwidget('entry')->configure(
-validatecommand => sub {
$_[0] =~ /^[+-]?\.?$| # starting entry
^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d*))?$ # continuing entry
/x; # not validated if the entry ever actually finishes
}
);
}
if ( $type[$_] =~ /i/ ) {
$fp->NumEntry( -textvariable => \$value[$_],
-width => 5,
-fg => $entry_font_color,
-selectbackground => $entry_font_color,
)->pack( -side => 'left' );
}
}
my ( $hw, $hwt ); # help toplevel/text
my ( $lw, $lwt ); # view log toplevel/text
$mw->waitVisibility;
open_opts( $ARGV[0] ) if $ARGV[0];
my $gpp_history = $ENV{HOME} || $ENV{HOMEPATH} || $FindBin::Bin;
$gpp_history .= '/.gpp.history';
open_hist();
$source_entry->focus;
MainLoop;
sub find_pp {
my $pp = 'pp';
$pp .= '.bat' if $^O =~ /win32/i;
return File::Spec->catfile( cwd(), $pp ) if -e $pp;
my @path = File::Spec->path();
for (@path) {
my $full_name = File::Spec->catfile( $_, $pp );
return $full_name if -e $full_name;
}
return undef;
}
sub open_opts {
my $opts_file = shift;
if ( !$opts_file ) {
$opts_file = $mw->getOpenFile( -filetype => $gpp_types );
}
return if !$opts_file;
my ( $save_chkd, $save_value );
if ( !open OH, "<$opts_file" ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$opts_file: $!",
-type => 'OK'
);
return;
}
my $opts_dump;
{
undef $/;
$opts_dump = <OH>;
}
close OH;
if ( $opts_dump !~ /\$save_chkd\s*=.*?\$save_value\s*=/s ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$opts_file: Not a gpp option file !!",
-type => 'OK'
);
return;
}
eval $opts_dump;
if ($@) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$opts_file: $@",
-type => 'OK'
);
return;
}
for ( 0 .. $#opts ) {
if ( exists $save_chkd->{ $opts[$_] } ) {
$chkd[$_] = $save_chkd->{ $opts[$_] };
$value[$_] = $save_value->{ $opts[$_] };
}
}
} ## end sub open_opts
sub save_opts {
my $opts_file =
$mw->getSaveFile( -filetypes => $gpp_types, -defaultextension => $default_gpp_ext );
return if !$opts_file;
my ( %save_chkd, %save_value );
for ( 0 .. $#opts ) {
$save_chkd{ $opts[$_] } = $chkd[$_];
$save_value{ $opts[$_] } = $value[$_];
}
if ( !open OH, ">$opts_file" ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$opts_file: $!",
-type => 'OK'
);
return;
}
print OH Data::Dumper->Dump( [ $source_file, $output_file, \%save_chkd, \%save_value ],
[qw( source_file output_file save_chkd save_value )] );
close OH;
}
sub open_hist {
return if !-e $gpp_history;
my ( $source_hist, $output_hist, $opts_hist );
if ( !open HH, "<$gpp_history" ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$gpp_history: $!",
-type => 'OK'
);
return;
}
my $hist_dump;
{
undef $/;
$hist_dump = <HH>;
}
close HH;
if ( $hist_dump !~ /\$source_hist\s*=.*?\$output_hist\s*=/s ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$gpp_history: Not a gpp history file !!",
-type => 'OK'
);
return;
}
eval $hist_dump;
if ($@) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$gpp_history: $@",
-type => 'OK'
);
return;
}
$source_entry->history($source_hist);
$output_entry->history($output_hist);
for ( 0 .. $#opts ) {
if ( exists $opts_hist->{ $opts[$_] } ) {
$hist_refs{ $opts[$_] }->history( $opts_hist->{ $opts[$_] } );
}
}
} ## end sub open_hist
sub save_hist {
if ( !open HH, ">$gpp_history" ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$gpp_history: $!",
-type => 'OK'
);
return;
}
my ( $source_hist, $output_hist );
$source_hist = [ $source_entry->history() ];
$output_hist = [ $output_entry->history() ];
for ( keys %hist_refs ) {
$hist_refs{$_} = [ $hist_refs{$_}->history() ];
}
print HH Data::Dumper->Dump( [ $source_hist, $output_hist, \%hist_refs ],
[qw( source_hist output_hist opts_hist )] );
close HH;
exit();
}
sub view_log {
my $file = $$log_file_ref;
$file =~ s/^"(.*)"$/$1/;
return if !$file;
if ( !open LH, "<$file" ) {
$mw->messageBox( -title => 'Error',
-icon => 'error',
-message => "$file: $!",
-type => 'OK'
);
return;
}
my $log_text;
{
undef $/;
$log_text = <LH>;
}
close LH;
if ( !Exists($lw) ) {
$lw = $mw->Toplevel( -title => 'Log file' );
my ( $x, $y ) = ( $mw->geometry() =~ /^\d+x\d+\+(\d+)\+(\d+)/ );
$lw->geometry( $default_size . '+' . ( $x + 20 ) . '+' . ( $y + 20 ) );
$lw->minsize( 200, 30 );
my $fb = $lw->Frame()->pack( -fill => 'x' );
$fb->Button( -text => 'Close', -command => sub { $lw->withdraw() } )
->pack( -side => 'left', -expand => 'y', -fill => 'x' );
$fb->Button( -text => 'Clear Log file',
-command => sub { open LH, ">$file"; close LH; $lw->withdraw() }
)->pack( -side => 'right' );
$lwt = $lw->Scrolled( "Text",
-scrollbars => 'osw',
-wrap => 'none',
-height => 1,
-width => 1
)->pack( -expand => 1, -fill => 'both' );
$lwt->insert( 'end', $log_text );
$lw->focus();
}
else {
$lwt->delete( '0.0', 'end' );
$lwt->insert( 'end', $log_text );
$lw->deiconify();
$lw->raise();
$lw->focus();
}
} ## end sub view_log
sub help {
if ( !Exists($hw) ) {
$hw = $mw->Toplevel( -title => 'Help for pp' );
my ( $x, $y ) = ( $mw->geometry() =~ /^\d+x\d+\+(\d+)\+(\d+)/ );
$hw->geometry( $default_size . '+' . ( $x + 40 ) . '+' . ( $y + 40 ) );
$hw->minsize( 100, 30 );
$hw->Button( -text => 'Close', -command => sub { $hw->withdraw } )->pack( -fill => 'x' );
my $parser = Pod::Simple::Text->new();
my $pod;
$parser->output_string( \$pod );
$parser->parse_string_document($pp_text);
$hwt = $hw->Scrolled( "Text",
-scrollbars => 'osw',
-wrap => 'none',
-height => 1,
-width => 1
)->pack( -expand => 1, -fill => 'both' );
$hwt->insert( 'end', $pod );
$hw->focus();
}
else {
$hw->deiconify();
$hw->raise();
$hw->focus();
}
}
sub run_pp {
my @pp_opts = ();
for ( 0 .. $#opts ) {
if ( $chkd[$_] ) {
if ( ( $type[$_] eq '' ) or ( $type[$_] =~ /:/ and $value[$_] eq '' ) ) {
push @pp_opts, '-' . $opts[$_];
}
elsif ( $type[$_] =~ /[ifs]$/ ) {
push @pp_opts, '-' . $opts[$_];
push @pp_opts, $value[$_];
}
elsif ( $type[$_] =~ /[fs][@%]/ ) {
my @multi = ();
my $value = $value[$_];
# Look for quoted strings first, then non-blank strings,
# separated by spaces, commas or semicolons
while ( $value =~ /\G\s*((['"])[^\2]*?\2)\s*[,;]?|\G\s*([^\s,;]+)\s*[,;]?/g ) {
push( @multi, defined($1) ? $1 : $3 );
}
for $value (@multi) {
push @pp_opts, '-' . $opts[$_];
push @pp_opts, $value;
}
}
}
}
if ($output_file) {
push @pp_opts, '-o';
push @pp_opts, $output_file;
}
if ($source_file) {
push @pp_opts, $source_file;
}
print "$pp @pp_opts\n";
$mw->Busy();
system $pp, @pp_opts;
$mw->Unbusy();
print "Done.\n\n";
} ## end sub run_pp