#!C:\Perl\bin\perl.exe # gus_annotate_graphics.pl version 2004-02-29 # Annotate N graphic files from a GUI list. # See POD at EOF for full description. print "\n\n\n\n\n\n\n\n\n\n\n\n"; # For debugging with T-Pad. use Tk; use strict; #use warnings; require Tk::Pane; use Image::Magick; use vars qw( $mw $header $file_basename $annotation_text $fill_color $stroke_color $gravity $check_flag $image ); ###################### # Begin stuff the user ought to configure ###################### # What to write to this script's own log file. Also the Tk title. $header = 'Annotate Graphics'; # Defaults to fill the entry widgets when built. $file_basename = ''; $fill_color = 'red'; $stroke_color = 'red'; $gravity = 'NorthWest'; # List of supported file patterns my @filetypes = ( [ 'JPEG files', '.jpg', 'TEXT' ], [ 'PNG files', '.png', 'TEXT' ], [ 'BMP files', '.bmp', 'TEXT' ], [ 'GIF files', '.gif', 'TEXT' ] ); ###################### # End stuff the user ought to configure ###################### $annotation_text = 'VL200?????'; my $feedback = 'Hints: 1) Browse files. 2) Click a button.'; ###################### # Begin GUS Tk widget subs ###################### 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. } #============ End 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. my $path_widget_count = 0; # For unique widget names, use int and inc. 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 mk_N_path_widgets { my ( $count, $which_frame, $file_basename, ) = @_; for ( my $i = 1 ; $i <= $count ; $i++ ) { # Each file to be tracked has a path on the PC running MPT, # its mod date there, and an alias-name on the FTP server. add_path_widget( $which_frame, $file_basename ); } } #============ End subs for N file browse entry frames ============ ###################### # End GUS Tk widget subs ###################### ###################### # Begin GUI stuff ###################### $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 => $header ); # Begin MENU BAR $mw->configure( -menu => my $menubar = $mw->Menu ); # Begin MENU HELP my $menu_help = $menubar->cascade( -label => '~Help' ); $menu_help->command( -label => "About", -command => sub { menu_help_about::start_MainLoop() } ); # Begin MENU CONFIG my $menu_config = $menubar->cascade( -label => '~Config' ); $menu_config->command( -label => "Configure", -command => sub { configure_menu::start_MainLoop() } ); # Start out with a frame for selecting the number of specimens (MTS stations) # which are to be monitored. my $frame_setup_1 = $mw->Frame( -relief => 'sunken', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); mk_frame_label_scale( 'file_qty', $frame_setup_1, 'File qty:', 1, 12 ); mk_frame_label_button( 'setup', $mw, 'Action:', [ 'Continue', 'Quit' ], [ \&pack_frame_pane, \&quit_MainLoop, ], [ 'red', 'green' ] ); # Have a separate, main frame for after the setup frame. my $frame_files = $mw->Frame( -relief => 'sunken', -borderwidth => 5 ); my $frame_pane = $frame_files->Scrolled( 'Pane', -scrollbars => 'w', -sticky => 'new' )->pack( -side => 'top', -expand => 1, -fill => 'both' ); my $frame_electives = $mw->Frame( -relief => 'sunken', -borderwidth => 5 ); # After the setup frame, pack the main frame. sub pack_frame_pane { $mw->title(" $header"); # In case two instances are running. $frame_setup_1->packForget(); $frame_label_button{'frame_setup'}->packForget(); # Separate frame for each pair of files. mk_N_path_widgets( $frame_label_scale{'file_qty'}->get(), $frame_pane, $file_basename ); # Allow user to elimiate file path browsing widgets. $menu_config->command( -label => "Remove bottom row", -command => sub { delete_path_widget() unless $check_flag } ); # 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 ) unless $check_flag } ); repack_frame_pane(); # To avoid duplication. Is called two places. $frame_electives->pack( -side => 'top', -expand => 1, -fill => 'both' ); mk_frame_label_radio( 'fill_color', $frame_electives, 'Fill color:', [ 'red', 'yellow', 'orange', 'green', 'blue', 'white', 'black', ], sub { $fill_color = $frame_label_radio{'fill_color'} } ); $frame_label_radio{'fill_color'} = $fill_color; # Pre-set from default. mk_frame_label_radio( 'stroke_color', $frame_electives, 'Stroke color:', [ 'red', 'yellow', 'orange', 'green', 'blue', 'white', 'black', ], sub { $stroke_color = $frame_label_radio{'stroke_color'} } ); $frame_label_radio{'stroke_color'} = $stroke_color; # Pre-set from default. mk_frame_label_radio( 'gravity', $frame_electives, 'Gravity:', [ 'NorthWest', 'North', 'NorthEast', 'SouthEast', 'South', 'SouthWest', ], sub { $gravity = $frame_label_radio{'gravity'} } ); $frame_label_radio{'gravity'} = $gravity; # Pre-set from default. mk_frame_label_scale( 'font_size', $frame_electives, 'Font size:', 30, 100, 5 ); $frame_label_scale{'font_size'}->set(50); mk_frame_label_entry( 'annotation', $frame_electives, 'Text:', \$annotation_text ); # Buttons for control. mk_frame_label_button( 'action', $mw, 'Action:', [ 'Annotate', 'Quit' ], [ \&annotate_pics, \&quit_MainLoop, ], [ 'red', 'green' ] ); # Feedback to user on actions, etc. mk_frame_label_entry( 'fdbk', $mw, 'Feedback:', \$feedback ); } sub repack_frame_pane { # Expands so file rows can scroll more than two high. $frame_files->pack( -side => 'top', -expand => 1, -fill => 'both' ); } # Close down the Perl/Tk GUI sub quit_MainLoop { menu_help_about::quit_MainLoop(); configure_menu::quit_MainLoop(); $mw->destroy() if Tk::Exists($mw); } sub annotate_pics { my $file_pointer = 1; 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 ''; $image = new Image::Magick(); $image->Read($file_path); $image->Annotate( font => 'C:\WINNT\Fonts\arial.ttf', text => $annotation_text, pointsize => $frame_label_scale{'font_size'}->get(), stroke => $stroke_color, fill => $fill_color, y => int( $frame_label_scale{'font_size'}->get() * 1.2 ), gravity => $gravity, ); $file_path =~ s/\.jpg/_new\.jpg/; $image->Write($file_path); # &display::start_MainLoop($file_path); # Pure Perl/Tk method is only okay on Win32. $feedback = `$file_path`; # Let the OS decide how best to display. } $feedback = "Files annotated."; } MainLoop; ###################### # End GUI stuff ###################### # Pop up a dialog box for the user to select a file to open sub browse_file_dialog { my $filename = $mw->getOpenFile( -filetypes => \@filetypes ); if ( defined $filename and $filename ne '' ) { addPage($filename); } } # 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::header\n" . "Release 2004-02-22\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); # Adjust FTP-related widgets to active or not depending on current upload mode. sub set_ftp_entry_state {} sub start_MainLoop { print "\n\n\n"; # Debugging aid for use with T-Pad. $mw_configure_menu = MainWindow->new( -title => ' Configure' ); &main::mk_frame_label_button( 'action', $mw_configure_menu, 'Action:', [ 'Okay', 'Quit' ], [ \&accept_config, \&quit_MainLoop, ], [ 'red', 'green' ] ); MainLoop; } # Close down the Perl/Tk GUI sub accept_config { quit_MainLoop(); } sub quit_MainLoop { $mw_configure_menu->destroy() if Tk::Exists($mw_configure_menu); } END {} ##################### # End Configure Defaults Package ##################### ##################### # Begin Display Package ##################### # This is a separate package for convenience. package display; BEGIN {} use Tk; use strict; use warnings; # Following not used at this time. Ignore two lines below. # use Tk::widgets qw/JPEG/; # Note: For ActivePerl 5.8 do: ppm> install http://theoryx5.uwinnipeg.ca/ppms/Tk-JPEG.ppd # Declare variables for strict. use vars qw( $mw_display); sub start_MainLoop { my ($file_path) = @_; $mw_display = MainWindow->new( -title => ' Display' ); my $canvas = $mw_display->Scrolled('Canvas', -width => 600, -height => 600 ); my $image = $mw_display->Photo( -format => 'jpeg', -file => "$file_path" ); $canvas->createImage( 0, 0, -anchor => 'nw', -image => $image ); $canvas->pack(); &main::mk_frame_label_button( 'display_action', $mw_display, 'Action:', [ 'Noop', 'Quit' ], [ sub {}, \&quit_MainLoop, ], [ 'red', 'green' ] ); MainLoop; } sub quit_MainLoop { $mw_display->destroy() if Tk::Exists($mw_display); } END {} ##################### # End Configure Defaults Package ##################### __END__ =head1 NAME gus_annotate_graphics.pl =head1 SYNOPSIS perl gus_annotate_graphics.pl =head1 DESCRIPTION Perl/Tk GUI utility to simplify annotating graphics, particulary sample photos in fatigue and durability testing. =head1 README Run this script. A setup window appears. Guestimate how many graphic files you wish to annotate (you may change your mind later). Browse the file(s) to annotate. Select colors (stroke & fill) and the position of annotation (gravity). Enter the annotation itself (may include Perl newline chars). Click the button. Same annotation will be made to all files browsed. Any empty windows will be ignored. Annotated output is written to B> where B> is path of original. =head1 PREREQUISITES =over 8 =item ImageMagic ImageMagick is the core of this Perl/Tk utility. I'd recommend having the full ImageMagic installation. It is free, after all. But corporate IT rules may interfere with that. In such case one can make do with just the minimal ImageMagick C<*.dll> files. Copy them into the F directory. Which ones are minimal? Start by obtaining ImageMagick's C and C<*magick.dll> files. Then to know which (if any) yet remain, try this at a DOS prompt: F. Perl will complain of the first file which it needs but can't find. Fetch that file, then ask Perl the same thing again. When Perl stops complaining, you've got them all. It worked for me at any rate. =item Win32 OS I wrote this script and tested it under Win2K because that's where I needed it at the time. For another OS you'll have to tweak the font path, surely. I'll port it to NetBSD at some point. So do keep watch. =back =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 Others will follow... This is fun! I intend to write further Perl/Tk GUI scripts for various chores in and around fatigue and durability labs. If you have a related need, feel free to write. Maybe I'll find it interesting. =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 Misc =cut