#!/usr/bin/perl -w use strict; use lib $ENV{ 'MAIN_CONF'} ; use main_config ; use Tk; my %commands = () ; if ( @ARGV <= 0 ) { push ( @{$commands{'help'}}, ' ' ) ; } else { (%commands) = main_config::get_commands ( @ARGV ) ; } my $PROC_ERROR = "FALSE" ; my $MACRO_FILE ="" ; my $keyword ; foreach $keyword ( sort keys (%commands) ) { if ( $keyword eq 'h' || substr($keyword, 0,4) eq "help" ) { goto HELP } if ( $keyword eq 'm' || substr($keyword, 0,5) eq "macro" ) { goto MACRO } print "unknown option >$keyword<\n" ; $PROC_ERROR = "TRUE" ; HELP: print << "END_OF_TEXT" ; -h|-help|--help) prints this message with available options and current status -m|--macro) file name of the created macro [$MACRO_FILE] END_OF_TEXT exit ; MACRO: $MACRO_FILE = shift ( @{$commands{$keyword}} ) ; next ; } if ( $PROC_ERROR eq "TRUE" ) { exit ; } ####################################### my $line ; my @whole_file = () ; my %key_list = () ; my $key ; #my $MACRO_FILE = "create_refine.pl" ; open ( MACRO, "$MACRO_FILE |" ) ; while() { chomp ; my $line = $_ ; push( @whole_file, $line ) ; } close(MACRO) ; $key = "" ; my $n_bra = 0 ; my @a_key = () ; my @b_key = () ; my @a_word = () ; my @b_word = () ; my @c_word = () ; my @text = () ; my $xx ; my $val ; my $chr ; my $nchr = 0 ; foreach $line ( @whole_file ) { # print $line, "\n" ; my @chr_array = split( '', $line ) ; @a_key = () ; $n_bra = 0 ; $nchr = 0 ; foreach $chr (@chr_array) { if ( $chr eq "\)" ) { $n_bra = $nchr } # elsif ( $n_bra == 0 ) { push( @a_key, $chr ) ; } else { push (@b_key, $chr ) ; } $nchr++ ; } if ( $nchr > 0 ) { if ( $n_bra > 0 ) { if ( $key ne "" && lc($key) ne "help" && lc($key) ne "doit" ) { gen_entry ( @text ) ; } $xx = join ( '', @a_key) ; @text = split( "-", $xx ) ; $key = pop( @text ) ; my $xx = join( '', @b_key ) ; @text = ( $xx ) ; @b_key = () ; # @{$key_list{$key}{'LINE'}} = ( $xx ); } else { $xx = join( '', @a_key ) ; # push( @{$key_list{$key}{'LINE'}}, "\n" ) ; # push( @{$key_list{$key}{'LINE'}}, $xx ) ; push ( @text, $xx ) ; # print " new line:", $xx, "\n" ; } } # print " TABLE: key >", $key, "< LINE: >", @{$key_list{$key}{'LINE'}}, "<\n" ; # print " TABLE: key >", $key, "< LINE: >", $key_list{$key}{'LINE'}, "<\n" ; # $key = "" ; } if ( $key ne "" && lc($key) ne "help" && lc($key) ne "doit" ) { gen_entry ( @text ) ; } my $max_length = 0 ; foreach $key ( sort keys %key_list ) { # print " TABLE: key >", $key, " LN:>", $key_list{$key}{'LINE'}, "<\n" ; if ( length($key_list{$key}{'LINE'}) > $max_length ) { $max_length = length($key_list{$key}{'LINE'}) ; } } ###################################################### my $mw = MainWindow->new; $mw->title("Tk: $MACRO_FILE"); my $f = $mw->Frame->pack(-side => 'bottom'); $f->Button(-text => "Quit", -command => sub { exit; })->pack(-side => 'left'); $f->Button(-text => "doit", -command => \&create_macro )->pack(-side => 'bottom'); my $t = $mw->Scrolled("Text", -width => $max_length + 30, -wrap => 'none')->pack(-expand => 10, -fill => 'both'); my $w ; my $text ; foreach $key ( keys %key_list ) { # $w = $t->Entry(-width => 12, -textvariable => \$key_list{$key}{'LINE'}); if ( $key_list{$key}{'KIND'} eq "VALUE" ) { $text = $key_list{$key}{'LINE'} ; $val = $key_list{$key}{'VALUE'} ; $w = $t->Label(-text => "$text", -justify => 'left', -relief => 'groove', -width => $max_length ); $t->windowCreate('end', -window => $w); $w = $t->Entry(-width => 12, -textvariable => \$key_list{$key}{'VALUE'} ); $t->windowCreate('end', -window => $w); $t->insert('end', "\n"); } elsif ( $key_list{$key}{'KIND'} eq "PAIR" ) { $text = $key_list{$key}{'LINE'} ; $val = $key_list{$key}{'VALUE'} ; $w = $t->Label(-text => "$text", -justify => 'left', -relief => 'groove', -width => $max_length ); $t->windowCreate('end', -window => $w); $w = $t->Entry(-width => 12, -textvariable => \$key_list{$key}{'ARRAY'}[0] ); $t->windowCreate('end', -window => $w); $w = $t->Entry(-width => 12, -textvariable => \$key_list{$key}{'ARRAY'}[1] ); $t->windowCreate('end', -window => $w); $t->insert('end', "\n"); } elsif ( $key_list{$key}{'KIND'} eq "THREES" ) { $text = $key_list{$key}{'LINE'} ; $val = $key_list{$key}{'VALUE'} ; $w = $t->Label(-text => "$text", -justify => 'left', -relief => 'groove', -width => $max_length ); $t->windowCreate('end', -window => $w); $w = $t->Entry(-width => 12, -textvariable => \$key_list{$key}{'ARRAY'}[0] ); $t->windowCreate('end', -window => $w); $w = $t->Entry(-width => 12, -textvariable => \$key_list{$key}{'ARRAY'}[1] ); $t->windowCreate('end', -window => $w); $w = $t->Entry(-width => 12, -textvariable => \$key_list{$key}{'ARRAY'}[2] ); $t->windowCreate('end', -window => $w); $t->insert('end', "\n"); } elsif ( $key_list{$key}{'KIND'} eq "LIST" ) { $text = $key_list{$key}{'LINE'} ; $w = $t->Label(-text => "$text", -justify => 'left', -relief => 'groove', -width => $max_length ); $t->windowCreate('end', -window => $w); $w = $t->Optionmenu(-width => 7, -textvariable => \$key_list{$key}{'VALUE'}, -options => [@{$key_list{$key}{'LIST'}} ] ); $t->windowCreate('end', -window => $w); $t->insert('end', "\n"); } } $t->configure(-state => 'disabled'); MainLoop; sub gen_entry { my @text_line = @_ ; my $n_brk = 0 ; my $nin = 0 ; my $xx ; my $chr ; @a_word = () ; @b_word = () ; @c_word = () ; $xx = join( " ", @text_line ) ; @text_line = split ( "", $xx ) ; foreach $chr (@text_line) { if ( $chr eq "\[" ) { $nin=1 } # elsif ( $chr eq "\]" ) { $xx = join ( "", @a_word ) ; push ( @c_word, $xx ) ; $n_brk++; $nin=0 ; @a_word = () ; } # elsif ( $nin == 0 ) { push( @b_word, $chr ) ; } else { push( @a_word, $chr ) ; } } # print " -- a_word:", @a_word, "\n" ; # print " -- b_word:", @b_word, "\n" ; # print " -- c_word:", @c_word, "\n" ; my $kind = "" ; $xx = join ("", @b_word ) ; $xx =~ s/current// ; $xx =~ s/=// ; $xx =~ s/:// ; my @chrs = split ( " ", $xx ) ; $val = pop (@c_word ) ; my @items = split( " - ", $val ) ; my $nn = scalar ( @items ) ; if ( $nn == 2 ) { $kind = "PAIR" ; } @items = split( ", ", $val ) ; $nn = scalar ( @items ) ; if ( $nn == 3 ) { $kind = "THREES" ; } # print " nn:", $nn, " items:", @items, "\n" ; if ( $kind eq "PAIR" ) { @items = split( " - ", $val ) ; $xx = join (" ", @chrs ) ; if ( scalar ( @c_word >= 1 ) ) { $xx = join ("", $xx, " [" , @c_word , "] " ) ; } # $xx = $xx . "[" . @c_word . "]" ; $key_list{$key}{'LINE'} = $xx ; $key_list{$key}{"KIND"} = "PAIR" ; @{$key_list{$key}{'ARRAY'}} = @items ; # print "items:", @items , "\n" ; # print "--------------> ", $key, " ARRAYS MENU:", $nn, ':>', @{$key_list{$key}{'ARRAY'}}, "<\n" ; } elsif ( $kind eq "THREES" ) { @items = split( ", ", $val ) ; $xx = join (" ", @chrs ) ; # $xx = $xx . "[" . @c_word . "]" ; $key_list{$key}{'LINE'} = $xx ; $key_list{$key}{"KIND"} = "THREES" ; @{$key_list{$key}{'ARRAY'}} = @items ; # print "items:", @items , "\n" ; # print "--------------> ", $key, " ARRAYS MENU:", $nn, ':>', @{$key_list{$key}{'ARRAY'}}, "<\n" ; } else { $key_list{$key}{'VALUE'} = $val ; $xx = join( "", @c_word ) ; @items = split ( "/", $xx ) ; $nn = scalar ( @items ) ; # print " ELSE / nn:", $nn, " items:", @items, "\n" ; if ( $xx =~ m/\// ) { $xx = join (" ", @chrs ) ; $key_list{$key}{'LINE'} = $xx ; # join ( " ", @chrs ) ; $key_list{$key}{"KIND"} = "LIST" ; @{$key_list{$key}{'LIST'}} = @items ; # print "--------------> ", $key, " = OPTION MENU:", $nn, ':>', @items, "<\n" ; } else { # print " -- a_word:", @a_word, "\n" ; # print " -- chrs_word:", @chrs, "\n" ; # print " -- c_word:", @c_word, "\n" ; $xx = join (" ", @chrs ) ; if ( scalar ( @c_word >= 1 ) ) { $xx = join ("", $xx, " [" , @c_word , "] " ) ; } # print " -- X_word:", $xx, "\n" ; $key_list{$key}{'LINE'} = $xx ; # join ( " ", @chrs ) ; $key_list{$key}{"KIND"} = "VALUE" ; # print "--------------> ", $key, " VALUE:", $nn, ':>', $val, "<\n" ; } } } sub create_macro { my @system_string = ( $MACRO_FILE ) ; foreach $key ( sort keys %key_list ) { my $ss_key = "--" . $key ; push (@system_string, $ss_key ) ; if ( $key_list{$key}{'KIND'} eq "PAIR" || $key_list{$key}{'KIND'} eq "THREES" ) { # print " ARRAY: ", @{$key_list{$key}{'ARRAY'}}, "\n" ; push (@system_string, @{$key_list{$key}{'ARRAY'}} ) ; } else { # print " VALUE: ", $key_list{$key}{'VALUE'}, "\n" ; push (@system_string, $key_list{$key}{'VALUE'} ) ; } } push (@system_string, "--doit" ) ; my $call = join (" ", @system_string ) ; print $call, "\n" ; system ( $call ) ; }