1#!perl -w 2use strict; 3 4our $VERSION = '2.2'; 5 6use Tk; 7use Tk::ROText; 8use Tk::LabFrame; 9use Tk::Pane; 10use Tk::Balloon; 11use Tk::HistEntry; 12use Tk::NumEntry; 13 14use Cwd; 15use FindBin; 16use File::Spec; 17use Data::Dumper; 18use Pod::Simple::Text; 19 20use PAR::Packer; 21my $optref = PAR::Packer::OPTIONS; 22 23our ( @opts, @type, @def, @chkd, @value ); 24our ( $source_file, $output_file, $log_file_ref, %hist_refs ); 25 26my $mw = MainWindow->new( -title => "gpp $VERSION - gui for pp" ); 27my $default_size = '500x500'; # for $mw, $hw and $lw 28$mw->geometry($default_size); 29$mw->minsize( 250, 250 ); 30$mw->setPalette('cornsilk3'); 31$mw->optionAdd( '*font' => 'Courier 10' ); 32my $entry_font_color = 'blue'; 33my $balloon_font = 'Courier 8'; 34my $balloon_color = 'yellow'; 35my $dots_font = 'Courier 5'; 36my $pl_types = [ [ 'pp source', [ '.par', '.pl', '.ptk', '.pm' ] ], [ 'All files', '*' ] ]; 37my $gpp_types = [ [ 'gpp options', ['.gpp'] ], [ 'All files', '*' ] ]; 38my $default_gpp_ext = '.gpp'; 39 40my $pp = find_pp(); 41if ( !$pp ) { 42 $mw->messageBox( -title => 'Error', 43 -icon => 'error', 44 -message => "Can't find pp !!", 45 -type => 'OK' 46 ); 47 exit(1); 48} 49if ( !open PP, "<$pp" ) { 50 $mw->messageBox( -title => 'Error', 51 -icon => 'error', 52 -message => "Can't open $pp: $!", 53 -type => 'OK' 54 ); 55 exit(1); 56} 57my $pp_text; 58{ 59 undef $/; 60 $pp_text = <PP>; 61} 62close PP; 63 64@opts = sort { 65 lc( substr( $a, 0, index( $a, '|' ) ) ) cmp lc( substr( $b, 0, index( $b, '|' ) ) ) 66 || $a cmp $b 67} keys %$optref; 68for (@opts) { push @def, $$optref{$_} } 69 70# parse option specifiers 71for ( 0 .. $#opts ) { 72 my ($short) = ( $opts[$_] =~ /([^|]+)/ ); 73 $type[$_] = ''; 74 $type[$_] = $1 if $opts[$_] =~ /([=:].*)/; 75 $opts[$_] = $short; 76 $chkd[$_] = 0; 77 $value[$_] = 0 if $type[$_] =~ /i/; 78 $value[$_] = '' if $type[$_] =~ /[fs]/; 79 $log_file_ref = \$value[$_] if $opts[$_] eq 'L'; 80} 81 82my $f = $mw->Frame( -borderwidth => 5 )->pack( -expand => 1, -fill => 'both' ); 83 84my $fb = $f->Frame()->pack( -fill => 'x' ); 85my $fb1 = $fb->Frame()->pack( -side => 'left', -expand => 'y', -fill => 'x' ); 86$fb1->Button( -text => 'Pack', -command => sub { run_pp() } )->pack( -expand => 1, -fill => 'x' ); 87$fb1->Button( -text => 'View Log', -command => sub { view_log() } ) 88 ->pack( -expand => 1, -fill => 'x' ); 89my $fb2 = $fb->Frame()->pack( -side => 'left', -expand => 'y', -fill => 'x' ); 90$fb2->Button( -text => 'Open Opts', 91 -command => sub { open_opts(); } 92 )->pack( -expand => 1, -fill => 'x' ); 93$fb2->Button( -text => 'Save Opts', 94 -command => sub { save_opts(); } 95 )->pack( -expand => 1, -fill => 'x' ); 96my $fb3 = $fb->Frame()->pack( -side => 'left', -expand => 'y', -fill => 'x' ); 97$fb3->Button( -text => 'Exit', -command => sub { save_hist() } ) 98 ->pack( -expand => 1, -fill => 'x' ); 99$fb3->Button( -text => 'Help', -command => sub { help() } )->pack( -expand => 1, -fill => 'x' ); 100 101my $ff = $f->Frame( -borderwidth => 5, )->pack( -fill => 'x' ); 102my $fn = $ff->Frame()->pack( -side => 'left' ); 103$fn->Label( -text => 'Source File:' )->pack( -anchor => 'e' ); 104$fn->Label( -text => 'Output File:' )->pack( -anchor => 'e' ); 105my $fe = $ff->Frame()->pack( -side => 'left', -expand => 1, -fill => 'x' ); 106my $source_entry = $fe->HistEntry( -textvariable => \$source_file, 107 -width => 1, 108 -fg => $entry_font_color, 109 -selectbackground => $entry_font_color, 110 -dup => 0, 111 -case => 0, # works opposite of pod 112 -match => 1, 113 -limit => 10, 114 -command => sub { } 115 )->pack( -expand => 1, -fill => 'x' ); 116$source_entry->Subwidget('slistbox')->configure( -bg => 'white' ); 117my $output_entry = $fe->HistEntry( -textvariable => \$output_file, 118 -width => 1, 119 -fg => $entry_font_color, 120 -selectbackground => $entry_font_color, 121 -dup => 0, 122 -case => 0, # works opposite of pod 123 -match => 1, 124 -limit => 10, 125 -command => sub { } 126 )->pack( -expand => 1, -fill => 'x' ); 127$output_entry->Subwidget('slistbox')->configure( -bg => 'white' ); 128my $fg = $ff->Frame()->pack( -side => 'left', -fill => 'y' ); 129$fg->Button( 130 -text => '...', 131 -font => $dots_font, 132 -command => sub { 133 my $file = $mw->getOpenFile( -filetypes => $pl_types ); 134 if ($file) { 135 $source_file = $file; 136 $source_file = '"' . $source_file . '"' if $source_file =~ / / and $^O =~ /win32/i; 137 $source_entry->xview('end'); 138 $source_entry->historyAdd(); 139 } 140 } 141)->pack(-expand => 'y', -fill => 'y'); 142$fg->Button( 143 -text => '...', 144 -font => $dots_font, 145 -command => sub { 146 my $file = $mw->getSaveFile(); 147 if ($file) { 148 $output_file = $file; 149 $output_file = '"' . $output_file . '"' if $output_file =~ / / and $^O =~ /win32/i; 150 $output_entry->xview('end'); 151 $output_entry->historyAdd(); 152 } 153 } 154)->pack(-expand => 'y', -fill => 'y'); 155 156my $fo = 157 $f->LabFrame( -label => 'Options', -labelside => 'acrosstop' ) 158 ->pack( -expand => 1, -fill => 'both' ); 159my $p = $fo->Scrolled( 'Pane', 160 -scrollbars => 'osw', 161 -sticky => 'we', 162 )->pack( -expand => 1, -fill => 'both' ); 163for ( 0 .. $#opts ) { 164 next if $opts[$_] =~ /^[oh]$/; 165 166 my $fp = $p->Frame()->pack( -expand => 'y', -fill => 'both' ); 167 my $c = $fp->Checkbutton( -text => $opts[$_], 168 -variable => \$chkd[$_], 169 -selectcolor => 'white' 170 )->pack( -side => 'left' ); 171 $fp->Balloon( -bg => $balloon_color, -font => $balloon_font ) 172 ->attach( $c, -balloonmsg => $def[$_] ); 173 if ( $type[$_] =~ /[@%]/ ) { 174 if ( $type[$_] =~ /=/ ) { 175 $fp->Label( -text => '+' )->pack( -side => 'left' ); 176 } 177 else { 178 $fp->Label( -text => '*' )->pack( -side => 'left' ); 179 } 180 } 181 else { 182 $fp->Label( -text => ' ' )->pack( -side => 'left' ); 183 } 184 my $he; 185 if ( $type[$_] =~ /[fs]/ ) { 186 $he = $fp->HistEntry( -textvariable => \$value[$_], 187 -width => 1, 188 -fg => $entry_font_color, 189 -selectbackground => $entry_font_color, 190 -dup => 0, 191 -case => 0, # works opposite of pod 192 -match => 1, 193 -limit => 10, 194 -command => sub { }, 195 )->pack( -side => 'left', -expand => 'y', -fill => 'x' ); 196 $he->Subwidget('slistbox')->configure( -bg => 'white' ); 197 $hist_refs{ $opts[$_] } = $he; 198 } 199 if ( $type[$_] =~ /f/ ) { 200 $he->Subwidget('entry')->configure( -validate => 'key' ); 201 $he->Subwidget('entry')->configure( 202 -validatecommand => sub { 203 $_[0] =~ /^[+-]?\.?$| # starting entry 204 ^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d*))?$ # continuing entry 205 /x; # not validated if the entry ever actually finishes 206 } 207 ); 208 } 209 if ( $type[$_] =~ /i/ ) { 210 $fp->NumEntry( -textvariable => \$value[$_], 211 -width => 5, 212 -fg => $entry_font_color, 213 -selectbackground => $entry_font_color, 214 )->pack( -side => 'left' ); 215 } 216} 217 218my ( $hw, $hwt ); # help toplevel/text 219my ( $lw, $lwt ); # view log toplevel/text 220$mw->waitVisibility; 221 222open_opts( $ARGV[0] ) if $ARGV[0]; 223my $gpp_history = $ENV{HOME} || $ENV{HOMEPATH} || $FindBin::Bin; 224$gpp_history .= '/.gpp.history'; 225open_hist(); 226 227$source_entry->focus; 228MainLoop; 229 230sub find_pp { 231 my $pp = 'pp'; 232 $pp .= '.bat' if $^O =~ /win32/i; 233 return File::Spec->catfile( cwd(), $pp ) if -e $pp; 234 my @path = File::Spec->path(); 235 for (@path) { 236 my $full_name = File::Spec->catfile( $_, $pp ); 237 return $full_name if -e $full_name; 238 } 239 return undef; 240} 241 242sub open_opts { 243 my $opts_file = shift; 244 if ( !$opts_file ) { 245 $opts_file = $mw->getOpenFile( -filetype => $gpp_types ); 246 } 247 return if !$opts_file; 248 my ( $save_chkd, $save_value ); 249 if ( !open OH, "<$opts_file" ) { 250 $mw->messageBox( -title => 'Error', 251 -icon => 'error', 252 -message => "$opts_file: $!", 253 -type => 'OK' 254 ); 255 return; 256 } 257 my $opts_dump; 258 { 259 undef $/; 260 $opts_dump = <OH>; 261 } 262 close OH; 263 if ( $opts_dump !~ /\$save_chkd\s*=.*?\$save_value\s*=/s ) { 264 $mw->messageBox( -title => 'Error', 265 -icon => 'error', 266 -message => "$opts_file: Not a gpp option file !!", 267 -type => 'OK' 268 ); 269 return; 270 } 271 eval $opts_dump; 272 if ($@) { 273 $mw->messageBox( -title => 'Error', 274 -icon => 'error', 275 -message => "$opts_file: $@", 276 -type => 'OK' 277 ); 278 return; 279 } 280 for ( 0 .. $#opts ) { 281 if ( exists $save_chkd->{ $opts[$_] } ) { 282 $chkd[$_] = $save_chkd->{ $opts[$_] }; 283 $value[$_] = $save_value->{ $opts[$_] }; 284 } 285 } 286} ## end sub open_opts 287 288sub save_opts { 289 my $opts_file = 290 $mw->getSaveFile( -filetypes => $gpp_types, -defaultextension => $default_gpp_ext ); 291 return if !$opts_file; 292 my ( %save_chkd, %save_value ); 293 for ( 0 .. $#opts ) { 294 $save_chkd{ $opts[$_] } = $chkd[$_]; 295 $save_value{ $opts[$_] } = $value[$_]; 296 } 297 if ( !open OH, ">$opts_file" ) { 298 $mw->messageBox( -title => 'Error', 299 -icon => 'error', 300 -message => "$opts_file: $!", 301 -type => 'OK' 302 ); 303 return; 304 } 305 print OH Data::Dumper->Dump( [ $source_file, $output_file, \%save_chkd, \%save_value ], 306 [qw( source_file output_file save_chkd save_value )] ); 307 close OH; 308} 309 310sub open_hist { 311 return if !-e $gpp_history; 312 my ( $source_hist, $output_hist, $opts_hist ); 313 if ( !open HH, "<$gpp_history" ) { 314 $mw->messageBox( -title => 'Error', 315 -icon => 'error', 316 -message => "$gpp_history: $!", 317 -type => 'OK' 318 ); 319 return; 320 } 321 my $hist_dump; 322 { 323 undef $/; 324 $hist_dump = <HH>; 325 } 326 close HH; 327 if ( $hist_dump !~ /\$source_hist\s*=.*?\$output_hist\s*=/s ) { 328 $mw->messageBox( -title => 'Error', 329 -icon => 'error', 330 -message => "$gpp_history: Not a gpp history file !!", 331 -type => 'OK' 332 ); 333 return; 334 } 335 eval $hist_dump; 336 if ($@) { 337 $mw->messageBox( -title => 'Error', 338 -icon => 'error', 339 -message => "$gpp_history: $@", 340 -type => 'OK' 341 ); 342 return; 343 } 344 $source_entry->history($source_hist); 345 $output_entry->history($output_hist); 346 for ( 0 .. $#opts ) { 347 if ( exists $opts_hist->{ $opts[$_] } ) { 348 $hist_refs{ $opts[$_] }->history( $opts_hist->{ $opts[$_] } ); 349 } 350 } 351} ## end sub open_hist 352 353sub save_hist { 354 if ( !open HH, ">$gpp_history" ) { 355 $mw->messageBox( -title => 'Error', 356 -icon => 'error', 357 -message => "$gpp_history: $!", 358 -type => 'OK' 359 ); 360 return; 361 } 362 my ( $source_hist, $output_hist ); 363 $source_hist = [ $source_entry->history() ]; 364 $output_hist = [ $output_entry->history() ]; 365 for ( keys %hist_refs ) { 366 $hist_refs{$_} = [ $hist_refs{$_}->history() ]; 367 } 368 print HH Data::Dumper->Dump( [ $source_hist, $output_hist, \%hist_refs ], 369 [qw( source_hist output_hist opts_hist )] ); 370 close HH; 371 exit(); 372} 373 374sub view_log { 375 my $file = $$log_file_ref; 376 $file =~ s/^"(.*)"$/$1/; 377 return if !$file; 378 if ( !open LH, "<$file" ) { 379 $mw->messageBox( -title => 'Error', 380 -icon => 'error', 381 -message => "$file: $!", 382 -type => 'OK' 383 ); 384 return; 385 } 386 my $log_text; 387 { 388 undef $/; 389 $log_text = <LH>; 390 } 391 close LH; 392 if ( !Exists($lw) ) { 393 $lw = $mw->Toplevel( -title => 'Log file' ); 394 my ( $x, $y ) = ( $mw->geometry() =~ /^\d+x\d+\+(\d+)\+(\d+)/ ); 395 $lw->geometry( $default_size . '+' . ( $x + 20 ) . '+' . ( $y + 20 ) ); 396 $lw->minsize( 200, 30 ); 397 my $fb = $lw->Frame()->pack( -fill => 'x' ); 398 $fb->Button( -text => 'Close', -command => sub { $lw->withdraw() } ) 399 ->pack( -side => 'left', -expand => 'y', -fill => 'x' ); 400 $fb->Button( -text => 'Clear Log file', 401 -command => sub { open LH, ">$file"; close LH; $lw->withdraw() } 402 )->pack( -side => 'right' ); 403 $lwt = $lw->Scrolled( "Text", 404 -scrollbars => 'osw', 405 -wrap => 'none', 406 -height => 1, 407 -width => 1 408 )->pack( -expand => 1, -fill => 'both' ); 409 $lwt->insert( 'end', $log_text ); 410 $lw->focus(); 411 } 412 else { 413 $lwt->delete( '0.0', 'end' ); 414 $lwt->insert( 'end', $log_text ); 415 $lw->deiconify(); 416 $lw->raise(); 417 $lw->focus(); 418 } 419} ## end sub view_log 420 421sub help { 422 if ( !Exists($hw) ) { 423 $hw = $mw->Toplevel( -title => 'Help for pp' ); 424 my ( $x, $y ) = ( $mw->geometry() =~ /^\d+x\d+\+(\d+)\+(\d+)/ ); 425 $hw->geometry( $default_size . '+' . ( $x + 40 ) . '+' . ( $y + 40 ) ); 426 $hw->minsize( 100, 30 ); 427 $hw->Button( -text => 'Close', -command => sub { $hw->withdraw } )->pack( -fill => 'x' ); 428 my $parser = Pod::Simple::Text->new(); 429 my $pod; 430 $parser->output_string( \$pod ); 431 $parser->parse_string_document($pp_text); 432 $hwt = $hw->Scrolled( "Text", 433 -scrollbars => 'osw', 434 -wrap => 'none', 435 -height => 1, 436 -width => 1 437 )->pack( -expand => 1, -fill => 'both' ); 438 $hwt->insert( 'end', $pod ); 439 $hw->focus(); 440 } 441 else { 442 $hw->deiconify(); 443 $hw->raise(); 444 $hw->focus(); 445 } 446} 447 448sub run_pp { 449 my @pp_opts = (); 450 for ( 0 .. $#opts ) { 451 if ( $chkd[$_] ) { 452 if ( ( $type[$_] eq '' ) or ( $type[$_] =~ /:/ and $value[$_] eq '' ) ) { 453 push @pp_opts, '-' . $opts[$_]; 454 } 455 elsif ( $type[$_] =~ /[ifs]$/ ) { 456 push @pp_opts, '-' . $opts[$_]; 457 push @pp_opts, $value[$_]; 458 } 459 elsif ( $type[$_] =~ /[fs][@%]/ ) { 460 my @multi = (); 461 my $value = $value[$_]; 462 463 # Look for quoted strings first, then non-blank strings, 464 # separated by spaces, commas or semicolons 465 while ( $value =~ /\G\s*((['"])[^\2]*?\2)\s*[,;]?|\G\s*([^\s,;]+)\s*[,;]?/g ) { 466 push( @multi, defined($1) ? $1 : $3 ); 467 } 468 for $value (@multi) { 469 push @pp_opts, '-' . $opts[$_]; 470 push @pp_opts, $value; 471 } 472 } 473 } 474 } 475 if ($output_file) { 476 push @pp_opts, '-o'; 477 push @pp_opts, $output_file; 478 } 479 if ($source_file) { 480 push @pp_opts, $source_file; 481 } 482 print "$pp @pp_opts\n"; 483 $mw->Busy(); 484 485 system $pp, @pp_opts; 486 $mw->Unbusy(); 487 print "Done.\n\n"; 488} ## end sub run_pp