#!Perl $^W = 1; use strict; use Net::FTP; use File::Copy; use Date::Parse; use Date::Format; use Tk::DialogBox; use Tk::ResizeButton; use Tk::ProgressBar; use Tk::LabFrame; use Tk::LabEntry; use Tk::ROText; use Tk::HList; use Cwd; use Tk; #Optional Modules# if ($^O eq 'MSWin32') { eval { require Win32::Console; Win32::Console::Free() }; if ($@) { warn "Win32::Console is not installed.\n$@"; } } #Declarations# my $VERSION = 2.7; my $loadhistory = 0; my $sort_cnt = 3; my ($ftp, $port, $after_id,); my $cwd = cwd; #Main# open STDERR, ">PFTPc.log" or warn "Cannot create PFTPc.log\a\n$!"; my $mw = MainWindow->new(-relief => 'raised', -bd => 2,); $mw->geometry("785x530+4+25"); &pftpc_gui(); &Tk::MainLoop(); #Subroutines# sub pftpc_gui #--------------------------------------------------------- { our $hlst1 = $mw->Scrolled('HList', -scrollbars => 'osoe', -bg => '#ffffff', -fg => '#000000', -selectbackground => '#000000', -selectforeground => '#fff000', -width => '110', -columns => '4', -header => '1', -takefocus => 1, -selectmode => 'extended',); my $h1 = $hlst1->ResizeButton(-text => 'Name', -relief => 'flat', -bd => 0, -command => sub {&sort1();}, -widget => \$hlst1, -column => 0, -anchor => 'w', -takefocus => 0,); my $h2 = $hlst1->ResizeButton(-text => 'Size (bytes)', -relief => 'flat', -bd => 0, -command => sub {&sort2();}, -widget => \$hlst1, -column => 1, -anchor => 'w', -takefocus => 0,); my $h3 = $hlst1->ResizeButton(-text => "Time/Date", -relief => 'flat', -bd => 0, -command => sub {&sort3();}, -widget => \$hlst1, -column => 2, -anchor => 'w', -takefocus => 0,); $hlst1->columnWidth(0, -char => '65'); $hlst1->columnWidth(1, -char => '20'); $hlst1->columnWidth(2, -char => '25'); $hlst1->columnWidth(3, -char => ''); $hlst1->header('create', 0, -borderwidth => 1, -itemtype => 'window', -widget => $h1,); $hlst1->header('create', 1, -borderwidth => 1, -itemtype => 'window', -widget => $h2,); $hlst1->header('create', 2, -borderwidth => 1, -itemtype => 'window', -widget => $h3,); $hlst1->header('create', 3, -borderwidth => 1,); my $f1 = $mw->Frame(-relief => 'sunken', -bd => 2,); my $lab1 = $mw->Label(-font => 'Verdana 16', -bd => '2.5', -relief => 'raised', -text => 'Perl FTP Client',); my $lab2 = $mw->Label(-text => 'Username: ',); my $lab3 = $mw->Label(-text => ' Password: ',); my $lab4 = $mw->Label(-text => 'Location: ',); our $lf1 = $mw->LabFrame(-bd => 2, -relief => 'groove', -label => "Connection Status", -labelside => 'acrosstop',); our $ent1_host = $mw->Entry(-width => 80, -textvariable => \our $host, -bg => '#ffffff', -fg => '#000000', -selectbackground => 'black', -selectforeground => 'yellow',); my $ent2_user = $mw->Entry(-textvariable => \our $user, -bg => '#ffffff', -fg => '#000000', -selectbackground => 'black', -selectforeground => 'yellow',); my $ent3_pass = $mw->Entry(-show => '*', -textvariable => \our $pass, -bg => '#ffffff', -fg => '#000000', -selectbackground => 'black', -selectforeground => 'yellow',); my $b1_logi = $mw->Button(-text => 'Login', -activeforeground => '#000fff', -command => \&b1_login_cmd); our $b2_logo = $mw->Button(-text => 'Logout', -activeforeground => '#000fff', -command => \&b2_logout_cmd); our $b3_get = $mw->Button(-text => 'Get', -activeforeground => '#000fff', -command => \&b3_get_cmd); our $b4_put = $mw->Button(-text => 'Put', -activeforeground => '#000fff', -command => \&b4_put_cmd); our $b5_mkdir = $mw->Button(-text => 'MkDir', -activeforeground => '#000fff', -command => \&b5_mkdir_cmd); our $b6_ren = $mw->Button(-text => 'Rename', -activeforeground => '#000fff', -command => \&b6_ren_cmd); our $b7_del = $mw->Button(-text => 'Delete', -activeforeground => '#000fff', -command => \&b7_del_cmd); my $b8_help = $mw->Button(-text => 'Help', -activeforeground => '#000fff', -command => \&b8_help_cmd); my $b9_exit = $mw->Button(-text => 'Exit', -activeforeground => '#000fff', -command => \&b9_exit_cmd); my $b10_bmark = $mw->Button(-text => 'Bookmarks', -activeforeground => '#fff000', -relief => 'flat', -command => \&b10_bmark_cmd); our $b11_hist = $mw->Button(-activeforeground => '#fff000', -command => \&b11_hist_cmd, -bitmap => '@' . Tk->findINC('cbxarrow.xbm'),); my $b12_log = $mw->Button(-text => 'View Log', -activeforeground => '#000fff', -command => \&b12_log_cmd); our $tl1 = $mw->Toplevel(-takefocus => 1, -relief => 'raised', -borderwidth => 2.5); $tl1->overrideredirect(1); $tl1->resizable(0, 0); $tl1->transient($mw); $tl1->withdraw; $tl1->geometry("300x60+225+260"); my $lab1_Pbar = $tl1->Label(-text => 'Working...',); my $f1_Pbar = $tl1->Frame(-bd => 2, -relief => 'sunken',); my $pb1_Pbar = $f1_Pbar->ProgressBar(-width => 25, -bd => 4, -length => 270, -relief => 'raised', -from => 0, -to => 100, -blocks => 50, -colors => [0, 'green'], -variable => \our $pb,); our $tl2 = $mw->Toplevel(-bg => '#000000'); $tl2->title('Bookmarks'); $tl2->geometry("+130+80"); $tl2->resizable(0, 0); $tl2->transient($mw); $tl2->withdraw; our $lb_bmark = $tl2->Scrolled('Listbox', -scrollbars => 'osoe', -bg => '#000000', -fg => '#ffffff', -selectforeground => '#000000', -selectbackground => '#fff000', -highlightbackground => 'grey64', -highlightcolor => 'grey64', -selectmode => 'single', -cursor => 'arrow', -width => 80,); our $e1_bmark = $tl2->Entry(-width => 60, -bg => '#ffffff', -fg => '#000000', -selectforeground => '#fff000', -selectbackground => '#000000', -textvariable => \our $add,); my $b1_bmark = $tl2->Button(-text => 'Add Bookmark', -bg => '#000000', -fg => '#ffffff', -activeforeground => '#fff000', -activebackground => '#000000', -relief => 'flat', -command => \&b1_bmark_cmd); my $b2_bmark = $tl2->Button(-text => 'Close', -relief => 'flat', -bg => '#000000', -fg => '#ffffff', -activeforeground => '#fff000', -activebackground => '#000000', -command => sub {$tl2->withdraw;}); our $tl3 = $mw->Toplevel(-relief => 'flat',); $tl3->overrideredirect(1); $tl3->resizable(0, 0); $tl3->transient($mw); $tl3->withdraw; our $f1_hist = $tl3->Frame(-relief => 'groove', -bd => 2, -takefocus => '1',); our $lb_hist = $tl3->Scrolled('Listbox', -scrollbars => 'ose', -selectmode => 'single', -width => 80, -height => 8, -bg => '#000000', -fg => '#ffffff', -selectforeground => '#000000', -selectbackground => '#fff000',); our $tl4 = $mw->Toplevel(-relief => 'raised', -bd => 2, -takefocus => '1',); $tl4->overrideredirect(1); $tl4->resizable(0, 0); $tl4->transient($mw); $tl4->withdraw; my $f1_men = $tl4->Frame(-relief => 'ridge', -bd => 2,); my $f2_men = $tl4->Frame(-relief => 'ridge', -bd => 2,); my $f3_men = $tl4->Frame(-relief => 'ridge', -bd => 2,); my $f4_men = $tl4->Frame(-relief => 'ridge', -bd => 2,); my $b1_men = $tl4->Button(-text => 'Get', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000", -command => \&b3_get_cmd); my $b2_men = $tl4->Button(-text => 'Get & Open', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000", -command => sub {&b3_get_cmd('O');}); my $b3_men = $tl4->Button(-text => 'Rename', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000", -command => \&b6_ren_cmd); my $b4_men = $tl4->Button(-text => 'Delete', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000", -command => \&b7_del_cmd); my $b5_men = $tl4->Button(-text => 'Put', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000", -command => \&b4_put_cmd); my $b6_men = $tl4->Button(-text => 'MakeDir', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000", -command => \&b5_mkdir_cmd); my $b7_men = $tl4->Button(-text => " Add to\nBookmarks", -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000", -command => \&add_to_bmark); #Bindings# $tl1->protocol(WM_DELETE_WINDOW => sub { $tl1->withdraw;} ); $tl2->protocol(WM_DELETE_WINDOW => sub { $tl2->withdraw;} ); $tl3->protocol(WM_DELETE_WINDOW => sub { $tl3->withdraw;} ); $tl4 ->bind('' => sub { $tl4->withdraw;} ); $f1_hist ->bind('' => sub { $lb_hist->selectionClear(0, "end"); $tl3 ->withdraw; }); $lab1->bind('' => sub { $lab1->configure(-text => ''); $mw->update; $mw->after(250); $lab1->configure(-anchor => 'w'); my $save; foreach my $l ('-', '=', 'P', 'F', 'T', 'P', 'C', '=', '-',) { my $c = 40; while ($c >=0) { unless ($save) { $save = ' '; } $lab1->configure(-text => ' 'x44 ."$save".' 'x$c."$l"); $mw->update; $c--; }$save .= $l; }$mw->after(1000); $lab1->configure(-anchor => 'center'); $lab1->configure(-text => ''); $mw->update; $mw->after(250); $lab1->configure(-text => 'Perl FTP Client'); }); $ent1_host->bind("" => \&b1_login_cmd); $ent3_pass->bind("" => \&b1_login_cmd); $hlst1 ->bind("" => \&b3_get_cmd); $lb_bmark ->bind('' => \&bmark_del_cmd); $lb_bmark ->bind('' => sub {$lb_bmark->focus;}); $lb_hist ->bind('' => \&hist_sel); $hlst1 ->bind('' => \&Tk::HList::Button1); $hlst1 ->bind('' => \&menu1); $lb_bmark ->bind('' => sub { my @sel = $lb_bmark->curselection; my $val = $lb_bmark->get("$sel[0]"); undef $host; $host = $val; $tl2->withdraw; }); &BindMouseWheel($hlst1); &BindMouseWheel($lb_bmark); &FlashButton($b10_bmark, 'green', '#000000'); &FlashButton($b1_bmark, 'cyan', '#ffffff'); &FlashButton($b2_bmark, 'red', '#ffffff'); #Grid $hlst1 ->grid(-in => $mw, -columnspan => '8', -column => '2', -rowspan => '8', -row => '6', -sticky => 'news'); $f1 ->grid(-in => $mw, -columnspan => '12', -column => '1', -rowspan => '1', -row => '1', -sticky => 'nsew'); $lab1 ->grid(-in => $f1, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'wsne'); $lab2 ->grid(-in => $mw, -columnspan => '1', -column => '2', -rowspan => '1', -row => '4', -sticky => 'nsw'); $lab3 ->grid(-in => $mw, -columnspan => '1', -column => '4', -rowspan => '1', -row => '4', -sticky => 'nse'); $lab4 ->grid(-in => $mw, -columnspan => '1', -column => '2', -rowspan => '1', -row => '3', -sticky => 'nsw'); $ent1_host->grid(-in => $mw, -columnspan => '3', -column => '3', -rowspan => '1', -row => '3', -sticky => 'w'); $ent2_user->grid(-in => $mw, -columnspan => '1', -column => '3', -rowspan => '1', -row => '4', -sticky => 'w'); $ent3_pass->grid(-in => $mw, -columnspan => '1', -column => '5', -rowspan => '1', -row => '4', -sticky => 'w'); $b1_logi ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '3', -sticky => 'new'); $b2_logo ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '4', -sticky => 'new'); $b3_get ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '6', -sticky => 'new'); $b4_put ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '7', -sticky => 'new'); $b5_mkdir ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '8', -sticky => 'new'); $b6_ren ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '9', -sticky => 'new'); $b7_del ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '10', -sticky => 'new'); $b8_help ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '12', -sticky => 'new'); $b9_exit ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '13', -sticky => 'new'); $b10_bmark->grid(-in => $mw, -columnspan => '3', -column => '6', -rowspan => '1', -row => '4', -sticky => 'n'); $b11_hist ->grid(-in => $mw, -columnspan => '1', -column => '6', -rowspan => '1', -row => '3', -sticky => 'w'); $b12_log ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '11', -sticky => 'new'); $lf1 ->grid(-in => $mw, -columnspan => '12', -column => '1', -rowspan => '1', -row => '15', -sticky => 'nesw'); $lab1_Pbar->grid(-in => $tl1, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'sw'); $f1_Pbar ->grid(-in => $tl1, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => 'new'); $pb1_Pbar ->grid(-in => $f1_Pbar, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $lb_bmark ->grid(-in => $tl2, -columnspan => '2', -column => '2', -rowspan => '1', -row => '2', -sticky => 'news'); $e1_bmark ->grid(-in => $tl2, -columnspan => '1', -column => '2', -rowspan => '1', -row => '4', -sticky => 'ew'); $b1_bmark ->grid(-in => $tl2, -columnspan => '1', -column => '3', -rowspan => '1', -row => '4', -sticky => ''); $b2_bmark ->grid(-in => $tl2, -columnspan => '1', -column => '3', -rowspan => '1', -row => '6', -sticky => ''); $f1_hist ->grid(-in => $tl3, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $lb_hist ->grid(-in => $f1_hist, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $f1_men ->grid(-in => $tl4, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $f2_men ->grid(-in => $tl4, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $f3_men ->grid(-in => $tl4, -columnspan => '1', -column => '1', -rowspan => '1', -row => '3', -sticky => 'news'); $f4_men ->grid(-in => $tl4, -columnspan => '1', -column => '1', -rowspan => '1', -row => '4', -sticky => 'news'); $b1_men ->grid(-in => $f1_men, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $b2_men ->grid(-in => $f1_men, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $b3_men ->grid(-in => $f2_men, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $b4_men ->grid(-in => $f2_men, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $b5_men ->grid(-in => $f3_men, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $b6_men ->grid(-in => $f3_men, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $b7_men ->grid(-in => $f4_men, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $mw->gridRowconfigure(1, -minsize => 2,); $mw->gridRowconfigure(2, -minsize => 8,); $mw->gridRowconfigure(3, -minsize => 2,); $mw->gridRowconfigure(4, -minsize => 2,); $mw->gridRowconfigure(5, -minsize => 8,); for (6..12) { $mw->gridRowconfigure($_, -minsize => 2,); } $mw->gridRowconfigure(13, -minsize => 180, -weight => 1,); $mw->gridRowconfigure(14, -minsize => 2,); $mw->gridRowconfigure(15, -minsize => 2,); for (1..5) { $mw->gridColumnconfigure($_, -minsize => 8,); } $mw->gridColumnconfigure(6, -minsize => 8, -weight => 1,); for (7..12) { $mw->gridColumnconfigure($_, -minsize => 8,); } $f1->gridRowconfigure(1, -minsize => 8, -weight => 1,); $f1->gridColumnconfigure(1, -minsize => 8, -weight => 1,); $tl1->gridRowconfigure(1, -minsize => 8,); $tl1->gridRowconfigure(2, -minsize => 40,); $tl1->gridColumnconfigure(1, -minsize => 8,); $f1_Pbar->gridRowconfigure(1, -minsize => 8,); $f1_Pbar->gridColumnconfigure(1, -minsize => 8,); $tl2->gridRowconfigure(1, -minsize => 8,); $tl2->gridRowconfigure(2, -minsize => 250,); for (3..6) { $tl2->gridRowconfigure($_, -minsize => 8,); } $tl2->gridColumnconfigure(1, -minsize => 8,); $tl2->gridColumnconfigure(2, -minsize => 40,); $tl2->gridColumnconfigure(3, -minsize => 40,); $tl2->gridColumnconfigure(4, -minsize => 8,); $tl3->gridRowconfigure(1, -minsize => 8,); $tl3->gridColumnconfigure(1, -minsize => 8,); $f1_hist->gridRowconfigure(1, -minsize => 8,); $f1_hist->gridColumnconfigure(1, -minsize => 8,); for (1..4) { $tl4->gridRowconfigure($_, -minsize => 8,); } $tl4->gridColumnconfigure(1, -minsize => 8,); $f1_men->gridRowconfigure(1, -minsize => 8,); $f1_men->gridRowconfigure(2, -minsize => 8,); $f1_men->gridColumnconfigure(1, -minsize => 8,); $f2_men->gridRowconfigure(1, -minsize => 8,); $f2_men->gridRowconfigure(2, -minsize => 8,); $f2_men->gridColumnconfigure(1, -minsize => 8,); $f3_men->gridRowconfigure(1, -minsize => 8,); $f3_men->gridRowconfigure(2, -minsize => 8,); $f3_men->gridColumnconfigure(1, -minsize => 8,); $f4_men->gridRowconfigure(1, -minsize => 8,); $f4_men->gridColumnconfigure(1, -minsize => 8,); #Defaults $ent1_host->focus; $b2_logo ->configure(-state => 'disabled'); $b3_get ->configure(-state => 'disabled'); $b4_put ->configure(-state => 'disabled'); $b5_mkdir->configure(-state => 'disabled'); $b6_ren ->configure(-state => 'disabled'); $b7_del ->configure(-state => 'disabled'); our $lf1_txt = $lf1->Label(-text => 'Not Connected')->pack; print STDERR 'PFTPc has started. (' . localtime() . "}\n"; #Callbacks sub b1_login_cmd #-------------------------------------------------- { $mw->Busy(-recurse => 1); $hlst1->focus; $lf1_txt->destroy; $lf1_txt = $lf1->Label(-text => 'Not Connected')->pack; my $dir; $port = 21; unless ($host) { $host = 'localhost' } unless ($user) { $user = 'anonymous'; $pass = 'anonymous@invalid.com'; } $host =~ s#ftp://##; #remove 'ftp://' @_ = split(':', $host); #determine port if ($_[1]) { $port = pop @_; $host = join(':', @_); } @_ = split('/', $host); #determine dir $host = shift @_; $dir = join('/', @_); unless ($loadhistory == 1) { &loadhistory(); } &history(); if ($ftp = Net::FTP->new("$host", Port => "$port", Debug => 1)) { #connect $after_id = $mw->repeat(30000, sub{ $ftp->quot('NOOP'); }); if ($pass) { my $a = $ftp->login("$user", "$pass"); unless ($a) { &error(2); goto b1_end; } }else{ my $a = $ftp->login("$user"); } $ftp->cwd("$dir") || $ftp->cwd(); #cwd $b2_logo ->configure(-state => 'normal'); $b3_get ->configure(-state => 'normal'); $b4_put ->configure(-state => 'normal'); $b5_mkdir->configure(-state => 'normal'); $b6_ren ->configure(-state => 'normal'); $b7_del ->configure(-state => 'normal'); $mw->update; &ftp_session(); }else{ &error(1) } b1_end: $mw->Unbusy; } sub b2_logout_cmd #------------------------------------------------- { if ($ftp) { $after_id->cancel; $ftp->quit; $lf1_txt->destroy; $lf1_txt = $lf1->Label(-text => 'Not Connected')->pack; } $hlst1->delete('all'); undef $ftp; $b2_logo ->configure(-state => 'disabled'); $b3_get ->configure(-state => 'disabled'); $b4_put ->configure(-state => 'disabled'); $b5_mkdir->configure(-state => 'disabled'); $b6_ren ->configure(-state => 'disabled'); $b7_del ->configure(-state => 'disabled'); $mw->update; } sub b3_get_cmd #---------------------------------------------------- { my $open_var = $_[0] || 'X'; if ($ftp) { $mw->Busy(-recurse => 1,); $pb = 0; my @selected = $hlst1->selectionGet; foreach (@selected) { my $sel = $hlst1->itemCget($_, 0, -text); my $isdir = $hlst1->itemCget($_, 1, -text); if ($_ eq 'up1') { $ftp->cdup; goto b3_end; }elsif ($isdir eq '') { $ftp->cwd($sel) || &error(3); goto b3_end; }elsif ($isdir eq '') { my $fs = 0; linkstart: my $tst = $ftp->cwd($sel); if ($tst == 0) { $fs++; my @a = split('/', $sel); pop @a; $sel = join('/', @a); unless($fs > 10) { goto linkstart; } }else{ goto b3_end; } $ftp->cwd($sel) or &error(3); goto b3_end; } $tl1->deiconify(); $tl1->raise(); $tl1->focus; $tl1->Busy; $ftp->pasv; $ftp->binary; for (1..25) { $pb++; $tl1->update; } if ($ftp->get($sel, '~pftpc.tmp')) { #d/l $tl1->focus; while ($pb < 100) {$pb += 2; $tl1->update;} $tl1->Unbusy; my $sfile = &save_file("$sel"); if ($open_var eq 'O') { #open $sfile =~ m#(.+\/)(.+)#; if ($^O eq 'MSWin32') { chdir "$1"; system("start", "$2"); chdir "$cwd"; }else{ chdir "$1"; system("$2"); chdir "$cwd"; } } } } } b3_end: $tl1->withdraw; $mw->Unbusy; $mw->update; &ftp_session(); } sub b4_put_cmd #---------------------------------------------------- { $mw->Busy(-recurse => 1,); if ($ftp) { unless (my $current_dir = $ftp->pwd()) { &error('put1'); } my $o = $mw->getOpenFile(-title=>'Select File for Upload',); if (defined ($o)) { $ftp->put($o) || &error(4); } } $mw->Unbusy; $mw->update; &ftp_session(); } sub b5_mkdir_cmd #-------------------------------------------------- { if ($ftp) { my $db = $mw->DialogBox(-title => 'Create New Directory', -buttons => ['MkDir', 'Cancel'], -default_button => 'MkDir'); $db->add('LabEntry', -textvariable => \my $mdir, -width => 20, -background => "#ffffff", -foreground => "#000000", -label => 'New Dir:', -labelPack => [-side => 'left'])->pack; my $ans = $db->Show(); if ($ans eq "MkDir") { $ftp->mkdir($mdir, 1) or &error(5); } &ftp_session(); } } sub b6_ren_cmd #---------------------------------------------------- { my @selected = $hlst1->selectionGet; foreach(@selected) { my $sel = $hlst1->itemCget($_, 0, -text); if ($_ eq 'up1') { goto b6_end; } my $db = $mw->DialogBox(-title => 'Rename File or Directory', -buttons => ['Rename', 'Cancel'], -default_button => 'Rename'); $db->add('LabEntry', -textvariable => \my $from, -width => 20, -label => 'From:', -state => 'disabled', -labelPack => [-side => 'left'])->pack; $db->add('LabEntry', -textvariable => \my $to, -width => 20, -background => "#ffffff", -foreground => "#000000", -label => ' To:', -labelPack => [-side => 'left'])->pack; $from = $sel; my $ans = $db->Show(); if ($ans eq "Rename") { $ftp->rename($sel, $to) or &error(6); } } b6_end: &ftp_session(); } sub b7_del_cmd #---------------------------------------------------- { my @selected = $hlst1->selectionGet; foreach(@selected) { if ($_ eq 'up1') { goto b7_end; } my $sel = $hlst1->itemCget($_, 0, -text); my $isdir = $hlst1->itemCget($_, 1, -text); my $db = $mw->DialogBox(-title => 'Confirm Delete', -buttons => ['Delete', 'Cancel'], -default_button => 'Cancel'); $db->add('Label', -text => "Delete $sel ?",)->pack; my $ans = $db->Show(); if ($ans eq "Delete") { $SIG{ALRM} = sub { &error(7); goto b7_end; }; eval { alarm(10); if ($isdir eq '') { $ftp->rmdir($sel, '1') or &error(7); }else{ $ftp->delete($sel) or &error(7); } }; } } b7_end: &ftp_session(); } sub b8_help_cmd #--------------------------------------------------- { $mw->Busy; my $email = 'QoS@cpan.org'; my $db = $mw->DialogBox(-title => 'PFTPc Help', -buttons => ['Close'], -default_button => 'Close'); my $t = $db->add('Scrolled', 'ROText', -background => 'black', -foreground => 'white', -selectforeground => 'white', -selectbackground => 'black', -scrollbars => 'oe', -width => 80, -height => 20,)->pack; $t->menu(undef); $t ->insert('end', <Show(); $mw->Unbusy; $mw->update; } sub b9_exit_cmd #--------------------------------------------------- { $mw->Busy; print STDERR 'PFTPc has closed. (' . localtime() . ")\n"; exit; } sub b10_bmark_cmd #------------------------------------------------- { my $opt = $_[0]; $mw->Busy; $tl2->deiconify; $tl2->raise; $e1_bmark->delete(0, 'end'); $lb_bmark->delete(0, 'end'); unless ($opt) { if (my $a = $ent1_host->get) { $e1_bmark->insert('end', $a); } } if (-e 'bookmark.txt') { open (FH, '< bookmark.txt'); my @b = (); close FH; foreach (@b) { chomp $_; $lb_bmark->insert('end', "$_"); } }else{ open (FH, '> bookmark.txt') or &error('bmark1'); if ('FH') { close FH; } } $mw->update; $mw->Unbusy; } sub b12_log_cmd #-------------------------------------------------- { my $db = $mw->DialogBox(-title => 'View Log', -buttons => ['Close', 'Save'], -default_button => 'Close'); my $t = $db->add('Scrolled', 'ROText', -scrollbars => 'oe', -bg => '#ffffff', -fg => '#000000', -selectforeground => '#000000', -selectbackground => '#ffffff', -insertbackground => '#ffffff', -width => 80, -height => 20,)->pack; $t->menu(undef); $t->tagConfigure('Blue', -foreground => '#000fff'); open (FH, '); close FH; foreach (@a) { s/^Net.*\)//; if (m/^<<<.*/) { $t->insert('end', $_, 'Blue'); } else { $t->insert('end', $_); } } my $ans = $db->Show(); $mw->update; if ($ans eq 'Save') { my $sf = $mw->getSaveFile(-title => 'Save Log', -initialfile => 'PFTPc_log',); if (defined ($sf)) { copy('PFTPc.log', $sf); } } } sub b1_bmark_cmd #-------------------------------------------------- { $mw->Busy; $e1_bmark->delete(0, 'end'); if (-e 'bookmark.txt' and $add) { $lb_bmark->insert('end', "$add"); open (FH, '>> bookmark.txt'); print FH "$add\n"; close FH; undef $add; $mw->update; } $mw->Unbusy; } sub bmark_del_cmd #------------------------------------------------- { my @sel = $lb_bmark->curselection; if (@sel) { my $val = $lb_bmark->get("$sel[0]"); open (FH, '< bookmark.txt'); my @b = (); close FH; open (FH, '> bookmark.txt'); $lb_bmark->delete(0, 'end'); foreach my $i (@b) { chomp $i; unless ($i eq "$val") { print FH "$i\n"; $lb_bmark->insert('end', $i); } }close FH; } } sub add_to_bmark #-------------------------------------------------- { if ($ftp) { $hlst1->focus; my $cwd = $ftp->pwd(); unless ($cwd) {$cwd = '/';} my $bmark = "$host" . "$cwd"; if (-e 'bookmark.txt' and $bmark) { $lb_bmark->insert('end', "$bmark"); open (FH, '>> bookmark.txt'); print FH "$bmark\n"; close FH; undef $bmark; &b10_bmark_cmd('add'); } } } sub ftp_session #--------------------------------------------------- { $hlst1->focus; $mw->update; unless ($ftp) { goto ftp_session_end; } my $cwd = $ftp->pwd(); unless ($cwd) { $cwd = 'PWD Not Supported' }; $lf1_txt->destroy; $lf1_txt = $lf1->Label(-text => "$user is ". "logged into $host:$port". "\t\tThe Current Working". " Directory is: $cwd",)->pack; my $counter = 0; my ($filename, $filesize, $timedate, $perms, %HoH,); my $dir_raw = $ftp->dir; unless ($dir_raw) { &b2_logout_cmd(); } $hlst1->delete('all'); $hlst1->add('up1'); $hlst1->itemCreate('up1', 0, -text => '...Up one level'); $hlst1->itemCreate('up1', 1, -text => ''); $hlst1->itemCreate('up1', 2, -text => ''); foreach my $line(@{$dir_raw}) { #drwxrwsr-x 10 ftpadmin 50 264 Jun 11 14:46 pub $line =~ m{([a-zA-Z-]*)\s* #perms ([0-9]*)\s* #inode ([0-9a-zA-Z]*)\s* #owner ([0-9a-zA-Z]*)\s* #group ([0-9]*)\s* #size ([A-Za-z]*)\s* #month ([0-9]*)\s* #day ([0-9A-Za-z:]*)\s* #YearOrTime ([\w*\W*\s*\S*]*) #name }x; my $perm = $1; my $inode = $2; my $owner = $3; my $group = $4; my $size = $5; my $month = $6; my $day = $7; my $YearOrTime = $8; my $name = $9; my ($lTarget, $lName,); if ($line =~ m#\s*->\s*([A-Za-z0-9.-/]*)#) { $lTarget = $1; $name =~ m#(.*)->.*#; $lName = $1; $name = $lTarget; } $HoH{$name}{perm} = $perm; $HoH{$name}{inode} = $inode; $HoH{$name}{owner} = $owner; $HoH{$name}{group} = $group; $HoH{$name}{size} = $size; $HoH{$name}{month} = $month; $HoH{$name}{day} = $day; $HoH{$name}{YearOrTime} = $YearOrTime; $HoH{$name}{lTarget} = $lTarget; } for my $k1 (sort keys %HoH) { $filename .= $k1; $perms = $HoH{$k1} {perm}; $filesize .= $HoH{$k1} {size} . ' '; $timedate .= $HoH{$k1} {month} . ' '; $timedate .= $HoH{$k1} {day} . ' '; $timedate .= $HoH{$k1} {YearOrTime}; if ($filename eq '.'or $filename eq '..'or $filename eq ''){ delete $HoH{$k1}; goto populate_end; } my $epoch = str2time($timedate); chomp($timedate = ctime($epoch)); undef $epoch; if ($perms =~ m/^d+?/i) { $filesize = ''; } if ($perms =~ m/^l+?/i) { $filesize = ''; } $hlst1->add($counter); $hlst1->itemCreate($counter, 0, -text => "$filename"); $hlst1->itemCreate($counter, 1, -text => "$filesize"); $hlst1->itemCreate($counter, 2, -text => "$timedate"); $counter++; populate_end: undef $filename; undef $perms; undef $filesize; undef $timedate; }ftp_session_end: } sub save_file #----------------------------------------------------- { my $ifile = $_[0]; my $sfile = $mw->getSaveFile(-title => 'Save File', -initialfile => $ifile,); if (defined ($sfile)) { copy('~pftpc.tmp', $sfile); unlink '~pftpc.tmp'; return "$sfile"; } } sub b11_hist_cmd #-------------------------------------------------- { $f1_hist->focus; $lb_hist->see('end'); my ($x, $y) = $mw->pointerxy; $x -= 505; $y += 5; $tl3->geometry('+'."$x".'+'."$y"); $tl3->deiconify(); $tl3->raise(); &loadhistory(); } sub hist_sel #------------------------------------------------------ { $mw->update; $mw->after(328); my @sels = $lb_hist->curselection(); unless (defined $sels[0]) { goto hist_sel_end; } my $sel = $lb_hist->get("$sels[0]"); if ($sel) { undef $host; $host = $sel; } hist_sel_end: $mw->focus; $mw->update; } sub loadhistory #--------------------------------------------------- { if ($loadhistory == 1) { goto loadhistory_end; } if (-e 'pftpc.hst') { open(HIST_IN, '< pftpc.hst') or &error('lhist1'); my @hist = ; close HIST_IN; CheckHistSize: my $histsize = $#hist; if ($histsize >= 9) { shift @hist; goto CheckHistSize; } open(HIST_OUT, '> pftpc.hst') or &error('lhist1'); foreach (@hist) { chomp $_; print HIST_OUT "$_\n"; $lb_hist->insert('end', $_); }close HIST_OUT; }else{ open(HIST_OUT, '> pftpc.hst'); close HIST_OUT; } $loadhistory = 1; loadhistory_end: } sub history #------------------------------------------------------- { $lb_hist->insert('end', $host); open (HIST_OUT, '>> pftpc.hst') or &error('hist1'); print HIST_OUT "$host\n"; close HIST_OUT; } sub menu1 #--------------------------------------------------------- { if ($ftp) { $tl4->focus; my ($x, $y) = $mw->pointerxy; $y -= 130; $tl4->geometry('+'."$x".'+'."$y"); $tl4->deiconify(); $tl4->raise(); } } sub sort1 #--------------------------------------------------------- { no warnings; my %HoA; $mw->Busy(-recurse => 1); $sort_cnt++; my @paths = $hlst1->infoChildren; foreach my $k (@paths) { my $col1 = $hlst1->itemCget($k, 0, -text); my $col2 = $hlst1->itemCget($k, 1, -text); my $col3 = $hlst1->itemCget($k, 2, -text); $HoA{$k} = ["$col1", "$col2", "$col3"]; } $hlst1->delete('all'); if ($sort_cnt % 2) { foreach my $k (sort {lc($HoA{$b}[0]) cmp lc($HoA{$a}[0])} keys %HoA) { #re-populate $hlst1->add($k); $hlst1->itemCreate($k, 0, -text => "$HoA{$k}[0]"); $hlst1->itemCreate($k, 1, -text => "$HoA{$k}[1]"); $hlst1->itemCreate($k, 2, -text => "$HoA{$k}[2]"); } }else{ foreach my $k (sort {lc($HoA{$a}[0]) cmp lc($HoA{$b}[0])} keys %HoA) { #re-populate $hlst1->add($k); $hlst1->itemCreate($k, 0, -text => "$HoA{$k}[0]"); $hlst1->itemCreate($k, 1, -text => "$HoA{$k}[1]"); $hlst1->itemCreate($k, 2, -text => "$HoA{$k}[2]"); } } $mw->Unbusy; $mw->update; } sub sort2 #--------------------------------------------------------- { no warnings; my %HoA; $mw->Busy(-recurse => 1); $sort_cnt++; my @paths = $hlst1->infoChildren; foreach my $k (@paths) { my $col1 = $hlst1->itemCget($k, 0, -text); my $col2 = $hlst1->itemCget($k, 1, -text); my $col3 = $hlst1->itemCget($k, 2, -text); unless ($col2) { $col2 = 1; } if ($col2 eq '') { $col2 = 1.1; } elsif ($col2 eq '') { $col2 = 1.2; } $HoA{$k} = ["$col1", "$col2", "$col3"]; } $hlst1->delete('all'); if ($sort_cnt % 2) { foreach my $k (sort {$HoA{$b}[1] <=> $HoA{$a}[1]} keys %HoA) { #re-populate if ($HoA{$k}[1] == 1) { $HoA{$k}[1] = ''; } elsif ($HoA{$k}[1] == 1.1) { $HoA{$k}[1] = ''; } elsif ($HoA{$k}[1] == 1.2) { $HoA{$k}[1] = ''; } $hlst1->add($k); $hlst1->itemCreate($k, 0, -text => "$HoA{$k}[0]"); $hlst1->itemCreate($k, 1, -text => "$HoA{$k}[1]"); $hlst1->itemCreate($k, 2, -text => "$HoA{$k}[2]"); } }else{ foreach my $k (sort {$HoA{$a}[1] <=> $HoA{$b}[1]} keys %HoA) { #re-populate if ($HoA{$k}[1] == 1) { $HoA{$k}[1] = ''; } elsif ($HoA{$k}[1] == 1.1) { $HoA{$k}[1] = ''; } elsif ($HoA{$k}[1] == 1.2) { $HoA{$k}[1] = ''; } $hlst1->add($k); $hlst1->itemCreate($k, 0, -text => "$HoA{$k}[0]"); $hlst1->itemCreate($k, 1, -text => "$HoA{$k}[1]"); $hlst1->itemCreate($k, 2, -text => "$HoA{$k}[2]"); } } $mw->Unbusy; $mw->update; } sub sort3 #--------------------------------------------------------- { no warnings; my %HoA; $mw->Busy(-recurse => 1); $sort_cnt++; my @paths = $hlst1->infoChildren; foreach my $k (@paths) { my $col1 = $hlst1->itemCget($k, 0, -text); my $col2 = $hlst1->itemCget($k, 1, -text); my $col3 = $hlst1->itemCget($k, 2, -text); $col3 = str2time($col3) if ($col3); $HoA{$k} = ["$col1", "$col2", "$col3"]; } $hlst1->delete('all'); if ($sort_cnt % 2) { foreach my $k (sort {$HoA{$b}[2] <=> $HoA{$a}[2]} keys %HoA) { #re-populate if ($HoA{$k}[2]) { chomp ($HoA{$k}[2] = ctime ($HoA{$k}[2])); } $hlst1->add($k); $hlst1->itemCreate($k, 0, -text => "$HoA{$k}[0]"); $hlst1->itemCreate($k, 1, -text => "$HoA{$k}[1]"); $hlst1->itemCreate($k, 2, -text => "$HoA{$k}[2]"); } }else{ foreach my $k (sort {$HoA{$a}[2] <=> $HoA{$b}[2]} keys %HoA) { #re-populate if ($HoA{$k}[2]) { chomp ($HoA{$k}[2] = ctime ($HoA{$k}[2])); } $hlst1->add($k); $hlst1->itemCreate($k, 0, -text => "$HoA{$k}[0]"); $hlst1->itemCreate($k, 1, -text => "$HoA{$k}[1]"); $hlst1->itemCreate($k, 2, -text => "$HoA{$k}[2]"); } } $mw->Unbusy; $mw->update; } 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 FlashButton #--------------------------------------------------- { my $w = $_[0]; my $c1 = $_[1]; my $c2 = $_[2]; unless($w and $c1 and $c2) {goto FlashButton_end;} $w->bind('' => sub { $w->configure(-relief => 'flat',); $w->configure(-fg => $c1); $w->flash; $w->flash; $w->configure(-fg => $c2); }); } sub error #--------------------------------------------------------- { my $err = $_[0]; my $ec; if ($err == 1) { $ec = "Cannot connect to $host: $@"; }elsif ($err == 2) { $ec = "Cannot login.\n" . $ftp->message; }elsif ($err == 3) { $ec = "Cannot change directory.\n" . $ftp->message; }elsif ($err == 4) { $ec = "Cannot upload file.\n$@" . "\n" . $ftp->message; }elsif ($err == 5) { $ec = "Cannot create new directory.\n" . $ftp->message; }elsif ($err == 6) { $ec = "Cannot rename file or directory.\n" . $ftp->message; }elsif ($err == 7) { $ec = "Cannot delete.\n" . $ftp->message; }elsif ($err eq 'put1') { $ec = "Cannot determine current working directory.\n$@"; }elsif ($err eq 'bmark1') { $ec = "Cannot create bookmark file.\n$!"; }elsif ($err eq 'lhist1') { $ec = "Cannot open history.\n$!"; }elsif ($err eq 'hist1') { $ec = "Cannot append history.\n$!"; }else{ $ec = "Unknown Error.\n"; } my $db = $mw->DialogBox(-title => 'Error', -buttons => ['Close'], -default_button => 'Close'); my $t = $db->add('ROText', -bg => '#000000', -fg => '#ffffff', -width => 80, -height => 20,)->pack; $t->insert('end', "$ec"); $db->Show(); $mw->update; } } #POD Section# =head1 NAME -=PFTPc=- Perl FTP Client =head1 DESCRIPTION Navigate and interact with FTP sites. =head1 README -=PFTPc=- Perl FTP Client - GUI based FTP site browser. =head1 PREREQUISITES Net-FTP Date-Parse Tk-ResizeButton Tk =head1 COREQUISITES Win32::Console (optional) =head1 History v1_0 - Initial release. v1_5 - Added symlink support. v2_0 - Added bookmarks, minor gui enhancements. v2_1 - Added sorting, more gui enhancements. v2_2 - Redesigned bookmark and history functions. Improved callback structure. Minor gui updates. Implemented Date::Parse to normalize the time/date column. Improved sorting functions. Added right-click menu to navigation screen. Added a keep-alive system. v2_3 - Various bug fixes, gui improvements. v2_4 - Changed default button states. Improved right-click menu. v2_5 - Removed some modules. Fixed a bug when clicking on an empty history window. Cleaned up code a bit. Minor GUI changes. v2_6 - Fixed a bug in get&open. Improved error subroutine. Altered placement of right-click menu. Implemented optional module for MSWin32 console removal. Implemented SIGalarm to trap bug when issuing a RMD on a non- empty directory. This is only needed for older versions of libnet. Altered keepalive to use NOOP instead of STAT. Added a logging function. v2_7 - POD update. Removed default right-click menu from help. =head1 ToDo Add drag and drop support. Add support for the ABOR command. Directory mirroring. =head1 Copyright -=PFTPC=- Perl FTP Client Copyright (C) 2004 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 OS Names: MSWin32, nix, nux, mac? =pod SCRIPT CATEGORIES Networking =cut