#! package PFTPC; use strict; use warnings; use Net::FTP; use File::Copy; use Date::Parse; use Date::Format; use Tk::DialogBox; use Tk::ResizeButton; use Tk::BrowseEntry; use Tk::ProgressBar; use Tk::LabEntry; use Tk::LabFrame; use Tk::ROText; use Tk::HList; use Cwd; use Tk; #Declarations# my $VERSION = 2.3; my $loadhistory = 0; my $sort_cnt = 3; my ($ftp, $ip, $port, $after_id,); my $cwd = cwd; 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', -bg => '#ffffff', -fg => '#000000', -selectbackground => '#000000', -selectforeground => '#fff000', -scrollbars => 'osoe', -width => '110', -columns => '4', -header => '1', -selectmode => 'extended', -takefocus => 1,); 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,); my $f1 = $mw->Frame(-relief => 'sunken', -bd => 2,); my $lab1 = $mw->Label(-font => 'Verdana 16', -relief => 'raised', -borderwidth => '2.5', -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(-borderwidth => 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 => '#fff000',); my $b2_logo = $mw->Button(-text => 'Logout', -activeforeground => '#fff000',); my $b3_get = $mw->Button(-text => 'Get', -activeforeground => '#fff000',); my $b4_put = $mw->Button(-text => 'Put', -activeforeground => '#fff000',); my $b5_mkdir = $mw->Button(-text => 'MkDir', -activeforeground => '#fff000',); my $b6_ren = $mw->Button(-text => 'Rename', -activeforeground => '#fff000',); my $b7_del = $mw->Button(-text => 'Delete', -activeforeground => '#fff000',); my $b8_help = $mw->Button(-text => 'Help', -activeforeground => '#fff000',); my $b9_exit = $mw->Button(-text => 'Exit', -activeforeground => '#fff000',); my $b10_bmark = $mw->Button(-text => 'Bookmarks', -activeforeground => '#fff000', -relief => 'flat',); our $b11_hist = $mw->Button(-activeforeground => '#fff000', -bitmap => '@' . Tk->findINC('cbxarrow.xbm'),); 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(-borderwidth => 2, -relief => 'sunken',); my $pb1_Pbar = $f1_Pbar->ProgressBar(-width => 25, -length => 270, -relief => 'raised', -bd => 4, -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,); my $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',); my $b2_bmark = $tl2->Button(-text => 'Close', -relief => 'flat', -bg => '#000000', -fg => '#ffffff', -activeforeground => '#fff000', -activebackground => '#000000',); 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",); my $b2_men = $tl4->Button(-text => 'Get & Open', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000",); my $b3_men = $tl4->Button(-text => 'Rename', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000",); my $b4_men = $tl4->Button(-text => 'Delete', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000",); my $b5_men = $tl4->Button(-text => 'Put', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000",); my $b6_men = $tl4->Button(-text => 'MakeDir', -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000",); my $b7_men = $tl4->Button(-text => " Add to\nBookmarks", -width => 10, -relief => 'groove', -bd => 2, -activeforeground => "#fff000",); #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); $hlst1 ->bind("" => \&b3_get_cmd); $b10_bmark->bind('' => sub { $b10_bmark->configure(-relief => 'flat',); $b10_bmark->configure(-fg => 'green'); $b10_bmark->flash; $b10_bmark->flash; $b10_bmark->configure(-fg => '#000000'); }); $b1_bmark->bind('' => sub { $b1_bmark->configure(-relief => 'flat',); $b1_bmark->configure(-fg => 'cyan'); $b1_bmark->flash; $b1_bmark->flash; $b1_bmark->configure(-fg => '#ffffff'); }); $b2_bmark->bind('' => sub { $b2_bmark->configure(-relief => 'flat',); $b2_bmark->configure(-fg => 'red'); $b2_bmark->flash; $b2_bmark->flash; $b2_bmark->configure(-fg => '#ffffff'); }); $lb_bmark->bind('' => sub { my @sel = $lb_bmark->curselection; my $val = $lb_bmark->get("$sel[0]"); undef $host; $host = $val; $tl2->withdraw; }); $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); &BindMouseWheel($hlst1); &BindMouseWheel($lb_bmark); #Widget Configuration our $sys_bg = $ent2_user->cget(-background); our $sys_fg = $ent2_user->cget(-foreground); $hlst1 ->columnWidth(0, -char => '68'); $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,); $b1_logi ->configure(-command => \&b1_login_cmd); $b2_logo ->configure(-command => \&b2_logout_cmd); $b3_get ->configure(-command => \&b3_get_cmd); $b4_put ->configure(-command => \&b4_put_cmd); $b5_mkdir ->configure(-command => \&b5_mkdir_cmd); $b6_ren ->configure(-command => \&b6_ren_cmd); $b7_del ->configure(-command => \&b7_del_cmd); $b8_help ->configure(-command => \&b8_help_cmd); $b9_exit ->configure(-command => \&b9_exit_cmd); $b10_bmark->configure(-command => \&b10_bmark_cmd); $b11_hist ->configure(-command => \&b11_hist_cmd); $b1_bmark ->configure(-command => \&b1_bmark_cmd); $b2_bmark ->configure(-command => sub {$tl2->withdraw;}); $b1_men->configure(-command => \&b3_get_cmd); $b2_men->configure(-command => sub {&b3_get_cmd('O');}); $b3_men->configure(-command => \&b6_ren_cmd); $b4_men->configure(-command => \&b7_del_cmd); $b5_men->configure(-command => \&b4_put_cmd); $b6_men->configure(-command => \&b5_mkdir_cmd); $b7_men->configure(-command => \&add_to_bmark); #Widget Geometry $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 => '11', -sticky => 'new'); $b9_exit ->grid(-in => $mw, -columnspan => '1', -column => '11', -rowspan => '1', -row => '12', -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'); $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'); #Grid Configuration $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,); $mw->gridRowconfigure(6, -minsize => 2,); $mw->gridRowconfigure(7, -minsize => 2,); $mw->gridRowconfigure(8, -minsize => 2,); $mw->gridRowconfigure(9, -minsize => 2,); $mw->gridRowconfigure(10, -minsize => 2,); $mw->gridRowconfigure(11, -minsize => 2,); $mw->gridRowconfigure(12, -minsize => 2,); $mw->gridRowconfigure(13, -minsize => 180, -weight => 1,); $mw->gridRowconfigure(14, -minsize => 2,); $mw->gridRowconfigure(15, -minsize => 2,); $mw->gridColumnconfigure(1, -minsize => 8,); $mw->gridColumnconfigure(2, -minsize => 8,); $mw->gridColumnconfigure(3, -minsize => 8,); $mw->gridColumnconfigure(4, -minsize => 8,); $mw->gridColumnconfigure(5, -minsize => 8,); $mw->gridColumnconfigure(6, -minsize => 8, -weight => 1,); $mw->gridColumnconfigure(7, -minsize => 8,); $mw->gridColumnconfigure(8, -minsize => 8,); $mw->gridColumnconfigure(9, -minsize => 8,); $mw->gridColumnconfigure(10, -minsize => 8,); $mw->gridColumnconfigure(11, -minsize => 8,); $mw->gridColumnconfigure(12, -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,); $tl2->gridRowconfigure(3, -minsize => 8,); $tl2->gridRowconfigure(4, -minsize => 8,); $tl2->gridRowconfigure(5, -minsize => 8,); $tl2->gridRowconfigure(6, -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,); $tl4->gridRowconfigure(1, -minsize => 8,); $tl4->gridRowconfigure(2, -minsize => 8,); $tl4->gridRowconfigure(3, -minsize => 8,); $tl4->gridRowconfigure(4, -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; our $lf1_txt = $lf1->Label(-text => 'Not Connected')->pack; #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@domain.invalid'} $host =~ s#ftp://##; #remove 'ftp://' @_ = split(':', $host); #determine port if ($_[1]) {$port = pop @_; $host = join(':', @_);} @_ = split('/', $host); #determine dir $host = shift @_; $dir = join('/', @_); &loadhistory() unless ($loadhistory == 1); &history(); if ($ftp = Net::FTP->new("$host", Port => "$port",)) { #connect $after_id = $mw->repeat(90000, sub {my $stat = $ftp->quot('stat');}); 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 &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; } sub b3_get_cmd #---------------------------------------------------- { if ($ftp) { my $open_var = $_[0]; unless ($open_var) {$open_var = 'X';} $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;} if ($isdir eq '') {$ftp->cwd($sel) || &error(3); goto b3_end;} if ($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) || &error(3); goto b3_end; } $tl1->deiconify(); $tl1->raise(); $tl1->focus; $tl1->Busy; $pb++; $tl1->update; $pb++; $tl1->update; $pb++; $tl1->update; $pb++; $tl1->update; $ftp->pasv; $ftp->binary; $pb += 5; $tl1->update; $pb += 5; $tl1->update; $pb += 5; $tl1->update; $pb += 5; $tl1->update; if ($ftp->get($sel, '~pftpc.tmp')) { $tl1->focus; while ($pb < 100) {$pb += 2; $tl1->update;} $tl1->Unbusy; my $sfile = &save_file("$sel"); if ($open_var eq 'O') { #$sfile =~ m#(\b.+)\/(.+\..{3,4})#; $sfile =~ m#(\b.+)\/(.+)#; $sfile =~ m#(.+)\/(.+)# unless ($2); if ($^O eq 'MSWin32') { chdir "$1"; `"start $2"`; chdir "$cwd"; } else{ chdir "$1"; `"$2"`; chdir "$cwd"; } #nfi } } }b3_end: undef $open_var; $mw->Unbusy; $tl1->withdraw; $mw->update; &ftp_session(); } } sub b4_put_cmd #---------------------------------------------------- { if ($ftp) { if (my $current_dir = $ftp->pwd()){} else {&error('put1');} my $ofile = $mw->getOpenFile(-title=>'Select File for Upload',); if (defined ($ofile)) { $mw->Busy(-recurse => 1,); $mw->update; $ftp->put($ofile) or &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 => "$sys_bg", -foreground => "$sys_fg", -label => 'New Dir:', -labelPack => [-side => 'left'])->pack; my $answer = $db->Show(); if ($answer 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 => "$sys_bg", -foreground => "$sys_fg", -label => ' To:', -labelPack => [-side => 'left'])->pack; $from = $sel; my $answer = $db->Show(); if ($answer eq "Rename") {$ftp->rename($sel, $to) or &error(6);} }b6_end: &ftp_session(); } sub b7_del_cmd #---------------------------------------------------- { my @selected = $hlst1->selectionGet; foreach(@selected) { my $sel = $hlst1->itemCget($_, 0, -text); my $isdir = $hlst1->itemCget($_, 1, -text); if ($_ eq 'up1') {goto b7_end;} my $db = $mw->DialogBox(-title => 'Confirm Delete', -buttons => ['Delete', 'Cancel'], -default_button => 'Cancel'); $db->add('Label', -text => "Delete $sel ?",)->pack; my $answer = $db->Show(); if ($answer eq "Delete") { 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 #--------------------------------------------------- { my $email = 'QoS@cpan.org'; my $clptk = '$_@_.%_'; my $db = $mw->DialogBox(-title => 'PFTPC Help', -buttons => ['Close'], -default_button => 'Close'); my $t = $db->add('Scrolled', 'ROText', -background => 'black', -foreground => 'white', -scrollbars => 'oe', -width => 80, -height => 20,)->pack; $t ->insert('end', <Show();} sub b9_exit_cmd #--------------------------------------------------- {exit;} sub b10_bmark_cmd #------------------------------------------------- { $tl2->deiconify; $tl2->raise; $lb_bmark->delete(0, 'end'); 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;} } } sub b1_bmark_cmd #-------------------------------------------------- { if (-e 'bookmark.txt' and $add) { $lb_bmark->insert('end', "$add"); open (FH, '>> bookmark.txt'); print FH "$add\n"; close FH; undef $add; } } 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; #print "i is: $i\n"; debugging 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(); } } } sub ftp_session #--------------------------------------------------- { 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}) { $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 $keys1 (sort keys %HoH) { $filename .= $keys1; $perms = $HoH{$keys1} {perm}; $filesize .= $HoH{$keys1} {size} . ' '; $timedate .= $HoH{$keys1} {month} . ' '; $timedate .= $HoH{$keys1} {day} . ' '; $timedate .= $HoH{$keys1} {YearOrTime}; if ($filename eq '.'or $filename eq '..'or $filename eq '') {delete $HoH{$keys1}; 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(); my $sel = $lb_hist->get("$sels[0]"); if ($sel) {undef $host; $host = $sel;} $mw->focus; $mw->update; } sub loadhistory #--------------------------------------------------- { goto loadhistory_end if ($loadhistory == 1); 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; $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 error #--------------------------------------------------------- { my $err = shift @_; print "\a"; if ($err == 1) { my $ec = "Cannot connect to $host: $@"; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); }if ($err == 2) { my $ec = 'Cannot login ' . $ftp->message; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); }if ($err == 3) { my $ec = 'Cannot change directory ' . $ftp->message; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; }if ($err == 4) { my $ec = "Cannot upload file $@ " . $ftp->message; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; }if ($err == 5) { my $ec = 'Cannot create new directory ' . $ftp->message; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; }if ($err == 6) { my $ec = 'Cannot rename file or directory ' . $ftp->message; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; }if ($err == 7) { my $ec = 'Cannot delete ' . $ftp->message; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; }if ($err eq 'put1') { my $ec = "Unable to determine the current working directory. $@"; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; }if ($err eq 'bmark1') { my $ec = "Cannot create bookmark file. $!"; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; }if ($err eq 'lhist1') { my $ec = "Cannot open history $!"; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; }if ($err eq 'hist1') { my $ec = "Cannot append history $!"; $hlst1->delete('all'); $hlst1->add('err'); $hlst1->itemCreate('err', 0, -text => "$ec"); $hlst1->itemCreate('err', 1, -text => ''); $hlst1->itemCreate('err', 2, -text => ''); $mw->update; sleep 3; } } } #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 n/a =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. =head1 ToDo Add drag and drop support? Add support for the abort () command. Directory mirroring. =head Wishlist Threads... =head1 Copyright -=PFTPC=- Perl FTP Client Copyright © 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 any? =pod SCRIPT CATEGORIES Networking Web =cut