From a5a4c9905377379bebda0130a51662f14b2eda4a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 21 Nov 2024 17:08:56 -0500 Subject: [PATCH] Remove GMAO_perllib into its own repo --- .gitignore | 3 + CHANGELOG.md | 2 + GMAO_perllib/CMakeLists.txt | 22 - GMAO_perllib/ESMA/Esma.pm | 139 - GMAO_perllib/ESMA/Rc.pm | 400 -- GMAO_perllib/ESMA/TkRc.pm | 1120 ---- GMAO_perllib/GrADS/Grads.pm | 2195 ------- GMAO_perllib/GrADS/Grads/Gerl.pm | 1282 ---- GMAO_perllib/Net/Cmd.pm | 591 -- GMAO_perllib/Net/Config.pm | 212 - GMAO_perllib/Net/Domain.pm | 331 - GMAO_perllib/Net/DummyInetd.pm | 148 - GMAO_perllib/Net/FTP.pm | 1642 ----- GMAO_perllib/Net/FTP/A.pm | 99 - GMAO_perllib/Net/FTP/E.pm | 7 - GMAO_perllib/Net/FTP/I.pm | 70 - GMAO_perllib/Net/FTP/L.pm | 7 - GMAO_perllib/Net/FTP/dataconn.pm | 123 - GMAO_perllib/Net/NNTP.pm | 1060 ---- GMAO_perllib/Net/Netrc.pm | 326 - GMAO_perllib/Net/PH.pm | 784 --- GMAO_perllib/Net/POP3.pm | 521 -- GMAO_perllib/Net/SFTP/Foreign.pm | 5651 ----------------- GMAO_perllib/Net/SFTP/Foreign/Attributes.pm | 348 - .../Net/SFTP/Foreign/Attributes/Compat.pm | 55 - GMAO_perllib/Net/SFTP/Foreign/Backend/Unix.pm | 458 -- .../Net/SFTP/Foreign/Backend/Windows.pm | 121 - GMAO_perllib/Net/SFTP/Foreign/Buffer.pm | 218 - GMAO_perllib/Net/SFTP/Foreign/Common.pm | 440 -- GMAO_perllib/Net/SFTP/Foreign/Compat.pm | 297 - GMAO_perllib/Net/SFTP/Foreign/Constants.pm | 246 - GMAO_perllib/Net/SFTP/Foreign/Helpers.pm | 336 - GMAO_perllib/Net/SFTP/Foreign/Local.pm | 138 - GMAO_perllib/Net/SMTP.pm | 596 -- GMAO_perllib/Net/SNPP.pm | 414 -- GMAO_perllib/Net/Telnet.pm | 4437 ------------- GMAO_perllib/Net/Time.pm | 147 - GMAO_perllib/Net/libnet.cfg | 14 - GMAO_perllib/Net/libnetFAQ.pod | 321 - GMAO_perllib/Time/CTime.pm | 197 - GMAO_perllib/Time/DaysInMonth.pm | 75 - GMAO_perllib/Time/JulianDay.pm | 200 - GMAO_perllib/Time/ParseDate.pm | 1194 ---- GMAO_perllib/Time/Timezone.pm | 272 - GMAO_perllib/Time/Zone.pm | 268 - GMAO_perllib/XML/Simple.pm | 3054 --------- 46 files changed, 5 insertions(+), 30576 deletions(-) delete mode 100644 GMAO_perllib/CMakeLists.txt delete mode 100755 GMAO_perllib/ESMA/Esma.pm delete mode 100755 GMAO_perllib/ESMA/Rc.pm delete mode 100755 GMAO_perllib/ESMA/TkRc.pm delete mode 100755 GMAO_perllib/GrADS/Grads.pm delete mode 100755 GMAO_perllib/GrADS/Grads/Gerl.pm delete mode 100755 GMAO_perllib/Net/Cmd.pm delete mode 100755 GMAO_perllib/Net/Config.pm delete mode 100755 GMAO_perllib/Net/Domain.pm delete mode 100755 GMAO_perllib/Net/DummyInetd.pm delete mode 100755 GMAO_perllib/Net/FTP.pm delete mode 100755 GMAO_perllib/Net/FTP/A.pm delete mode 100755 GMAO_perllib/Net/FTP/E.pm delete mode 100755 GMAO_perllib/Net/FTP/I.pm delete mode 100755 GMAO_perllib/Net/FTP/L.pm delete mode 100755 GMAO_perllib/Net/FTP/dataconn.pm delete mode 100755 GMAO_perllib/Net/NNTP.pm delete mode 100755 GMAO_perllib/Net/Netrc.pm delete mode 100755 GMAO_perllib/Net/PH.pm delete mode 100755 GMAO_perllib/Net/POP3.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Attributes.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Attributes/Compat.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Backend/Unix.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Backend/Windows.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Buffer.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Common.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Compat.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Constants.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Helpers.pm delete mode 100644 GMAO_perllib/Net/SFTP/Foreign/Local.pm delete mode 100755 GMAO_perllib/Net/SMTP.pm delete mode 100755 GMAO_perllib/Net/SNPP.pm delete mode 100755 GMAO_perllib/Net/Telnet.pm delete mode 100755 GMAO_perllib/Net/Time.pm delete mode 100644 GMAO_perllib/Net/libnet.cfg delete mode 100755 GMAO_perllib/Net/libnetFAQ.pod delete mode 100755 GMAO_perllib/Time/CTime.pm delete mode 100755 GMAO_perllib/Time/DaysInMonth.pm delete mode 100755 GMAO_perllib/Time/JulianDay.pm delete mode 100755 GMAO_perllib/Time/ParseDate.pm delete mode 100755 GMAO_perllib/Time/Timezone.pm delete mode 100755 GMAO_perllib/Time/Zone.pm delete mode 100644 GMAO_perllib/XML/Simple.pm diff --git a/.gitignore b/.gitignore index 2c350ed6..697cb86a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,6 @@ /@GEOS_Util/ /GEOS_Util/ /GEOS_Util@/ +/@GMAO_perllib/ +/GMAO_perllib/ +/GMAO_perllib@/ diff --git a/CHANGELOG.md b/CHANGELOG.md index 8b43922d..a664a03e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Removed +- Remove `GMAO_perllib` into its own repository + ## [1.9.9] - 2024-10-03 ### Changed diff --git a/GMAO_perllib/CMakeLists.txt b/GMAO_perllib/CMakeLists.txt deleted file mode 100644 index 6d32a78b..00000000 --- a/GMAO_perllib/CMakeLists.txt +++ /dev/null @@ -1,22 +0,0 @@ -esma_set_this() - -# add a dummy target so that GMAO_etc can depend -# on GMAO_perllib - -add_custom_target(${this} ALL) - -set(perldirs - ESMA - GrADS - Net - Time - XML - ) - -foreach(perldir ${perldirs}) - install ( - DIRECTORY ${perldirs} - DESTINATION bin - USE_SOURCE_PERMISSIONS - ) -endforeach() diff --git a/GMAO_perllib/ESMA/Esma.pm b/GMAO_perllib/ESMA/Esma.pm deleted file mode 100755 index 5a86143d..00000000 --- a/GMAO_perllib/ESMA/Esma.pm +++ /dev/null @@ -1,139 +0,0 @@ -package Esma; -# -# This module implements a base class for creating driving scripts for -# ESMA applications. -# -#--- -# -# This program is free software; you can redistribute it and/or modify it -# under the same terms as Perl itself. -# -# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES -# OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE -# -# REVISION HISTORY: -# -# 28Oct2006 da Silva Initial implementation loosely based on the -# functionality of GEOS-4 "fvpsas" script, but -# adopting an OO approach. -# -#-------------------------------------------------------------------------- - -require 5.000; -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(new setup} - -#......................................................................... - - use FileHandle; - use Carp; - use Env; # Environment variables - - $VERSION = 1.00; - -# The public ESMA object -# ---------------------- -my %esma = { - - ExpID => undef, # Experiment ID - ExpDescr => undef, # Experiment description - - ExpCF => {}, # User supplied configuration parameters - - ExpHomeDir => undef, # Where the experiment scripts, recycles reside - # (same as FVHOME in GEOS-4) - ExpExecDir => undef, # Where the job actually runs (FVWORK) - ExpParkDir => undef, # Truck stop before mass storage destination - ExpArchDir => undef, # Mass storage destination - - EsmaDir => undef, # Where system binaries have been installed - - Restarts => [], # list of restarts to be brought over - Resources => [], # list of resources to be brought over - Children => [], # children components - - Debug => undef, # whether to print out debug info - -}; - -#......................................................................... - -sub new { # Constructor - - my $that = shift; - my $class = ref($that) || $that; - - my ( $argv ) = @_; - -# Record input args -# ----------------- - $esma{ExpID} = $argv->{ExpID}; - $esma{ExpDescr} = $argv->{ExpDescr}; - $esma{ExpCF} = $argv->{ExpCF}; - - $esma{ExpHomeDir} = $argv->{ExpHomeDir}; - $esma{ExpExecDir} = $argv->{ExpExecDir}; - $esma{ExpParkDir} = $argv->{ExpParkDir}; - $esma{ExpArchDir} = $argv->{ExpArchDir}; - $esma{EsmaDir} = $argv->{EsmaDir}; - - $esma{Restarts} = $argv->{Restarts}; - $esma{Resources} = $argv->{Resources}; - $esma{Children} = $argv->{Children}; - - $esma{Debug} = $argv->{Debug}; - -# Bless it -# -------- - $self = { %ema, }; - bless $self, $class; - - return $self; - -} - -#.......................................................................... - -sub setup { # Prepares the run environment - my $self = shift; - -} - -#.......................................................................... - -sub acquire { # Acquires necessary data - my $self = shift; - -} - -#.......................................................................... - -sub run { # Executes the poor component - my $self = shift; - -} - -#.......................................................................... - -sub deliver { # Archives/disposes of run output - my $self = shift; - -} - -#.......................................................................... - -sub DESTROY { # Destructor - - my $self = shift; - - print "Destroyed Esma object associated with $self->{file}\n" - if ( $self->{debug} ); - - $self->{ExpID} = undef; - -} - -#.......................................................................... diff --git a/GMAO_perllib/ESMA/Rc.pm b/GMAO_perllib/ESMA/Rc.pm deleted file mode 100755 index 8bcfbf49..00000000 --- a/GMAO_perllib/ESMA/Rc.pm +++ /dev/null @@ -1,400 +0,0 @@ -package Rc; -# -# This Class implements a Perl interface to Resource files. It has -# methods for reading/parsing and writing resource files. -# -#--- -# -# This program is free software; you can redistribute it and/or modify it -# under the same terms as Perl itself. -# -# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES -# OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE -# -# REVISION HISTORY: -# -# 09Oct2006 da Silva Initial implementation based on code fragments -# from the original "red" script. -# -#-------------------------------------------------------------------------- - -require 5.000; -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(new dump write); - -#......................................................................... - - use FileHandle; - use Carp; - use Env; # Environment variables - - $VERSION = 1.00; - -# The public Rc object -# -------------------- - my %rc = { - - file => undef, # file name of the associated resource file - name => undef, # name of the resource file - title => undef, # title of the resource file - Line => undef, # each line of the resource file: as is - Help => undef, # parsed help information - Hist => undef, # parsed revision information - Ui => undef, # parsed user interface - debug => undef, # print things as it goes along; mostly for debugging - critique => undef, # callback for critique of user input - }; - -#......................................................................... - -sub new { # Constructor - - my $that = shift; - my $class = ref($that) || $that; - - my ( $argv ) = @_; - - my $file = $argv->{file}; - my $debug = $argv->{debug}; - -# Record input args -# ----------------- - $rc{file} = $file; - $rc{debug} = $debug; - -# Bless it -# -------- - $self = { %rc, }; - bless $self, $class; - - $self->_parseFile(); # _parse is kind of private - - return $self; - -} - -#.......................................................................... - -sub DESTROY { # Destructor - - my $self = shift; - - print "Destroyed Rc associated with $self->{file}\n" - if ( $self->{verb} ); - - $self->{file} = undef; - $self->{name} = undef; - $self->{title} = undef; - $self->{Line} = undef; - $self->{Help} = undef; - $self->{Hist} = undef; - $self->{Ui} = undef; - $self->{Dict} = undef; - $self->{debug} = undef; - -} - -#.......................................................................... - -sub _parseFile { # reads and parses a resource file - - my $self = shift; - -# Local short hands -# ----------------- - my $RCname = undef; # Resource File name - my $RCtitle = undef; # Resource title - my @Line = (); # Actual RC lines - my @UI = (); # parsed user interface tokens - my %Dict = {}; - - $i = -1; # line index - $m = -1; # GUI index (actual questions) - - $file = $self->{file}; - $debug = $self->{debug}; - -# Open the file -# ------------- - open (FILE, $file) or confess "cannot open file $file"; - -# Main loop over lines on file -# ---------------------------- -LINE: - while () { - - chop; # strip record separator - - $line = $_; - - $i++; - push @Line, $line; # store all lines for later output - - @Fld = split(' ', $_, 9999); - - if ( $Fld[0] eq '#BOP' ) { - $doing_help = 0; - $doing_hist = 0; - $doing_prol = 1; - next LINE; - } - - if ( $Fld[1] eq '!RESOURCE:' ) { - $RCname = $Fld[2]; - shift @Fld; - shift @Fld; - shift @Fld; - shift @Fld; - $RCtitle = join(' ', @Fld ); - next LINE; - } - - if ( $Fld[1] eq '!HELP:' ) { - $doing_help = 1; - next LINE; - } - - if ( $Fld[1] eq '!REVISION' ) { - $doing_help = 0; - $doing_hist = 1; - next LINE; - } - - if ( $Fld[0] eq '#EOP' ) { - $doing_help = 0; - $doing_hist = 0; - $doing_prol = 0; - next LINE; - } - - if ( $doing_help ) { - $help = $line; - $help =~ s/^\#/ /; - push @Help, $help; - } - - if ( $doing_hist ) { - $hist = $line; - $hist =~ s/^\#/ /; - # print "hist = $hist\n"; - push @Hist, $hist; - } - - next LINE if ( $doing_prol ); - - ( $tmp, $cmd ) = split('#', $_, 2); # rcv = resource value - ( $rcn, $rcv ) = split(':', $tmp, 2); # rcn = resource name - $rcn =~ s/[ ]*\?[ ]*/\?/; - $cmd =~ s/^\#[ ]*//; # cmd = GUI directive - - $rcn = $rcn . ":" if $rcv; # put ":" back in label - -# Continue if a UI command is found -# --------------------------------- -### next LINE unless ( $rcv =~ /[ ]*\?/ || $cmd =~ /[ ]*&/ ); - -# Is this an UI line? -# ------------------- -### if ( $rcv =~ /[ ]*\?/ || $rcv eq "" ) { - if ( $rcv =~ /[ ]*\?/ || $cmd =~ /[ ]*&/ ) { - -# Parse widget and args -# --------------------- - $m++ if ( $rcv ); # keep track of questions - $rcv =~ s/[ ]*\?[ ]*//; # strip out "?" - - if ( $cmd =~ /[ ]*&/ ) { - ( $rcw, $rca ) = split(' ', $cmd, 2); - } - else { - $cmd =~ s/[ ]*//; - $rcw = "&Str"; # default widget name - $rca = $cmd; - } - -# Record user interface request -# ----------------------------- - $tokens = { - index => $i, # line index in original rc file - name => $rcn, # resource name - value => $rcv, # actually, the default resource value - widget => $rcw, # the widget name - args => $rca, # the arguments for the widget - set => 1, # always UI as been set - }; - - push @UI, $tokens; # sequential array with UI tokens - - } else { - - $tokens = { - index => $i, # line index in original rc file - name => $rcn, # resource name - value => $rcv, # actually, the default resource value - widget => $cmd, # not really the widget name - args => undef, # the arguments for the widget - set => 0, # whether it has been modified by a set() - }; - } - - $Dict{$rcn} = $tokens; # hash with parsed line indexed by resource name - - - } # end LINE - -# All done with file -# ------------------ - close(FILE); - -# Record results into object -# -------------------------- - $self->{name} = $RCname; - $self->{title} = $RCtitle; - $self->{Line} = \@Line; - $self->{Help} = \@Help; - $self->{Hist} = \@Hist; - $self->{Ui} = \@UI; - $self->{Dict} = \%Dict; - -# Debugging output -# ---------------- - $self->dump() if ( $debug ); - -} - -#.......................................................................... -sub _parseLine { # parse a resource line - my $self = shift; - my $line = shift; - -} - -#.......................................................................... -sub dump { # output, mostly for debugging - - my $self = shift; - -# Convenience counters -# -------------------- - my $nLine = @{$self->{Line}}; - my $nHelp = @{$self->{Help}}; - my $nHist = @{$self->{Hist}}; - my $nUi = @{$self->{Ui}}; - -# Debugging information, if requested -# ----------------------------------- - print "\n" ; - print " NAME: ", $self->{name}, "\n"; - print " TITLE: ", $self->{title},"\n"; - for ( $i=0; $i < $nHelp; $i++ ) { - print " HELP: ",$self->{Help}[$i],"\n"; } - for ( $i=0; $i < $nHist; $i++ ) { - print " HIST: ",$self->{Hist}[$i],"\n"; } - for ( $i=0; $i < $nUi; $i++ ) { - $ui = $self->{Ui}->[$i]; - print "\n"; - print " LABEL: |$ui->{name}| ($ui->{index})\n"; - print " VALUE: |$ui->{value}|\n"; - print "WIDGET: |$ui->{widget}|\n"; - print " ARGS: |$ui->{args}|\n"; - } - -} - -#.......................................................................... - -sub write { # writes out resource file - - my $self = shift; - my $argv = shift; - - my $file = $argv->{file}; # outputfile name - my $xenv = $argv->{xenv}; # expand environment variables - - my $rLine = $self->{Line}; - my $nLine = @{$rLine}; - - $file = '-' unless($file); - -# Commit changes unless told not to -# --------------------------------- - $self->commit() unless ( $argv->{NoCommit} ); - -# Open -# ---- - if ( $file eq "-" ) { - open(FILE,">&STDOUT"); - } else { - open(FILE,">$file") or confess "cannot open $file"; - } - -# Write -# ----- - if ( $xenv ) { - for ( my $i=0; $i < $nLine; $i++ ) { - $evalline = $rLine->[$i]; - eval "\$eLine = \"$evalline\"" ; # expand environmnet - printf FILE "%s\n", "$eLine"; } - } else { - for ( my $i=0; $i < $nLine; $i++ ) { - printf FILE "%s\n", $rLine->[$i]; - } - } - -# Close -# ----- - close(FILE); - -} - -#......................................................................... -sub commit { # commit changes made to UI resources - - my $self = shift; - my $argv = shift; - - my $Line = $self->{Line}; - my $Dict = $self->{Dict}; - - foreach $key ( keys %{$Dict} ) { - if ( $Dict->{$key}->{'set'} ) { - $j = $Dict->{$key}->{'index' }; - $name = $Dict->{$key}->{'name' }; - $value = $Dict->{$key}->{'value' }; - $widget = $Dict->{$key}->{'widget'}; - $args = $Dict->{$key}->{'args' }; - $Line->[$j] = $name . " " . $value . " # " . - $widget . " " . $args; -# print $self->{'file'} . " <$key> <$value> NEW LINE: " . $Line->[$j] . "\n"; - } - } - -} - -#......................................................................... -sub set { # update value of an UI resource - my $self = shift; - my $name = shift; - my $value = shift; - my $token; - return undef unless ( $token = $self->{Dict}->{$name} ); - $token->{'set'} = 1; # so that we now to commit it - return $token->{'value'} = $value; -} - -#......................................................................... -sub get { # update value of an UI resource - my $self = shift; - my $name = shift; - $value = $self->{Dict}->{$name}->{value}; - return $value; -} - -1; - - - - diff --git a/GMAO_perllib/ESMA/TkRc.pm b/GMAO_perllib/ESMA/TkRc.pm deleted file mode 100755 index 1041757c..00000000 --- a/GMAO_perllib/ESMA/TkRc.pm +++ /dev/null @@ -1,1120 +0,0 @@ -package TkRc; -# -# This Class implements a Perl interface to a Tk GUI for Resource files. -# It is created from a list of RC objects which have possibly registered -# "critique" methods. It can also be created from a list of files. -# -#--- -# -# This program is free software; you can redistribute it and/or modify it -# under the same terms as Perl itself. -# -# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES -# OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE -# -# REVISION HISTORY: -# -# 23May2007 da Silva Initial implementation based on code fragments -# from the original "red" script. -# -#-------------------------------------------------------------------------- - -require 5.000; -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(new dump write); - -#......................................................................... - - use FileHandle; - use Carp; - use Env; # Environment variables - use ESMA::Rc; # Resource file class - - use Getopt::Std; # command line options - use Tk; # Tk GUI - use Tk::DirTree; # Tk Directory - use FindBin; # so we can find where this script resides - use File::Path; # for mkpath() - use File::Copy "cp"; # for cp() - use File::Basename; # for basename(), dirname() - use MIME::Base64 (); # for MIME base 64 nasa logo - - $VERSION = 1.00; - -# The public RC object -# -------------------- -my %tkrc = { - - Files => [], # List of file names - Rcs => [], # List of already parsed resources - debug => undef, # print things as it goes along; mostly for debugging -}; - -# Class scope data, for now -# ------------------------- - $ROOTDIR = ""; - -# $rightwidget_width = 1020; - $textentrywidth = 18; - $textqcolor = "#FEFEFE"; - $textentrycolor = "#EFEFDF"; - $textitemcolor = "#DFCFCF"; - $textframecolor = "#FFFEF0"; - - $titlecolor = "#DCF1dF"; - $radioqcolor = "#FEFEFE"; - -# $radioframecolor = "#FFEEEE"; - $radioframecolor = "#FFFEF0"; - $radioitemcolor = "#DFCFCF"; - $radiobuttoncolor = "#EFEFDF"; - - $checkframecolor = "#FFFEF0"; - $checkbuttoncolor = "#EFEFDF"; - $checkbackground = "#FEFEFE"; - - $filebrowsecolor = "#FEFEFE"; - $filebrowseframe = "#FFEEEE"; - $filelabelcolor = "#FEFEFE"; - $fileframecolor = "#FFFEF0"; - $fileentrycolor = "#EFEFDF"; - - $dirbrowsecolor = "#FEFEFE"; - $dirbrowseframe = "#FFEEEE"; - $dirlabelcolor = "#FEFEFE"; - $dirframecolor = "#FFFEF0"; - $direntrycolor = "#EFEFDF"; - - $buttoncolor = "#EFE4CF"; - $buttonframecolor = "#EEEEF1"; - - $mainframecolor = "#E1DAE0"; - - $logo = ___LoadLogo(); - -#......................................................................... - -sub new { # Constructor - - my $that = shift; - my $class = ref($that) || $that; - - my ( $argv ) = @_; - - my $Files = $argv->{Files}; - my $Rcs = $argv->{Rcs}; - my $debug = $argv->{debug}; - -# If file list specified, load those files -# ---------------------------------------- - $Rcs = ___ReadFiles($Files) if ( $Files ); - - print "After ReadFiles\n"; - -# Record input args -# ----------------- - $tkrc{Files} = $Files; # list of files - $tkrc{Rcs} = $Rcs; # list of RC objects - $tkrc{debug} = $debug; - - print "Before blessing\n"; - -# Bless it -# -------- - $self = { %tkrc, }; - bless $self, $class; - - print "Done with new TkRc\n"; - - return $self; - -} - -#.......................................................................... - -sub DESTROY { # Destructor - - my $self = shift; - - print "Destroyed TkRC object\n" - if ( $self->{debug} ); - - $self->{Files} = undef; - $self->{Rcs} = undef; - $self->{debug} = undef; - -} - -#.......................................................................... - -sub MainLoop { # Enter Tk Main Loop, no returns - - $main = MainWindow -> new; - my $name, $default, $value, $widget, $args; - -# Setup widgets -# ------------- - print "before new MainGUI\n"; - ___MainGUI($RCfilename[0]); - print "before Create Widget\n"; - ___CreateWidget($RCfilename[0]); - -# Go for it -# --------- - print "before MainLoop\n"; - MainLoop; # there will no return from here - -} - -#.......................................................................... - -sub ___ReadFiles { - my $Files = shift; - my $rc = undef; - my @Rcs = (); - foreach $file ( @{$Files} ) { - $rc = new Rc { file=>"$file"} or - confess "Cannot load RC from file $file"; - push @Rcs, $rc; - } - return \@Rcs; -} - -#.......................................................................... - -sub ___MainGUI { - my ($file) = @_; - - print "create_mainGUI\n" if ($debug); - - $main -> title("RED - Resource File EDitor"); - $filemenuframe = $main -> Frame(-height=>35); - - Tk_FileMenu($file); - - $filemenuframe -> pack(-side=>'top',-anchor=>'w'); - $submain = $main -> Frame(-relief => 'ridge', - -borderwidth=>2, -background => '#FFAAAA', ); - $leftframe = $submain -> Frame(-relief => 'ridge', - -background => '#FFDDDD',-width=>100); - - Tk_LeftWidget($file); - - $leftframe -> pack ( -side=>'left', -fill => 'y', - -anchor=>'w', -padx => 1, -pady => 1); - $rightframe = $submain -> Frame(-relief => 'ridge', -width=>800, - -borderwidth=>1, - -background => '#FFAAAA',); - - Tk_RightWidget($file); - - $rightframe -> pack(-anchor => 'nw', - -side => 'top', - -fill => 'both', - -expand => 1, - -padx => 1, - -pady => 0 - ); - - $submain -> pack(-anchor => 'nw', - -side => 'top', - -fill => 'both', - -expand => 1, - -padx => 1, - -pady => 1, - - ); - - $buttonframe =$main-> Frame( - -background=> $buttonframecolor, - -relief => 'groove', - -height => 40 - ); - $buttonframe -> pack( - -side =>'bottom', - -anchor=>'s', - -padx => 2, - -pady => 3, - -fill =>'both', - -expand =>1 - ); - - -} - -#.......................................................................... - -sub ___CreateWidget { # Create Tk Widgets - my ($file) = @_; - print "createwidget: file = $file \n" if ($debug); - print "\n\n Editing ",$RCtitle{$file},"\n" if ($nUI{$file} > 0 && $debug); - - Tk_TextEntry(-1,"OUTPUT FILE NAME", $outfn{$file}, $file); - -for ( my $i=0; $i < $nUI{$file}; $i++ ) { - - $name = $UI[$i]{'name' }{$file}; - $default = $UI[$i]{'value' }{$file}; - $widget = $UI[$i]{'widget'}{$file}; - $args = $UI[$i]{'args' }{$file}; - $value = $default; - - - for ( $widget ) { - -SWITCH: { - - /^\&Label/ && do { - Tk_Label($args); - print "TK:$args\n" if ($debug); - last SWITCH; - }; - - /^\&Str/ && do { - $value = $default; - Tk_TextEntry($i,$args, $default, $file); - print "TK:$args [$default]\n" if ($debug); - #chomp($ans = ); - #$ans and $value = $ans; - #print ""; # cosmetic - last SWITCH; - }; - - /^\&Dir/ && do { - $default =~ s/[ ]*//g; - $value = $default; - print "TK:$args [$default]\n" if ($debug); - Tk_Dir($i,$args,$default, $file); - last SWITCH; - }; - - /^\&File/ && do { - $default =~ s/[ ]*//g; - $value = $default; - print "TK:$args [$default]\n" if ($debug); - Tk_File($i,$args,$default, $file); - last SWITCH; - }; - - /^\&YesNo/ && do { - $default =~ s/[ ]*//g; - $value = $default; - Tk_YesNo($i, $args, $default, $file); - last SWITCH; - }; - - /^\&CheckBox/ && do { - $default =~ s/[ ]*//g; - Tk_CheckBox($i, $args, $file); - last SWITCH; - }; - }} # SWITCH - # updated resource file - } # for each UI request - - Tk_Buttons($file); - my $y = ($nUI{$file}) * $elementfontsize * 2 + 140; - my $x = 555; - my $geometry = $x . "x" . $y; - print "geometry = $geometry" if ($debug); - $main->geometry($geometry); -} - -#.......................................................................... - -sub Tk_DirBrowse { - my ($i,$text, $path, $file) = @_; - #my ($direntry); - - if ($path =~ /^\$/gi) { - $evalline = $path; - eval "\$path = \"$evalline\"" ; # expand environmnet - } - - $ok = 0; # flag: "1" means OK, "-1" means cancelled - $newtoplevel -> destroy() if (Exists $newtoplevel); - $newtoplevel = MainWindow -> new(-relief=>'ridge', - -borderwidth=> 5, -background=>$filebrowseframe); - $newtoplevel -> Label ( -background => $filelabelcolor, - -text => $text, -font=> "Arial 16 bold", - )-> pack(-side => 'top', -padx => 6, -pady=>1 ); - $dirtree = $newtoplevel -> Scrolled('DirTree', - -background=> $filebrowsecolor, - -scrollbars => 'osoe' , -width => 44, -height => 10, - -selectmode => 'browse', -exportselection => 1, - -browsecmd => sub { - chomp($path); - #print "dirtree: var $var , value $path\n"; - #$UI[$i]{'value'}{$file} = $path; - $path = shift; - $path =~ s/\/\//\//g; - #print "path = $path \n"; - $direntry{$i}-> delete(0, 'end'); - $direntry{$i}-> insert(0, "$path"); - - }, - # With this version of -command a double-click will - # select the directory - #-command => sub { $ok = 1 }, - - # With this version of -command a double-click will - # open a directory. Selection is only possible with - # the Ok button. - #-command => sub { $d->opencmd($_[0]) }, - -command => sub { $newtoplevel -> destroy(); }, - )->pack(-side => 'top', -fill => "both", -expand => "both"); - # Set the initial directory - if (-d $path) { $dirtree -> chdir($path); - $dirtree -> update(); - } else { - $newtoplevel -> Label(-text => "$path does not exist"); - #print "path $path does not exist\n"; - $dirtree -> chdir( dirname($path) ) if (Exists $dirtree); - } - $newtoplevel -> Button(-text => "Apply", - -command => sub { - $path = $direntry{$i} -> get(); -# $path = shift; - $path =~ s/\/\//\//g; - chomp($path); - #print "dirtree: var $var , value $path\n"; - #$UI[$i]{'value'}{$file} = $path; - - - print "path = $path \n"; - $UI[$i]{'value'}{$file} = $path; - $newtoplevel -> destroy(); - } - )-> pack (-side=>'top', -padx=>6, -pady=>1); - $newtoplevel -> update(); - #$newtoplevel->geometry("310x300+$xpos+$ypos"); - #$newtoplevel->positionfrom("program"); - $newtoplevel->title("RED DIR Browser GUI"); - - return 0; -} - -#.......................................................................... - -sub Tk_Dir{ - my ($i,$question,$default, $file) = @_; - - my $dirframe = $rightwidget -> Frame(-background=>$dirframecolor,-height=>35); - - $width = 20 if (! defined $width); - my $leftframe = $dirframe -> Frame(-background=>$dirframecolor); - my $rightframe = $dirframe -> Frame(-background=>$dirframecolor); - - $leftframe -> Label (-background => $dirlabelcolor, -text => $question,-font=>$elementfont, - )-> pack(-side => 'left',-padx => 4, -pady => 1); - $rightframe -> Button(-text => "Browse", - -command => sub { &Tk_DirBrowse($i,$question,$default,$file); } - )-> pack(-side => 'left',-padx=>3); - $direntry{$i} = $rightframe -> Entry(-background=> $direntrycolor,-width=> $textentrywidth )-> pack(-side => 'right'); - $direntry{$i} -> insert(0,"$default"); - $leftframe -> pack(-side => 'left', -anchor=> 'w', -padx => 2, -pady => 1); - $rightframe-> pack(-side => 'right',-anchor=> 'e', -padx => 3, -pady => 1); - $dirframe -> pack(-side => 'top', -padx => 2, -pady => 1, -fill=>'both'); - -# Set the initial directory -# if (! -e $path) { ("$path does not exist"); }# -# - $direntry{$i} -> bind('', sub { - print "direntry: $checkbox " if ($debug); - $path = $direntry{$i} -> get(); - chomp($path); print "dirtree: var $var , value $path\n" if ($debug); - $UI[$i]{'value'}{$file} = $path; - } - ); - return 0; -} -sub Tk_Dir2{ - my ($i,$question,$default, $file) = @_; - my $dirframe = $rightwidget -> Frame(-background=>$dirframecolor, -height=>30); - my ($direntry); - $width = 20 if (! defined $width); - my $leftframe = $dirframe -> Frame(-background=>$dirframecolor); - my $rightframe = $dirframe -> Frame(-background=>$dirframecolor); - $leftframe -> Label (-background => $dirlabelcolor, -font=>$elementfont, - -text => $question - )-> pack(-side => 'left',-padx => 4, -pady => 0); - - - $rightframe -> Button(-text => "Browse", - -command => sub { - $path = $rightframe -> getOpenFile( - -defaultextension => "", - # -filetypes => - # [ ['All Files', '*', ], - # ['Perl Scripts', '.pl' ], - # ['Text Files', ['.txt', '.text']], - # ['C Source Files', '.c', 'TEXT'], - # ['GIF Files', '.gif', ], - # ['GIF Files', '', 'GIFF'], - # ], - -initialdir => $default, - # -initialfile => "$default", - -title => "$question", - ); - chomp($path); - $UI[$i]{'value'}{$file} = $path; - $direntry-> delete(0, 'end'); - $direntry-> insert(0, "$path"); - } - )-> pack(-side => 'left',-padx=>3); - $direntry = $rightframe -> Entry( - -background=> $fileentrycolor, - -width=> $textentrywidth - )-> pack(-side => 'right'); - $direntry -> insert(0,"$default"); - $leftframe -> pack(-side => 'left', -anchor=> 'w', -padx => 2, -pady => 0); - $rightframe-> pack(-side => 'right',-anchor=> 'e', -padx => 3, -pady => 0); - $dirframe -> pack(-side => 'top', -padx => 2, -pady => 0, -fill=>'both'); - - # Set the initial directory -# if (! -e $path) { ("$path does not exist"); }# - - $direntry -> bind('', sub { - print "direntry: $checkbox " if ($debug); - $path = $direntry -> get(); - chomp($path); print "dirtree: var $var , value $path\n" if ($debug); - $UI[$i]{'value'}{$file} = $path; - } - ); - return 0; -} - -#.......................................................................... -sub Tk_File{ - my ($i,$question,$default, $file) = @_; - my $fileframe = $rightwidget -> Frame(-background=>$fileframecolor, -height=>30); - my ($direntry); - $width = 20 if (! defined $width); - my $leftframe = $fileframe -> Frame(-background=>$fileframecolor); - my $rightframe = $fileframe -> Frame(-background=>$fileframecolor); - $leftframe -> Label (-background => $filelabelcolor, -font=>$elementfont, - -text => $question - )-> pack(-side => 'left',-padx => 4, -pady => 0); - - $rightframe -> Button(-text => "Browse", - -command => sub { - $path = $rightframe -> getOpenFile( - -defaultextension => "", - -filetypes => - [ ['All Files', '*', ], - ['Perl Scripts', '.pl' ], - ['Text Files', ['.txt', '.text']], - ['C Source Files', '.c', 'TEXT'], - ['GIF Files', '.gif', ], - ['GIF Files', '', 'GIFF'], - ], - -initialdir => dirname($default), - -initialfile => "$default", - -title => "$question", - ); - - chomp($path); - $UI[$i]{'value'}{$file} = $path; - $direntry-> delete(0, 'end'); - $direntry-> insert(0, "$path"); - } - )-> pack(-side => 'left',-padx=>3); - $direntry = $rightframe -> Entry( - -background=> $fileentrycolor, - -width=> $textentrywidth - )-> pack(-side => 'right'); - $direntry -> insert(0,"$default"); - $leftframe -> pack(-side => 'left', -anchor=> 'w', -padx => 2, -pady => 0); - $rightframe-> pack(-side => 'right',-anchor=> 'e', -padx => 3, -pady => 0); - $fileframe -> pack(-side => 'top', -padx => 2, -pady => 0, -fill=>'both'); - - # Set the initial directory -# if (! -e $path) { ("$path does not exist"); }# - - $direntry -> bind('', sub { - print "direntry: $checkbox " if ($debug); - $path = $direntry -> get(); - chomp($path); - print "dirtree: var $var , value $path\n" if ($debug); - $UI[$i]{'value'}{$file} = $path; - } - ); - return 0; -} - -#.......................................................................... -sub Tk_Label { - my ($LABEL) = @_; - print "doLABEL : $LABEL \n" if ($debug); - my ($labelframe) = $rightwidget -> Frame(-height=>30, - ); - $labelframe -> Label ( - -background => $titlecolor, - -font=>"Helvetica 14 italic", - -text => $LABEL, - )-> pack(-side => 'top', -fill=>'both',-expand=>'both',-pady => 0, -fill=>'both',-expand=>1); - $labelframe -> pack(-side=>'top',-padx=>3, -pady=>0,-fill=>'both',-expand=>1); - return 0; -} - -sub Tk_TextEntry { - my ($i,$question,$default, $file) = @_; - my ($inputentry, $textentry, $temp,$pad); - if ($i> -1) { $pad = 0;} else { $pad=3;} - print "doTEXTENTRY i, question, default = ($i,$question,$default)\n" if ($debug); - - $textentry = $rightwidget -> Frame(-background=>$textframecolor); - $textentry -> Label( -background => $textqcolor, - -text => $question, -font=>$elementfont, - )-> pack(-side => 'left',-anchor=> 'w', -pady=>0,-padx=>1); - - $inputentry = $textentry -> Entry( -width=> $textentrywidth, - -background=> $textentrycolor, - ) -> pack(-side => 'right'); - $inputentry -> insert(0, "$default"); - $textentry -> pack(-side => 'top', -anchor=>'e', - -padx => 3, -pady => $pad,-fill=>'x'); - - $inputentry -> bind('', - sub { - $temp = $inputentry -> get(); - chomp($temp); - if ($i> -1) { - $UI[$i]{'value'}{$file} = $temp; - print "i = $i, \$temp= ",$temp, "\n" if ($debug); - } else { - $outfn{$file} = $temp; - } - } - ); - - return 0; -} - -#.......................................................................... -sub Tk_YesNo { - my ($i,$question,$default, $file) = @_; - my ($var,$radioframe,$radio,$rttl); - print "Tk_YesNo i, question,default = ($i,$question,$default)\n" if ($debug); - chomp($default); $var = $default; - - $radioframe = $rightwidget -> Frame( -background=>$radioframecolor, - -height=>20, - ); - $rttl = $radioframe -> Frame; - $rttl -> Label(-background => $radioqcolor, - -text=>$question, - -font=>$elementfont )-> pack(-side => 'left',-anchor=>'w'); - $rttl -> pack(-side => 'left', - -anchor=>'w', - -padx => 1, - -pady => 0, -# -expand=>1 - ); - $radio = $radioframe -> Frame; - $radio -> Radiobutton(-text => "Yes", -width=>3, - -background => $radiobuttoncolor, -value => "yes", - -variable => \$var, -relief=>'raised', - -command => sub { - $UI[$i]{'value'}{$file} = $var; - print "i = $i, name = ", $UI[$i]{'name'}{$file}, ", \$var = ",$var, "\n" if ($debug); - return; - }, - )-> pack(-side => 'right'); - $radio -> Radiobutton(-text => "No", -width=>3, - -background => $radiobuttoncolor, -value => "no", - -variable => \$var,-relief=>'raised', - -command => sub { - $UI[$i]{'value'}{$file}= $var; - print "i = $i,name = ", $UI[$i]{'name'}{$file}, ", \$var = ",$var, "\n" if ($debug); - return; - }, - )-> pack(-side => 'right'); - $radio -> pack(-side => 'right', -padx => 1, -pady => 0); - $radioframe -> pack(-side => 'top', - -padx => 3, - -pady => 0, - -fill=>'x', - #-expand=>'x' - ); - return 0; -} - - -#.......................................................................... -sub Tk_CheckBox { - - my ($i,$default, $file) = @_; - my ($var,$checkframe,$check,$rttl,$blank); - print "Tk_CheckBox i, args, default = ($i,$args,$default)\n" if ($debug); - chomp($default); - if ($default =~ /on/i) { $var = 1;} - else { $var = 0;} - Tk_markCB($i, $var, $file); - $UI[$i]{'name'}{$file} =~ s/\://gi; - $UI[$i]{'name'}{$file} =~ s/\?//; - - ($labeltext = $UI[$i]{'name'}{$file}) =~ s/\#//gi;; - - $checkframe = $rightwidget -> Frame(-background=>$checkframecolor, - -height=>30, ); - - $check = $checkframe -> Frame(-height=>30, -background=>$checkframecolor); - $check -> Checkbutton( -width=>1, - -background => $checkbuttoncolor, - -variable => \$var, -wraplength => 2, -relief=>'raised', - -command => sub { - Tk_markCB($i, $var, $file); return; - },)-> pack(); - $check -> pack(-side => 'left', -padx => 10, -pady => 0); - - - $rttl = $checkframe -> Frame(-height=>30,-background=>$checkframecolor,); - $rttl -> Label(-background => $checkbackground, - -text=>$labeltext, -font=> $elementfont ) - -> pack(); - $rttl -> pack(-side => 'left', -anchor=>'w', -padx => 1, -pady => 0 ); - - $checkframe -> pack( -side => 'top', - -anchor=>'w', - -padx => 3, - -pady => 0, -# -expand=>'x', - -fill=>'x' - ); -# $checkframe -> update; -} - -#.......................................................................... -sub Tk_markCB { - my ($i, $var, $file) = @_; - print "before i = $i, name = ", $UI[$i]{'name'}{$file}, ", \$var = ",$var, "\n" if ($debug); - $UI[$i]{'name'}{$file} =~ s/^\ //gi; - if ($var == 1) { - $UI[$i]{'name'}{$file} =~ s/\#//gi; - $UI[$i]{'args'}{$file} = "on"; - } else { - $UI[$i]{'name'}{$file} = "#" . $UI[$i]{'name'}{$file} if ($UI[$i]{'name'}{$file} !~ /\#/); - $UI[$i]{'args'}{$file} = "off"; - } - print "after i = $i, name = ", $UI[$i]{'name'}{$file}, ", \$var = ",$var, "\n" if ($debug); - - return ; -} - -#.......................................................................... -sub Tk_HelpAboutRed { - $newtoplevel -> destroy() if (Exists $newtoplevel); - - $newtoplevel = MainWindow -> new(-relief=>'ridge', - -borderwidth=> 5, - -background=>$filebrowseframe); - $newtoplevel -> Label ( -background => $filelabelcolor, - -text => "About RED", - -font=> "Arial 20 bold", - )-> pack(-fill=>'x', - -side => 'top', - -padx => 6, - -pady=>1 - ); - my (@ARR) = ("About RED", "Resource File Editor", - "Global Modeling Assimilation Office", "Created 3/30/2005 "," ", - - "[SAVE] - saves current configurations to *.rc file", - "[NEXT] - goes to next RC file if available", - "[BACK] - goes back to the previous file if available", - "[FINISH] - saves all info in memory to *.rc files", - "This tool holds all config info in memory hash-table", - "and saves to rc file at the end or when [save] is pressed", - ); - foreach my $a (@ARR) { - $newtoplevel -> Label(-text=> $a, -background=>$filebrowseframe - )->pack(-expand=>1, - -anchor=>'w', - -side=>'top'); - } - $newtoplevel -> Button(-text => "Close", - -command => sub { $newtoplevel -> destroy(); } - )-> pack (-side=>'top', -padx=>6, -pady=>1); - - $newtoplevel->title("RED Help - About RED"); -} - -#.......................................................................... -sub Tk_HelpAbout { - my ($file) = @_; - $newtoplevel -> destroy() if (Exists $newtoplevel); - $newtoplevel = MainWindow -> new(-relief=>'ridge', - -borderwidth=> 5, - -background=>$filebrowseframe); - $newtoplevel -> Label ( -background => $filelabelcolor, - -text => "About ". $RCtitle{$file}, - -font=> "Arial 20 bold", - )-> pack(-fill=>'x', - -side => 'top', - -padx => 6, - -pady=>1 - ); - for ( $i=0; $i < $nHelp{$file}; $i++ ) { - $newtoplevel -> Label( -text => $Help[$i]{$file}, - -background => $filebrowseframe - )->pack( -expand=>1, - -anchor=>'w', - -side=>'top' - ); - } - $newtoplevel -> Button( -text => "Close", - -command => sub { - $newtoplevel -> destroy(); - } - )-> pack (-side=>'top', -padx=>6, -pady=>1); - - $newtoplevel->title("RED Help - About " . $RCtitle{$file}); - -} - -#.......................................................................... -sub Tk_HelpRevision { - my ($file) = @_; - $newtoplevel -> destroy() if (Exists $newtoplevel); - - $newtoplevel = MainWindow -> new( -relief=>'ridge', - -borderwidth=> 5, - -background=>$filebrowseframe - ); - $newtoplevel -> Label ( -background => $filelabelcolor, - -text => "Revision History " . $RCtitle{$file}, - -font=> "Arial 20 bold", - )-> pack( -expand=>1, - -side => 'top', - -padx => 6, - -pady=>1 - ); - for ( $i=0; $i < $nHist{$file}; $i++ ) { -# foreach my $a (@Hist{$file}) { - $newtoplevel -> Label( -text=> $Hist[$i]{$file}, - -background=>$filebrowseframe - )->pack( - -anchor=>'w', - -side=>'top'); - } - $newtoplevel -> Button(-text => "Close", - -command => sub { $newtoplevel -> destroy(); } - )-> pack (-side=>'top', -padx=>6, -pady=>1); - $newtoplevel->title("RED Help - Revision History"); -} - -#.......................................................................... -sub Tk_FileMenu { - my ($file) = @_; - if (! $file) { $file = $RCfilename[0]}; - $filemenuwidget = $filemenuframe -> Frame(-height=>40); - $filemenu = $filemenuwidget -> Menubutton('-text' => 'File')-> pack(-side=> 'left'); - $filemenu -> command('-label' => 'Save As', - -command => sub { - $outfn = $filemenu -> getSaveFile( - -filetypes => - [ ['Resource Files','*.rc',], - ['All Files', '.*' ], - ], - ); - }); - $filemenu -> command('-label' => 'Reload', '-command' => sub {Tk_Reload($file);}); - $filemenu -> separator(); - $filemenu -> command(-label => 'Exit', -command=> sub { exit; } ); - - $editmenu = $filemenuwidget -> Menubutton(-text => 'Edit')-> pack(-side=> 'left'); - $editmenu -> command(-label => 'vi', - -command=> sub {system("vi $file"); Tk_Reload($file);}); - $editmenu -> command(-label => 'nedit', - -command=> sub {system("nedit $file"); Tk_Reload($file);}); - $editmenu -> command(-label => 'emacs', - -command=> sub {system("emacs $file"); Tk_Reload($file);}); - $editmenu -> command(-label => 'xemacs', - -command=> sub {system("xemacs $file"); Tk_Reload($file);}); - - $helpmenu = $filemenuwidget -> Menubutton(-text => 'Help')-> pack(-side=> 'left'); - $helpmenu -> command(-label => 'About RED', - -command=> sub { Tk_HelpAboutRed($file);} ); - - $helpmenu -> command(-label => "About $file", - -command=> sub { Tk_HelpAbout($file);} ); - - $helpmenu -> command(-label => 'Revision History', - -command=> sub { Tk_HelpRevision($file);} ); - - $filemenuwidget ->pack(); - -} - -#.......................................................................... -sub Tk_Reload { - my ($file) = @_; - print "Reload for $file" if ($debug); - $buttonwidget -> destroy() if ( Exists $buttonwidget ); - $filemenuwidget -> destroy() if ( Exists $filemenuwidget); - $rightwidget -> destroy() if ( Exists $rightwidget ); - $leftwidget -> destroy() if ( Exists $leftwidget ); - Parse_RCfile($file); - Tk_FileMenu($file); - Tk_RightWidget($file); - Tk_LeftWidget($file); - ___CreateWidget($file); - return 0; -} - -#.......................................................................... -sub Tk_LeftWidget { - my ($currentfile) = @_; - if (! $currentfile) { $currentfile = $RCfilename[0]}; - - $leftwidget = $leftframe -> Frame(-background => '#FFAAAA'); - - $nasalogo = $leftwidget -> Photo(-format=>"gif", -data => $logo); -# $nasalogo = $leftwidget -> Photo(-format=>"gif", -file=>"red_nasalogo.gif"); - $label = $leftwidget -> Label(-background => '#FFDDDD', - -text => 'NASA LOGO!', - -image => $nasalogo, - )->pack(-side => 'top',-fill=>'both'); - #} - my %label; - - foreach my $file (@RCfilename) { - - if ($currentfile eq $file) { $labelcolor = "#EEEE00"; } - else { $labelcolor = "#EEFFEE"; } - - $label{$file} = $leftwidget -> Label ( -text => $RCname{$file}, -background=> $labelcolor, - )->pack(-side=> 'top' , -anchor=>'w', -padx=> 5 , -pady=> 2); - - $label{$file} -> bind ('