# print "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"; # For debugging via T-Pad use Tk; require Tk::Pane; use strict; use vars qw ( $dir_path $input_path $output_path $DTG $regex_cols $regex_rows $feedback $prior_headings @column_headings @units_of_measure @dynamic_data_rows @lines $frame_pane @output_file_list $row_cnt $file_basename $mw ); # Start out with a hint about how to use regex for benighted Windoze users. $feedback = 'Perl regex: . = any-char; * = zero-or-more; + = one-or-more; ' . '^ = start of line; $ = end-of-line; \t = TAB; ' . '\d = digit; \D = non-digit; ' . '\u = upper-case next; \l = lower-case next; ' . '\w = word char (alphanum & _); \W = non-word char '; $row_cnt = 0; # Init the row count. $file_basename = 'specimen.dat'; $regex_rows = '^Condition\tTime\tChannel'; $feedback = 'Hints: 1) Browse files. 2) Set colors, etc. 3) Click a button.'; ##################### # Begin OS Detect Subs ##################### # Declare variables for strict. use vars qw( $OS $home $delim $browser $font $txt_viewer $ttf_dir ); $OS = ''; unless ($OS) { unless ( $OS = $^O ) { require Config; $OS = $Config::Config{'osname'}; } } if ( $OS =~ /Win/i ) { $OS = 'WINDOWS'; $home = "C:/"; $delim = '\\'; $browser = 'C:/Program Files/Internet Explorer/IEXPLORE.EXE'; $txt_viewer = 'C:/Program Files/Windows NT/Accessories/wordpad.exe'; $ttf_dir = 'C:\\WINNT\\Fonts\\'; $font = $ttf_dir . 'arial.ttf'; } elsif ( $OS =~ /^netbsd$/i ) { $OS = 'NetBSD'; $home = '~/'; $delim = '/'; $browser = '/usr/pkg/bin/mozilla'; $txt_viewer = '/usr/pkg/bin/nedit'; $ttf_dir = ''; $font = $ttf_dir . 'Generic.ttf'; } elsif ( $OS =~ /^MacOS$/i ) { $OS = 'MACINTOSH'; $home = '~/'; $delim = '/'; $browser = ''; $txt_viewer = ''; $ttf_dir = ''; $font = $ttf_dir . 'Generic.ttf'; } elsif ( $OS =~ /os2/i ) { $OS = 'OS2'; $home = ''; $delim = '/'; $browser = ''; $txt_viewer = ''; $ttf_dir = ''; $font = $ttf_dir . 'Generic.ttf'; } else { $OS = 'UNIX'; $home = '~/'; $delim = '/'; $browser = '/usr/local/bin/mozilla/'; $txt_viewer = ''; $ttf_dir = ''; $font = $ttf_dir . 'Generic.ttf'; } sub os_path { my ( $path, ) = @_; $path =~ s/\//\\/g if $OS eq 'WINDOWS'; return ($path); } ##################### # End OS Detect Subs ##################### ###################### # Begin GUS Tk widget subs # Version 2004-02-25 ###################### use vars qw( %frame_label_entry %frame_label_button %frame_label_scale %frame_label_check %frame_label_radio $button_width $label_width $entry_width $path_widget_count ); # Automate the build of a lable & entry wiget set inside a frame. sub mk_frame_label_entry { my ( $foo, $parent_frame, $label_text, $text_var_ref ) = @_; $frame_label_entry{"frame_$foo"} = $parent_frame->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); $frame_label_entry{"label_$foo"} = $frame_label_entry{"frame_$foo"}->Label( -width => $main::label_width, -text => " $label_text " )->pack( -side => 'left' ); $frame_label_entry{"entry_$foo"} = $frame_label_entry{"frame_$foo"}->Scrolled( 'Entry', -textvariable => $text_var_ref, -width => $main::entry_width, -background => "white", -foreground => 'blue', -relief => 'sunken', -font => 'courier' )->pack( -side => 'left', -expand => 1, -fill => 'x' ); } # Automate the build of a lable & radiobutton wiget set inside a frame. sub mk_frame_label_radio { my ( $foo, $parent_frame, $label_text, $text_array_ref, $cmd_ref ) = @_; $frame_label_radio{"frame_$foo"} = $parent_frame->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); $frame_label_radio{"label_$foo"} = $frame_label_radio{"frame_$foo"}->Label( -width => $main::label_width, -text => " $label_text " )->pack( -side => 'left' ); # Make N radiobuttons. foreach my $text(@$text_array_ref) { $frame_label_radio{"radio_$foo"} = $frame_label_radio{"frame_$foo"}->Radiobutton( -text => $text, -value => $text, -variable => \$frame_label_radio{"$foo"}, -command => $cmd_ref )->pack( -side => 'left', -expand => 1, -fill => 'x' ); } # End of foreach. } # Automate the build of a lable & radiobutton wiget set inside a frame. sub mk_frame_label_scale { my ( $foo, $parent_frame, $label_text, $from, $to, $resolution, $orientation ) = @_; $orientation = 'horizontal' unless defined($orientation); # Default option. $resolution = 1 unless defined($resolution); # Default option. $frame_label_scale{"frame_$foo"} = $parent_frame->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); $frame_label_scale{"label_$foo"} = $frame_label_scale{"frame_$foo"}->Label( -width => $main::label_width, -text => " $label_text " )->pack( -side => 'left' ); $frame_label_scale{"$foo"} = $frame_label_scale{"frame_$foo"}->Scale( -from => $from, -to => $to, -resolution => $resolution, -orient => $orientation )->pack( -side => 'left', -expand => 1, -fill => 'x' ); } # Automate the build of a lable & button wiget set inside a frame. sub mk_frame_label_button { my ( $foo, $parent_frame, $label_text, $text_array_ref, $cmd_ref_array_ref, $color_array_ref ) = @_; $frame_label_button{"frame_$foo"} = $parent_frame->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); $frame_label_button{"label_$foo"} = $frame_label_button{"frame_$foo"}->Label( -width => $main::label_width, -text => " $label_text " )->pack( -side => 'left' ); # Make N buttons. foreach my $text(@$text_array_ref) { $frame_label_button{"button_$text"} = $frame_label_button{"frame_$foo"}->Button( -width => $button_width, -text => $text, -command => shift ( @{$cmd_ref_array_ref} ), -background => 'gray', -activebackground => shift ( @{$color_array_ref} ), -relief => 'raised', )->pack( -side => 'left', -expand => 1, -fill => 'x' ); } # End of foreach. } #============ Begin subs for N checkbutton frames ============ # Automate the build of a lable & button wiget set inside a frame. sub mk_frame_label_check { # The var_ref's in var_ref_array_ref are on-off values. my ( $width, $foo, $parent_frame, $label_text, $text_array_ref, $on_array_ref, $off_array_ref, $bool_array_ref, $cmd_ref_array_ref ) = @_; $frame_label_check{"frame_$foo"} = $parent_frame->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); $frame_label_check{"label_$foo"} = $frame_label_check{"frame_$foo"}->Label( -width => $main::label_width, -text => " $label_text " )->pack( -side => 'left' ); # Make N checkbuttons. foreach my $text(@$text_array_ref) { my $var_key = $foo . '_' . $text . '_var'; # Default to generic un-checked = 0. May be overriden further down. $frame_label_check{"$var_key"} = 0; # For debugging... # print "New var = \$frame_label_check{'$var_key'} = ", # $frame_label_check{"$var_key"}, " \n"; $frame_label_check{"$foo" . '_' . "$text"} = $frame_label_check{"frame_$foo"}->Checkbutton( -text => $text, -justify => 'left', -anchor => 'w', -width => $width, -variable => \$frame_label_check{"$var_key"}, -background => 'gray', -relief => 'groove', )->pack( -side => 'left', -expand => 1, -fill => 'x', ); # Assign the default on-value, if present. $frame_label_check{"$foo" . '_' . "$text"}->configure( -onvalue => shift @$on_array_ref ) if defined $on_array_ref; # Assign the default off-value, if present. $frame_label_check{"$foo" . '_' . "$text"}->configure( -offvalue => shift @$off_array_ref ) if defined $off_array_ref; # Assign checked or not-checked condition, if present. if ( defined $bool_array_ref ) { if ( shift @$bool_array_ref ) { $frame_label_check{"$foo" . '_' . "$text"}->select(); #print "Selecting \$frame_label_check{"$foo" . '_' . "$text"} as default.\n"; } else { $frame_label_check{"$foo" . '_' . "$text"}->deselect(); #print "De-selecting \$frame_label_check{"$foo" . '_' . "$text"} as default.\n"; } } # Assign subroutine , if present. $frame_label_check{"$foo" . '_' . "$text"}->configure( -command => shift @$cmd_ref_array_ref ) if defined $cmd_ref_array_ref; } # End of foreach. } # Return values of checkbutton widget set. sub poll_frame_label_checks { # The key_head and key_middles are text, as in $frame_label_check{'head' . 'middle' . 'tail'} my ( $key_head, @key_middles_array ) = @_; my @bar = (); foreach my $key_middle(@key_middles_array) { push @bar, $frame_label_check{ $key_head . '_' . $key_middle . '_var' }; } return @bar; } #============ End subs for N checkbutton frames ============ #============ Begin subs for N file browse entry frames ============ # One var and three subs below require sub mk_frame_label_entry defined above. Use them to # make one-or-more file-browse widgets. Can add new ones underneath as required. Can also # delete them, one-at-a-time, except for the top one. $path_widget_count = 0; # For unique widget names, use int and inc. # List of supported file patterns my @filetypes = ( ['TAB delimited', '.dat', 'TEXT'], ['ASCII', '.txt', 'TEXT'], ['Any', '*.*', 'TEXT']); sub add_path_widget { my ( $which_frame, $file_basename, ) = @_; $path_widget_count++; my $this_widget_id = $path_widget_count; # Avoid later interpolation. $frame_label_entry{"file_$this_widget_id"} = $file_basename; $frame_label_entry{"file_status_$this_widget_id"} = 'foobar'; mk_frame_label_entry( "file_$this_widget_id", $which_frame, "File $this_widget_id:", \$frame_label_entry{"file_$this_widget_id"} ); # Button to browse for entry widget above. $frame_label_entry{"frame_file_$this_widget_id"}->Button( -width => 8, -text => 'Browse', -command => sub { $frame_label_entry{ 'file_' . $this_widget_id } = $mw->getOpenFile( -filetypes => \@filetypes ); }, -background => 'gray', -activebackground => 'red', -relief => 'raised', )->pack( -side => 'left', ); } sub delete_path_widget { if ( ( $path_widget_count > 1 ) && Tk::Exists( $frame_label_entry{"frame_file_$path_widget_count"} ) ) { $frame_label_entry{"frame_file_$path_widget_count"}->destroy(); foreach my $key( 'frame_', 'file_', 'file_status_',, ) { delete( $frame_label_entry{ $key . $path_widget_count } ); } $feedback = "Row $path_widget_count has been removed."; $path_widget_count--; } else { $feedback = "Oops! Can't remove only remaining row."; } } sub adjust_path_widgets { my ( $count, $which_frame, $file_basename, ) = @_; if ( $count > 0 ) { for ( my $i = 1 ; $i <= $count ; $i++ ) { add_path_widget( $which_frame, $file_basename ); } } if ( $count < 0 ) { for ( my $i = 1 ; $i >= $count ; $i-- ) { delete_path_widget( $which_frame, $file_basename ); } } } #============ End subs for N file browse entry frames ============ ###################### # End GUS Tk widget subs ###################### ###################### # Begin GUI stuff ###################### use vars qw( $mw_title ); $mw_title = 'MPT Dynamic Characterization'; $label_width = 12; $entry_width = 32; $button_width = 30; # Keeps pane from shrinking in X axis. # First declare the main GUI frame and all her daughters. $mw = MainWindow->new( -title => $mw_title ); my $frame_files = $mw->Frame( -relief => 'sunken', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'both' ); # Have a separate, main frame for after the setup frame. $frame_pane = $frame_files->Scrolled( 'Pane', -scrollbars => 'w', -sticky => 'new' )->pack( -side => 'top', -expand => 1, -fill => 'both' ); add_path_widget( $frame_pane, $file_basename ); my $frame_btm = $mw->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 0, -fill => 'x' ); # Annotate or not at will. mk_frame_label_button( 'action', $frame_btm, 'Action:', [ 'Extract', 'Show', 'Quit' ], [ \&process_all_files, \&show_file_list, \&quit_MainLoop, ], [ 'red', 'blue', 'green' ] ); # Feedback to user on actions, etc. mk_frame_label_entry( 'fdbk', $frame_btm, 'Feedback:', \$feedback ); # --------------- BEGIN MENU BAR --------------- $mw->configure( -menu => my $menubar = $mw->Menu ); # --- Config Menu --- my $menu_config = $menubar->cascade( -label => '~Config' ); # Allow user to add more file path browsing widgets. $menu_config->command( -label => "Add bottom row", -command => sub { add_path_widget( $frame_pane, $file_basename ) } ); # Allow user to elimiate file path browsing widgets. $menu_config->command( -label => "Remove bottom row", -command => sub { delete_path_widget() } ); # Allow more complex configs also. $menu_config->command( -label => "Configure in depth", -command => sub { configure_menu::start_MainLoop() } ); # --- Help Menu --- my $menu_help = $menubar->cascade( -label => '~Help' ); $menu_help->command( -label => "About", -command => sub { menu_help_about::start_MainLoop() } ); # --------------- END MENU BAR --------------- MainLoop; # Close down the Perl/Tk GUI sub quit_MainLoop { menu_help_about::quit_MainLoop(); configure_menu::quit_MainLoop(); $mw->destroy() if Tk::Exists($mw); } ###################### # End GUI stuff ###################### use vars qw( $prior_headings @column_headings @units_of_measure @dynamic_data_rows $row_count $col_width ); # Start out fresh. sub initialize { $prior_headings = ''; @column_headings = (); @units_of_measure = (); @dynamic_data_rows = (); $row_count = 0; $col_width = 12; adjust_regex_cols( 'Phase', 'K\*' ) if $regex_cols eq ''; } sub process_all_files { my $file_pointer = 1; my $files_processed = 0; @output_file_list = (); while ( defined( my $file_path = $frame_label_entry{"file_$file_pointer"} ) ) { $file_pointer++; # Increment before test empty string to avoid endless loop; next if $file_path eq ''; process_single_file($file_path); $files_processed++; } $feedback = "Files processed = $files_processed" if $files_processed > 1; } # Process the file. sub process_single_file { my ( $input_path, ) = @_; initialize(); # Open the file. if ( open( IN_FILE, "< $input_path" ) ) { $feedback = "Parsing file data."; # Read all lines of file into array. @lines = ; close(IN_FILE); # Get path from file name for writing. $output_path = $input_path; $output_path =~ s(\.[a-zA-Z0-9_\-]{1,3}$)(_); # Strip file suffix from path. $DTG = update_DTG(); # Get ISO Date Time Group. $DTG =~ s/:/-/g; # Change time '00:00:01' to '00-00-01'. $DTG =~ s/ /_/g; # Change space to u-score between date & time. $output_path .= "dynamic_" . $DTG . ".dat"; # Open new file in same directory for output. if ( open( OUT_FILE, "> $output_path" ) ) { push @output_file_list, $output_path; # Keep list for viewing in browser or editor. print( OUT_FILE "Columns of dynamic data extracted from file path below:" . "\n'$input_path'\n" ); get_dynamic_data(); print( OUT_FILE "\nEnd of extracted dynamic data. \n" ); close(OUT_FILE); $feedback = "Done: $row_count rows extracted to '$output_path'."; } else { $feedback = "Can't write to $output_path"; } } else { $feedback = "Can't read from $input_path" } } # Locate and parse the first header for later reference sub get_dynamic_data { while ( defined( my $line = shift (@lines) ) ) { # Match for separation by rows. next unless $line =~ m/$regex_rows/; @column_headings = split /\t/, $line; @units_of_measure = split /\t/, shift (@lines); shift (@lines); # Lose 1st blank line. # Collect rows until next blank line. while ( $lines[0] !~ /^\n$/ ) { push ( @dynamic_data_rows, shift (@lines) ); $row_count++; } } get_wanted_columns(); } # Adjust for which columns need to be parsed. # Takes an array of strings. sub adjust_regex_cols { $regex_cols = join '|', @_; $regex_cols =~ s{\|*\|}{\|}g; # Prevent double-OR. $regex_cols =~ s{^\|}{}; # No leading OR. $regex_cols =~ s{\|}{\$\|\^}g; # Make OR's greedier. $regex_cols = '^' . $regex_cols . '$'; # First and last OR's too. # For debugging only. # print "\nNew regex_cols = $regex_cols"; } # Get only desired columns from a row. sub get_wanted_columns { my $col_ptr = 0; my @want_list = (); foreach my $heading(@column_headings) { # Match for separation by rows. if ( $heading =~ m/$regex_cols/ ) { push ( @want_list, $col_ptr ); } $col_ptr++; } foreach my $row(@dynamic_data_rows) { # Print out one heading row per data set. my @head_cols = @column_headings[@want_list]; foreach my $head(@head_cols) { $head = sprintf "%$col_width" . "s", $head if $head =~ m/[a-z|A-Z]/; } my $heads = join "\t", @head_cols; print OUT_FILE "\n$heads\n" unless $heads eq $prior_headings; $prior_headings = $heads; # Group the data set. my @data_cols = ( split /\t/, $row )[@want_list]; # Make each datum pretty. foreach my $datum(@data_cols) { if ( $datum =~ m/-*[0-9]+\.[0-9]+/ ) { $datum = sprintf "%$col_width.2f", $datum ; } else { $datum = sprintf "%$col_width" . 's', $datum ; } } print OUT_FILE join "\t", @data_cols, "\n"; } } sub show_file_list { foreach my $file ( @output_file_list ) { $feedback = "Showing $file in browser."; show_in_viewer( $file ); } } # Display each annotated pic in a browser window for cross-platform # compatibility. I tried Tk::JPEG but it did not look very good. sub show_in_viewer { # Command below, modified from Randall's, does not hang Tk. Note that # you MUST have the command twice. 1st is name of DOS box. 2nd is # command called. 3rd is arg. The initial 'start' detaches the process # even though is called by 'system'. # print "start \"$_[0]\" \"$_[0]\"", "\"$_[1]\""; system( "start \"$txt_viewer\" \"$txt_viewer\"", "\"$_[0]\"" ) && warn "OOPS! "; } # Display each annotated pic in a browser window for cross-platform # compatibility. I tried Tk::JPEG but it did not look very good. sub show_in_browser { my @sys_args = ($browser); push ( @sys_args, os_path(@_) ); # Command below, modified from Randall's, does not hang Tk. Note that # you MUST have the command twice. 1st is name of DOS box. 2nd is # command called. 3rd is arg. The initial 'start' detaches the process # even though is called by 'system'. system( "start \"$sys_args[0]\" \"$sys_args[0]\"", "\"$sys_args[1]\"" ) && warn "OOPS! "; } # Return Date Time Group in ISO 8601 approved fashion. sub update_DTG { my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime(time); my $DTG = sprintf( "%04d-%02d-%02d_%02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec ); return ("$DTG"); } ##################### # Begin Menu Help About Package ##################### # This is a separate package for convenient use as a template. package menu_help_about; BEGIN {} use Tk; use strict; no strict "refs"; # Declare variables for strict. use vars qw( $mw_about ); sub start_MainLoop { $mw_about = MainWindow->new( -title => 'About' ); my $text = $mw_about->Label( -text => "$main::mw_title\n" . "Release 2004-02-24\n\n" . "Copyright 2004, Gan Uesli Starling\n\nTrailing Edge Technologies\n" . "http://starling.us/tet\n" . "email gan\@starling.us" . "\n" )->pack(); my $bn_okay = $mw_about->Button( -width => 8, -relief => 'raised', -foreground => 'blue', -activebackground => 'green', -command => \&quit_MainLoop, -text => 'Okay' )->pack( -side => 'top' ); MainLoop; } # Close down the Perl/Tk GUI sub quit_MainLoop { $mw_about->destroy() if Tk::Exists($mw_about); } END {} ##################### # End Menu Help About Package ##################### ##################### # Begin Configure Menu Package ##################### # This is a separate package for convenience. package configure_menu; BEGIN {} use Tk; use strict; use warnings; # Declare variables for strict. use vars qw( $mw_configure_menu @regex_cols_new ); sub start_MainLoop { $mw_configure_menu = MainWindow->new( -title => ' Configure' ); my $frame_sunken_top = $mw_configure_menu->Frame( -relief => 'sunken', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); &main::mk_frame_label_scale( 'file_qty', $frame_sunken_top, 'Adjust files:', -5, 5 ); &main::mk_frame_label_check( 16, 'columns_1', $frame_sunken_top, 'Columns:', [ 'Condition', 'Time', 'Channel', 'Spec. Freq.', 'Spec. Mean Level', ], [ 'Condition', 'Time', 'Channel', 'Specified Frequency', 'Specified Mean Level', ], [ '', '', '', '', '', ], [ 0, 0, 0, 0, 0, ], ); &main::mk_frame_label_check( 16, 'columns_2', $frame_sunken_top, ' ', [ 'Spec. Dyn. Amp.', 'Spec. Phase', 'Frequency', 'Load Mean Level', 'Load Dyn. Amp.', ], [ 'Specified Dynamic Amplitude (p-p)', 'Specified Phase', 'Frequency', 'Load Mean Level', 'Load Dynamic Amplitude (p-p)', ], [ '', '', '', '', '', ], [ 0, 0, 0, 0, 0, ], ); &main::mk_frame_label_check( 16, 'columns_3', $frame_sunken_top, ' ', [ 'Load Vector', 'Disp. Mean Level', 'Disp. Dyn. Amp.', 'Disp. Vector', 'Accel. Dyn. Amp.', ], [ 'Load Vector', 'Displacement Mean Level', 'Displacement Dynamic Amplitude (p-p)', 'Displacement Vector', 'Acceleration Dynamic Amplitude (p-p)', ], [ '', '', '', '', '', ], [ 0, 0, 0, 0, 0, ], ); &main::mk_frame_label_check( 16, 'columns_4', $frame_sunken_top, ' ', [ 'Time/Point', 'Total Points', 'Points/Cycle', 'Data Cycles', 'Condition Cycles', ], [ 'Time/Point', 'Total Points', 'Points/Cycle', 'Data Cycles', 'Condition Cycles', ], [ '', '', '', '', '', ], [ 0, 0, 0, 0, 0, ], ); &main::mk_frame_label_check( 0, 'columns_5', $frame_sunken_top, ' ', [ 'Test Cycles', 'Phase', 'K*', "K'", 'K"', 'C', 'Tr', 'Tan Delta', 'Energy', ], [ 'Test Cycles', 'Phase', 'K\*', 'K\'', 'K"', 'C', 'Tr', 'Tan Delta', 'Energy', ], [ '', '', '', '', '', '', '', '', '', ], [ 0, 1, 1, 0, 0, 0, 0, 0, ], ); &main::mk_frame_label_button( 'action', $mw_configure_menu, 'Action:', [ 'Accept', 'Cancel' ], [ \&accept_config, \&quit_MainLoop, ], [ 'red', 'green' ] ); MainLoop; } sub get_column_checklist { my @list = &main::poll_frame_label_checks( 'columns_1', 'Condition', 'Time', 'Channel', 'Spec. Freq.', 'Spec. Mean Level', ); push @list, &main::poll_frame_label_checks( 'columns_2', 'Spec. Dyn. Amp.', 'Spec. Phase', 'Frequency', 'Load Mean Level', 'Load Dyn. Amp.', ); push @list, &main::poll_frame_label_checks( 'columns_3', 'Load Vector', 'Displacement Mean Level', 'Displacement Dynamic Amplitude (p-p)', 'Displacement Vector', 'Acceleration Dynamic Amplitude (p-p)', ); push @list, &main::poll_frame_label_checks( 'columns_4', 'Time/Point', 'Total Points', 'Points/Cycle', 'Data Cycles', 'Condition Cycles', ); push @list, &main::poll_frame_label_checks( 'columns_5', 'Test Cycles', 'Phase', 'K*', "K'", 'K"', 'C', 'Tr', 'Tan Delta', 'Energy', ); return @list; } # Close down the Perl/Tk GUI sub accept_config { # Add or subtract from file path browse widgets. &main::adjust_path_widgets( $main::frame_label_scale{'file_qty'}->get(), $main::frame_pane, $main::file_basename ); # Re-define the columns to parse. Sub in main returns scalar inless in list context. &main::adjust_regex_cols( get_column_checklist() ); quit_MainLoop(); } sub quit_MainLoop { $mw_configure_menu->destroy() if Tk::Exists($mw_configure_menu); } END {} ##################### # End Configure Defaults Package ##################### __END__ =head1 NAME MTS MPT Elastomer Dynamic Characterization =head1 SYNOPSIS perl gus_mpt_dynamic.pl =head1 DESCRIPTION Reads in one or more MTS-default C files. From amongst any other formats therein, the script will seek out only dynamic characterization records. From these it will then extract only user-selected columns. =head1 README For simplicity's sake, put B of your MPT data in the default C file. Then use my Perl/Tk scripts to extract what you need from them. When tests are done, fire up this Perl/Tk GUI script. Browse to whichever input files you want to munge. More than one may be munged at a time. For an input file from path C output will be written to C'. Use pull-down menus to configure how many files to munge, which columns to extract, etc. =head1 PREREQUISITES This script requires the C a graphical user interface toolkit module for Perl. =head1 SEE ALSO =over 8 =item Stand-alone *.exe version If you absolutely, positively can't get Perl on your PC, then drop me a email. I'll run it through PAR on Win2K and reply with the B> attached. The script is free but burning stand-alone B>'s for Win32 is a service. My own time I value quite the same as you. Thus will I expect a half-hour's pay (at your own rate, whatever it be) to appear in my mailbox a week or so later. =item gus_mpt_static_def_char.pl For extracting and ex-post-facto re-calculating static stiffness data embeded in C files by the Static Deflection process in the Elastomer module of MultiPurpose TestWare by MTS. No matter that said file may also contain other data of unlike format there embeded by other MPT processes (such as Dynamic Characterization, etc.). =item gus_crpc_fmc_klt.pl A Perl/Tk GUI for extrating MTS cRPC iteration data according to Ford Motor Company's own Key Life Test formating requirements. =item Others will follow... This is fun! I intend to write further Perl/Tk GUI scripts for various sorts of data embeded by MPT within its default C ASCII file format. If you have a specific need which I've yet to addres, feel free to write. Include an example of the C file and how you'd like to see it munged. =back =head1 AUTHOR Gan Uesli Starling > =head1 COPYRIGHT Copyright (c) 2004, Gan Uesli Starling. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SCRIPT CATEGORIES MTS MultiPurpose TestWare