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