#!Perl use strict; use warnings; use MIME::Base64; use Tk::ROText; use Tk; #Declarations# my $VERSION = 1.2; my ($data,); #Main# my $mw = MainWindow->new(-relief => 'groove', -bg => '#6495ed', -bd => 2,); $mw->geometry("+30+50"); &photoenc_gui(); &Tk::MainLoop(); #Subroutines# sub photoenc_gui { #Widget Initialization my $e1 = $mw->Entry(-bg => '#ffffff', -fg => '#000000', -selectbackground => '#000000', -selectforeground => '#fff000', -textvariable => \our $file, -width => 80,); my $b1_bro = $mw->Button(-activeforeground => '#fff000', -activebackground => '#6495ed', -bg => '#6495ed', -fg => '#000000', -font => 'Script 18 italic', -relief => 'flat', -text => 'Browse ',); my $b2_enc = $mw->Button(-activeforeground => '#fff000', -activebackground => '#6495ed', -bg => '#6495ed', -fg => '#000000', -font => 'Script 18 italic', -relief => 'flat', -text => 'Encode',); my $b3_den = $mw->Button(-activeforeground => '#fff000', -activebackground => '#6495ed', -bg => '#6495ed', -fg => '#000000', -font => 'Script 18 italic', -relief => 'flat', -text => 'Decode',); my $b4_xit = $mw->Button(-activeforeground => '#fff000', -activebackground => '#6495ed', -bg => '#6495ed', -fg => '#000000', -font => 'Script 18 italic', -relief => 'flat', -text => 'Exit',); my $f1 = $mw->Frame(-relief => 'sunken', -bd => 2,); my $lab1 = $mw->Label(-text => 'Tk Photo Encoder', -font => 'Script 24 bold', -bg => '#6495ed', -fg => '#000000',); our $txt1 = $mw->Scrolled('ROText', -scrollbars => 'ose', -bg => '#ffffff', -fg => '#000000', -selectbackground => '#000000', -selectforeground => '#fff000', -wrap => 'none', -relief => 'flat', -width => 80,); our $tl1 = $mw->Toplevel(-relief => 'raised', -bd => 2.5,); $tl1->overrideredirect(1); $tl1->resizable(0, 0); $tl1->transient($mw); $tl1->withdraw; our $f1_menu1 = $tl1->Frame(-relief => 'sunken', -borderwidth => 1.5, -takefocus => 1,); my $b1_menu1 = $tl1->Button(-text => 'Copy to Clipboard', -activeforeground => '#fff000', -activebackground => '#6495ed', -bg => '#6495ed', -fg => '#000000', -relief => 'flat', -anchor => 'w',); my $b2_menu1 = $tl1->Button(-text => 'Save As', -activeforeground => '#fff000', -activebackground => '#6495ed', -bg => '#6495ed', -fg => '#000000', -relief => 'flat', -anchor => 'w',); our $tl2 = $mw->Toplevel(-relief => 'groove', -bg => '#6495ed', -bd => 2,); $tl2->title('Decode Photo'); $tl2->geometry('+88+75'); $tl2->resizable(0, 0); $tl2->transient($mw); $tl2->withdraw; our $txt_den = $tl2->Scrolled('Text', -scrollbars => 'osoe', -fg => '#000000', -bg => '#ffffff', -selectforeground => '#fff000', -selectbackground => '#000000', -wrap => 'none',); my $den_menu = $txt_den->menu; $den_menu->delete('File'); $den_menu->delete('Search'); $den_menu->delete('View'); undef $den_menu; my $l1_den = $tl2->Label(-text => 'Paste encoded data below.', -bg => '#6495ed', -fg => '#000000', -anchor => 'w',); my $b1_den_ok = $tl2->Button(-text => 'Ok', -activeforeground => '#fff000', -activebackground => '#6495ed', -bg => '#6495ed', -fg => '#000000', -width => 10,); my $b2_den_can = $tl2->Button(-text => 'Cancel', -activeforeground => '#fff000', -activebackground => '#6495ed', -bg => '#6495ed', -fg => '#000000', -width => 10,); #Bindings $lab1->bind('' => sub { my $c1 = 17; my $c2 = 17; my $c3 = 17; while ($c3 <= 254) { $c3 += 2; my $c1_hex = sprintf "%x", $c1; my $c2_hex = sprintf "%x", $c2; my $c3_hex = sprintf "%x", $c3; my $x = $c1_hex.$c2_hex.$c3_hex; my $a = '#'.$x; $lab1->configure(-fg => "$a"); $mw->update; $mw->after(25); }while ($c2 <= 254) { $c2 += 2; my $c1_hex = sprintf "%x", $c1; my $c2_hex = sprintf "%x", $c2; my $c3_hex = sprintf "%x", $c3; my $x = $c1_hex.$c2_hex.$c3_hex; my $a = '#'.$x; $lab1->configure(-fg => "$a"); $mw->update; $mw->after(25); }while ($c1 <= 254) { $c1 += 2; my $c1_hex = sprintf "%x", $c1; my $c2_hex = sprintf "%x", $c2; my $c3_hex = sprintf "%x", $c3; my $x = $c1_hex.$c2_hex.$c3_hex; my $a = '#'.$x; $lab1->configure(-fg => "$a"); $mw->update; $mw->after(25); } $c1 = 255; $c2 = 255; $c3 = 255; while ($c3 >= 18) { $c3 -= 2; my $c1_hex = sprintf "%x", $c1; my $c2_hex = sprintf "%x", $c2; my $c3_hex = sprintf "%x", $c3; my $x = $c1_hex.$c2_hex.$c3_hex; my $a = '#'.$x; $lab1->configure(-fg => "$a"); $mw->update; }while ($c2 >= 18) { $c2 -= 2; my $c1_hex = sprintf "%x", $c1; my $c2_hex = sprintf "%x", $c2; my $c3_hex = sprintf "%x", $c3; my $x = $c1_hex.$c2_hex.$c3_hex; my $a = '#'.$x; $lab1->configure(-fg => "$a"); $mw->update; }while ($c1 >= 18) { $c1 -= 2; my $c1_hex = sprintf "%x", $c1; my $c2_hex = sprintf "%x", $c2; my $c3_hex = sprintf "%x", $c3; my $x = $c1_hex.$c2_hex.$c3_hex; my $a = '#'.$x; $lab1->configure(-fg => "$a"); $mw->update; }$lab1->configure(-fg => '#000000'); }); $b1_bro->bind('' => sub { $b1_bro->configure(-relief => 'flat',); $b1_bro->configure(-fg => 'cyan'); $b1_bro->flash; $b1_bro->flash; $b1_bro->configure(-fg => '#000000'); }); $b2_enc->bind('' => sub { $b2_enc->configure(-relief => 'flat',); $b2_enc->configure(-fg => 'green'); $b2_enc->flash; $b2_enc->flash; $b2_enc->configure(-fg => '#000000'); }); $b3_den->bind('' => sub { $b3_den->configure(-relief => 'flat',); $b3_den->configure(-fg => 'green'); $b3_den->flash; $b3_den->flash; $b3_den->configure(-fg => '#000000'); }); $b4_xit->bind('' => sub { $b4_xit->configure(-relief => 'flat',); $b4_xit->configure(-fg => 'red'); $b4_xit->flash; $b4_xit->flash; $b4_xit->configure(-fg => '#000000'); }); $tl2->protocol(WM_DELETE_WINDOW => \&den_can); $f1_menu1->bind('' => sub {$tl1->withdraw;}); $txt1 ->bind('' => \&menu1); &BindMouseWheel($txt1); #Widget configuration $b1_bro ->configure(-command => \&b1_bro_cmd); $b2_enc ->configure(-command => \&b2_enc_cmd); $b3_den ->configure(-command => \&b3_den_cmd); $b4_xit ->configure(-command => sub {exit;}); $b1_menu1 ->configure(-command => \&menu_cmd_1); $b2_menu1 ->configure(-command => \&menu_cmd_2); $b1_den_ok ->configure(-command => \&den_ok); $b2_den_can ->configure(-command => \&den_can); #Widget Placement $b1_bro->grid(-in => $mw, -columnspan => '1', -column => '2', -rowspan => '1', -row => '2', -sticky => ''); $b2_enc->grid(-in => $mw, -columnspan => '1', -column => '4', -rowspan => '1', -row => '2', -sticky => ''); $b3_den->grid(-in => $mw, -columnspan => '1', -column => '4', -rowspan => '1', -row => '3', -sticky => 'n'); $b4_xit->grid(-in => $mw, -columnspan => '1', -column => '4', -rowspan => '1', -row => '4', -sticky => 's'); $e1 ->grid(-in => $mw, -columnspan => '1', -column => '3', -rowspan => '1', -row => '2', -sticky => 'we'); $lab1 ->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '1', -sticky => 'wsne'); $f1 ->grid(-in => $mw, -columnspan => '1', -column => '3', -rowspan => '2', -row => '3', -sticky => 'wsne'); $txt1 ->grid(-in => $f1, -columnspan => '1', -column => '1', -rowspan => '2', -row => '1', -sticky => 'wsne'); $f1_menu1 ->grid(-in => $tl1, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $b1_menu1 ->grid(-in => $f1_menu1, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'new'); $b2_menu1 ->grid(-in => $f1_menu1, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => 'new'); $txt_den ->grid(-in => $tl2, -columnspan => '2', -column => '2', -rowspan => '1', -row => '2', -sticky => 'news'); $l1_den ->grid(-in => $tl2, -columnspan => '2', -column => '2', -rowspan => '1', -row => '1', -sticky => 'snew'); $b1_den_ok ->grid(-in => $tl2, -columnspan => '1', -column => '2', -rowspan => '1', -row => '4', -sticky => 'w'); $b2_den_can ->grid(-in => $tl2, -columnspan => '1', -column => '3', -rowspan => '1', -row => '4', -sticky => 'e'); #Grid Configuration $mw->gridRowconfigure(1, -minsize => 8,); $mw->gridRowconfigure(2, -minsize => 8,); $mw->gridRowconfigure(3, -minsize => 8,); $mw->gridRowconfigure(4, -minsize => 318, -weight => 1,); $mw->gridRowconfigure(5, -minsize => 16,); $mw->gridColumnconfigure(1, -minsize => 8,); $mw->gridColumnconfigure(2, -minsize => 8,); $mw->gridColumnconfigure(3, -minsize => 8, -weight => 1,); $mw->gridColumnconfigure(4, -minsize => 8,); $mw->gridColumnconfigure(5, -minsize => 8,); $f1->gridRowconfigure(1, -minsize => 8, -weight => 1,); $f1->gridColumnconfigure(1, -minsize => 8, -weight => 1,); $tl1->gridRowconfigure(1, -minsize => 8,); $tl1->gridColumnconfigure(1, -minsize => 8,); $f1_menu1->gridRowconfigure(1, -minsize => 8,); $f1_menu1->gridRowconfigure(2, -minsize => 8,); $f1_menu1->gridColumnconfigure(1, -minsize => 8,); $tl2->gridRowconfigure(1, -minsize => 8,); $tl2->gridRowconfigure(2, -minsize => 40,); $tl2->gridRowconfigure(3, -minsize => 8,); $tl2->gridRowconfigure(4, -minsize => 8,); $tl2->gridRowconfigure(5, -minsize => 8,); $tl2->gridColumnconfigure(1, -minsize => 8,); $tl2->gridColumnconfigure(2, -minsize => 8,); $tl2->gridColumnconfigure(3, -minsize => 40,); $tl2->gridColumnconfigure(4, -minsize => 8,); #Defaults $e1->focus; $txt1->menu(undef); #Callbacks sub b1_bro_cmd #---------------------------------------------------- { my $ofile = $mw->getOpenFile(); if (defined $ofile) {$file = "$ofile";} } sub b2_enc_cmd #---------------------------------------------------- { undef $data; $mw->Busy(-recurse => 1); unless (defined $file) {&error('enc1'); goto b2_enc_end;} unless (-e $file) {&error('enc2'); goto b2_enc_end;} $txt1->delete("1.0", 'end'); my ($bin, $stat,); open (PHOTO, "< $file") or &error('enc3') and goto b2_enc_end; while ($stat = sysread(PHOTO, $bin, 57 * 17)) {$data .= encode_base64($bin);} close (PHOTO); unless (defined $stat) {&error('enc4'); goto b2_enc_end;} $txt1->insert('end', $data); $mw->Unbusy; $txt1->focus; b2_enc_end: } sub b3_den_cmd #---------------------------------------------------- { $tl2->deiconify; $tl2->raise; $tl2->focus; $mw->update; } sub den_ok #-------------------------------------------------------- { undef $data; my $text; $txt_den->focus; $txt_den->SetCursor('1.0'); $txt_den->selectAll; $text = $txt_den->getSelected; $data = decode_base64($text); undef $text; if ($data) { my $types = [ ['JPEG Files', '.jpg', ], ['TIFF Files', '.tif', ], ['BMP Files', '.bmp', ], ['GIF Files', '.gif', ], ['PNG Files', '.png', ], ]; my $sfile = $mw->getSaveFile(-filetypes => $types, -defaultextension => '.jpg',); if ($sfile) { open (FH, "> $sfile") or &error('den_1') and goto den_ok_end; binmode FH; print FH $data; close FH; $txt1->delete("1.0", 'end'); $txt1->insert('end', 'Operation completed. File decoded '. 'and saved as: $sfile'); } }else{ &error('den_2'); } den_ok_end: &den_can(); } sub den_can #------------------------------------------------------- { $txt_den->delete("1.0", 'end'); $tl2->withdraw; } sub BindMouseWheel #------------------------------------------------ { my($w) = @_; if ($^O eq 'MSWin32') { $w->bind(''=>[sub{ $_[0]->yview('scroll', -($_[1]/120)*3,'units')} ,Ev('D')]); $w->bind('' => sub {$w->focus}); }else{ $w->bind('<4>' => sub {$_[0]->yview('scroll', -3, 'units') unless $Tk::strictMotif;}); $w->bind('<5>' => sub {$_[0]->yview('scroll', +3, 'units') unless $Tk::strictMotif;}); } } sub menu1 #--------------------------------------------------------- { $f1_menu1->focus; my ($x, $y) = $mw->pointerxy; $y -= 40; $tl1->geometry('+'."$x".'+'."$y"); $tl1->deiconify(); $tl1->raise(); } sub menu_cmd_1 #---------------------------------------------------- { $txt1->focus; $txt1->SetCursor('1.0'); $txt1->selectAll; $mw->update; $mw->Busy(-recurse => 1); $mw->clipboardClear; $mw->clipboardAppend($data); $txt1->delete("1.0", 'end'); $txt1->insert('end', 'Operation completed. The data has been '. 'copied to the clipboard.') if ($data); $mw->Unbusy; undef $data; undef $file; } sub menu_cmd_2 #---------------------------------------------------- { my $ifile; $mw->Busy(-recurse => 1); my $types = [ ['Encoded Files', '.enc', ], ['Text Files', ['.txt', '.text']], ['All Files', '*', ], ]; if ($file) {$file =~ m/(.+)\/(.+)(\..{3,4})/; $ifile = $2;} my $sfile = $mw->getSaveFile(-title => 'Save As', -filetypes => $types, -defaultextension => '.enc', -initialfile => $ifile,); if (defined $sfile) { $txt1->focus; $txt1->SetCursor('1.0'); $txt1->selectAll; $mw->update; open(FH, "> $sfile") or &error('menu2_1'); print FH $data; close FH; $mw->clipboardClear; $mw->clipboardAppend($data); $txt1->delete("1.0", 'end'); $txt1->insert('end', "Operation completed.\n\n$file has ". "been encoded,\nand saved as $sfile.\n\n". 'The data has been copied to the clipboard.'); undef $data; undef $file; }$mw->Unbusy; } sub error #--------------------------------------------------------- { my $err = $_[0]; print "\a"; $txt1->delete("1.0", 'end'); if ($err eq 'enc1') { $txt1->insert('end', "Must choose a file to encode.\n"); }elsif ($err eq 'enc2') { $txt1->insert('end', "File: $file not found.\n"); }elsif ($err eq 'enc3') { $txt1->insert('end', "Can't open file: $file\n$!"); }elsif ($err eq 'enc4') { $txt1->insert('end', "sysread error.\n$!"); }elsif ($err eq 'menu2_1') { $txt1->insert('end', "Cannot open file.\n$!"); }elsif ($err eq 'den_1') { $txt1->insert('end', "Cannot create file.\n$!"); }elsif ($err eq 'den_2') { $txt1->insert('end', "Data Error.\n"); } $mw->Busy(-recurse => 1,); $mw->after(5000, sub {$txt1->delete("1.0", 'end'); $mw->Unbusy;}); } } #POD Section# =head1 NAME Tk PhotoEncoder =head1 DESCRIPTION Useful for storing photos within your pTk application. =head1 README Tk PhotoEncoder - GUI-based photo encoder, a development tool for pTk. =head1 PREREQUISITES MIME-Base64 =head1 COREQUISITES n/a =head1 History v1_0 - Initial release. v1_1 - Added Decode function. Improved error handling. v1_2 - Minor GUI adjustments. Neater code =head1 Copyright Tk PhotoEncoder Copyright (C) 2004 - 2005 Jason David McManus This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =pod OSNAMES MSWin32, any others? =pod SCRIPT CATEGORIES =cut