#!
package PFTPC_gui;
use strict;
use warnings;
use Net::FTP;
use File::Copy;
use Tk::DialogBox;
use Tk::ResizeButton;
use Tk::BrowseEntry;
use Tk::LabFrame;
use Tk::LabEntry;
use Tk::ROText;
use Tk::HList;
use Tk;

#Optional Modules#
my $Tk_AutoScroll_installed = 0;
eval {require Tk::Autoscroll; $Tk_AutoScroll_installed = 1;};

#Declarations#
my $VERSION = 1.0; my $loadhistory = 0;
my ($hlst1, $lf1, $lf1_txt, $ftp, $ip, $host, $user, $port, $ent1_host,);

my $mw = MainWindow->new(); $mw->title("-=PFTPC=-");
&pftpc_gui(); Tk::MainLoop();
1;

#Subroutines#
sub pftpc_gui #---------------------------------------------------------
{
    ($hlst1)       = $mw->Scrolled('HList',
                                   -scrollbars => 'oe',
                                   -height => '0',
                                   -width => '80',
                                   -columns => '4',
                                   -header => '1',
                                   -selectmode => 'extended',
                                   -takefocus => 1,);
    my($h1)        = $hlst1->ResizeButton(-text => 'Name',
                                          -relief => 'flat',
                                          -command => sub {},
                                          -widget => \$hlst1,
                                          -column => 0,
                                          -anchor => 'w',
                                          -takefocus => 0,);
    my($h2)        = $hlst1->ResizeButton(-text => 'Size',
                                          -relief => 'flat',
                                          -command => sub {},
                                          -widget => \$hlst1,
                                          -column => 1,
                                          -anchor => 'w',
                                          -takefocus => 0,);
    my($h3)        = $hlst1->ResizeButton(-text => "Time/Date",
                                          -relief => 'flat',
                                          -command => sub {},
                                          -widget => \$hlst1,
                                          -column => 2,
                                          -anchor => 'w',
                                          -takefocus => 0,);
    my($lab1)      = $mw->Label(-font => 'Verdana 16',
                                -relief => 'sunken',
                                -borderwidth => '4',
                                -text => 'Perl FTP Client',);
    my($lab2)      = $mw->Label(-text => 'Username: ',);
    my($lab3)      = $mw->Label(-text => 'Password: ',);
    ($lf1)         = $mw->LabFrame(-borderwidth => 2,
                                   -relief => 'flat',
                                   -label => "Connection Status",
                                   -labelside => 'acrosstop',);
    ($ent1_host)   = $mw->BrowseEntry(-width => '80',
                                      -variable => \$host,
                                      -label => 'Location:   ',);
    my($ent2_user) = $mw->Entry(-textvariable => \$user,);
    my($ent3_pass) = $mw->Entry(-show => '*',
                                -textvariable => \our $pass,);
    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',);

    #Widget Configuration
    if ($Tk_AutoScroll_installed == 1) {Tk::Autoscroll::Init($hlst1);}
    our $sys_bg = $ent2_user->cget(-background);
    our $sys_fg = $ent2_user->cget(-foreground);
    $ent1_host->bind("<Return>", \&b1_login_cmd);
    $hlst1    ->bind("<Double-Button-1>", \&b3_get_cmd);
    $hlst1    ->columnWidth(0, -char => '58');
    $hlst1    ->columnWidth(1, -char => '20');
    $hlst1    ->columnWidth(2, -char => '26');
    $hlst1    ->columnWidth(3, -char => '2');
    $hlst1    ->header('create', 0,
                       -itemtype => 'window',
                       -widget => $h1,);
    $hlst1    ->header('create', 1,
                       -itemtype => 'window',
                       -widget => $h2,);
    $hlst1    ->header('create', 2,
                       -itemtype => 'window',
                       -widget => $h3,);
    $hlst1    ->configure(-background => "$sys_bg",
                          -foreground => "$sys_fg");
    $ent1_host->configure(-listcmd => \&loadhistory());
    $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);
    &BindMouseWheel($hlst1);

    #Widget Geometry
    $hlst1    ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '2',          -ipady => '0',
                     -row    => '6',          -padx => '0',
                     -columnspan => '8',      -pady => '0',
                     -rowspan => '8',         -sticky => 'news');
    $lab1     ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '1',          -ipady => '0',
                     -row    => '1',          -padx => '0',
                     -columnspan => '12',     -pady => '0',
                     -rowspan => '1',         -sticky => 'nsew');
    $lab2     ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '2',          -ipady => '0',
                     -row    => '4',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'nsw');
    $lab3     ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '5',          -ipady => '0',
                     -row    => '4',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'nsw');
    $ent1_host->grid(-in     => $mw,          -ipadx => '0',
                     -column => '2',          -ipady => '0',
                     -row    => '3',          -padx => '0',
                     -columnspan => '5',      -pady => '0',
                     -rowspan => '1',         -sticky => 'w');
    $ent2_user->grid(-in     => $mw,          -ipadx => '0',
                     -column => '3',          -ipady => '0',
                     -row    => '4',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'w');
    $ent3_pass->grid(-in     => $mw,          -ipadx => '0',
                     -column => '6',          -ipady => '0',
                     -row    => '4',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'w');
    $b1_logi  ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '3',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b2_logo  ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '4',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b3_get   ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '6',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b4_put   ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '7',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b5_mkdir ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '8',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b6_ren   ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '9',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b7_del   ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '10',         -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b8_help  ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '11',         -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b9_exit  ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '11',         -ipady => '0',
                     -row    => '12',         -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $b10_bmark->grid(-in     => $mw,          -ipadx => '0',
                     -column => '8',          -ipady => '0',
                     -row    => '3',          -padx => '0',
                     -columnspan => '1',      -pady => '0',
                     -rowspan => '1',         -sticky => 'new');
    $lf1      ->grid(-in     => $mw,          -ipadx => '0',
                     -column => '1',          -ipady => '0',
                     -row    => '15',         -padx => '0',
                     -columnspan => '12',     -pady => '0',
                     -rowspan => '1',         -sticky => 'nesw');

    #Grid Configuration
    $mw->gridRowconfigure(1, -weight => 0, -minsize => 40, -pad => 0);
    $mw->gridRowconfigure(2, -weight => 0, -minsize => 8, -pad => 0);
    $mw->gridRowconfigure(3, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(4, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(5, -weight => 0, -minsize => 8, -pad => 0);
    $mw->gridRowconfigure(6, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(7, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(8, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(9, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(10, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(11, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(12, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridRowconfigure(13, -weight => 1, -minsize => 180, -pad => 0);
    $mw->gridRowconfigure(14, -weight => 0, -minsize => 18, -pad => 0);
    $mw->gridRowconfigure(15, -weight => 0, -minsize => 18, -pad => 0);
    $mw->gridColumnconfigure(1, -weight => 0, -minsize => 18, -pad => 0);
    $mw->gridColumnconfigure(2, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridColumnconfigure(3, -weight => 0, -minsize => 118, -pad => 0);
    $mw->gridColumnconfigure(4, -weight => 0, -minsize => 4, -pad => 0);
    $mw->gridColumnconfigure(5, -weight => 0, -minsize => 2, -pad => 0);
    $mw->gridColumnconfigure(6, -weight => 1, -minsize => 276, -pad => 0);
    $mw->gridColumnconfigure(7, -weight => 0, -minsize => 4, -pad => 0);
    $mw->gridColumnconfigure(8, -weight => 0, -minsize => 3, -pad => 0);
    $mw->gridColumnconfigure(9, -weight => 0, -minsize => 22, -pad => 0);
    $mw->gridColumnconfigure(10, -weight => 0, -minsize => 18, -pad => 0);
    $mw->gridColumnconfigure(11, -weight => 0, -minsize => 40, -pad => 0);
    $mw->gridColumnconfigure(12, -weight => 0, -minsize => 18, -pad => 0);

    #Defaults
    $ent1_host->focus;
    $lf1_txt = $lf1->Label(-text => 'Not Connected')->pack;

    #Callbacks
    sub b1_login_cmd #--------------------------------------------------
    {
        $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@_.%_'}
        $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
            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:
    }

    sub b2_logout_cmd #-------------------------------------------------
    {
        if ($ftp) {
            $ftp->quit; $lf1_txt->destroy;
            $lf1_txt = $lf1->Label(-text => 'Not Connected')->pack;
        }
        $hlst1->delete('all'); undef $ftp;
    }

    sub b3_get_cmd
    {
    my @selected = $hlst1->selectionGet;
    foreach (@selected) {
        my $selected = $hlst1->itemCget($_, 0, -text);
        my $isdir    = $hlst1->itemCget($_, 1, -text);
        if ($_ eq 'up1')       {$ftp->cdup; goto b3_end;}
        if ($isdir eq '<DIR>') {$ftp->cwd($selected)
                                || &error(3); goto b3_end;}
        if ($isdir eq '<LINK>') {my $fs = 0; linkstart:
                                 my $tst = $ftp->cwd($selected);
                                 if ($tst == 0)
                                 {$fs++; my  @a = split('/', $selected);
                                  pop @a;  $selected = join('/', @a);
                                  unless($fs > 10) {goto linkstart;}}
                                 else {goto b3_end;}
                                 $ftp->cwd($selected)
                                 || &error(3); goto b3_end;}
        $ftp->pasv; $ftp->binary;
        &save_file($selected) if $ftp->get($selected, '~pftpc.tmp');
    }
    b3_end: &ftp_session();
    }

    sub b4_put_cmd #----------------------------------------------------
    {
        if (my $current_dir = $ftp->pwd()){}
        else {warn "Unable to determine the current working directory\n"
              ."$@\n";}
        my $types = [['All Files',        '*',             ],];
        my $ofile = $mw->getOpenFile(-title => 'Select File for Upload',
                                     -filetype => $types,);
        if (defined ($ofile)) {$ftp->put($ofile) || &error(4);}
        &ftp_session();
    }

    sub b5_mkdir_cmd #--------------------------------------------------
    {
        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) || &error(5);}
        &ftp_session();
    }

    sub b6_ren_cmd
    {
        my @selected = $hlst1->selectionGet;
        foreach(@selected) {
            my $selected = $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 = $selected;
            my $answer = $db->Show();
            if ($answer eq "Rename") {$ftp->rename($selected, $to)
                                      || &error(6);}
        }
        b6_end: &ftp_session();
    }

    sub b7_del_cmd #----------------------------------------------------
    {
        my @selected = $hlst1->selectionGet;
        foreach(@selected) {
            my $selected = $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 $selected?",)->pack;
            my $answer = $db->Show();
            if ($answer eq "Delete") {
                if   ($isdir eq '<DIR>') {$ftp->rmdir($selected, '1')
                                          || &error(7);}
                else {$ftp->delete($selected) || &error(7);}
            }
        }
        b7_end: &ftp_session();
    }

    sub b8_help_cmd
    {
        my $email = 'QoS@cpan.org';
        my $db = $mw->DialogBox(-title => 'PFTPC Help',
                                -buttons => ['Close'],
                                -default_button => 'Close');
        my $t = $db->add('Scrolled', 'ROText',
                         -scrollbars => 'e',
                         -width => 80,
                         -height => 20,)->pack;
        $t ->insert('end', <<ENDTEXT
Examples of FTP sites:  ftp.cpan.org
                        ftp://ftp.cpan.org
                        ftp://ftp.cpan.org:21
                        192.168.0.1:55555
                        127.0.0.1

Use the User and Password fields if the FTP site requires it.

If no Port information is entered then the default port 21 will be used.
Unless a Username is entered the default anonymous login will be used.

Please note:  Column sorting is not yet implemented.
              This is beta software send comments/bugs/suggestions to:
              $email
ENDTEXT
    );$db->Show();}

    sub b9_exit_cmd #---------------------------------------------------
        {exit;}

    sub b10_bmark_cmd #-------------------------------------------------
    {
        my $db = $mw->DialogBox(-title => 'Bookmarks',
                                -buttons => ['Close'],
                                -default_button => 'Close');
        my $t = $db->add('ROText', -background => '#000000',
                         -wrap => 'none', -width => 80,
                         -height => 20,)->pack;
        $t->insert('end', '    ');
        my $bmark_lb = $t->Scrolled('Listbox', -scrollbars => 'osoe',
                                    -selectmode => 'single',
                                    -width => 80,
                                    -background => '#000000',
                                    -foreground => '#ffffff',
                                    -selectbackground => '#fff000',
                                    -selectforeground => '#000000',);
        $t->windowCreate('end', -window => $bmark_lb);
        $t->insert('end', "\n\n       ");
        my $e = $t->Entry(-width => 60, -textvariable => \our $add);
        $t->windowCreate('end', -window => $e);
        $t->insert('end', '    ');
        my $b = $t->Button(-text => "Add Bookmark",
                           -background => '#000000',
                           -foreground => '#ffffff',
                           -activeforeground => '#fff000',
                           -activebackground => '#000000',
                           -relief => 'flat',
                           -height => 1,
                           -command => sub {
                                $bmark_lb->insert('end', "$add\n");
                                if (-e 'bookmark.txt') {
                                    open (FH, '>> bookmark.txt');
                                    print FH "$add\n";
                                    close FH; undef $add;
                                }
                            });
        $t->windowCreate('end', -window => $b);
        $t->insert('end', "\n\n");
        if (-e 'bookmark.txt') {
            open (FH, '< bookmark.txt'); my @b = (<FH>); close FH;
            foreach (@b) {$bmark_lb->insert('end', "$_");}
        }
        else {
            open (FH, '> bookmark.txt') or warn 'Cannot create'.
            "bookmark file.\a\n$!"; if ('FH') {close FH;}
        }
        $bmark_lb->bind("<Double-Button-1>", sub { no warnings;
           my $sel = $bmark_lb->curselection;
           my $val = $bmark_lb->get("$sel"); chomp $val;
           undef $host; $host = $val; $db->destroy;
        });
        $db->Show();
    }
}

sub ftp_session #-------------------------------------------------------
{
    unless ($ftp) {goto ftp_session_end;}
    my $cwd = $ftp->pwd(); unless ($cwd) {$cwd = '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;

    $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 ($perms =~ m/^d+?/i) {$filesize  = '<DIR>';}
        if ($perms =~ m/^l+?/i) {$filesize  = '<LINK>';}
        
        $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 $filesize; undef $perms; undef $timedate;
    }
    ftp_session_end:
}

sub save_file #---------------------------------------------------------
{
    my $types = [['All Files',        '*',             ],];
    my $sfile = $mw->getSaveFile(-title => 'Save File',
                                 -filetypes => $types,
                                 -initialfile => $_[0]);
    if  (defined ($sfile))
        {copy('~pftpc.tmp', $sfile); unlink '~pftpc.tmp';}
}

sub loadhistory #-------------------------------------------------------
{
    goto loadhistory_end if ($loadhistory == 1);
    if (-e 'pftpc.hst') {
        open(HIST_IN, 'pftpc.hst') || warn "Cannot open history $!";
        my @hist = <HIST_IN>; close HIST_IN;
        CheckHistSize: my $histsize = $#hist;
        if ($histsize >= 9) {shift @hist; goto CheckHistSize;}
        foreach (@hist) {chomp $_; $ent1_host->insert('end', $_);}
    }
    else {open(HIST_OUT, '> pftpc.hst'); close HIST_OUT;}
    $loadhistory = 1; loadhistory_end:
}

sub history #-----------------------------------------------------------
{
    $ent1_host->insert('end', $host);
    open (HIST_OUT, '>> pftpc.hst') || warn "Cannot append history $!";
    print HIST_OUT "$host\n"; close HIST_OUT;
}

sub BindMouseWheel #----------------------------------------------------
{
    my($w) = @_;
    if ($^O eq 'MSWin32') {
        $w->bind('<MouseWheel>'=>[sub{
        $_[0]->yview('scroll', -($_[1]/120)*3,'units')} ,Ev('D')]);
    }
    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;
    }
}

#POD Section#
=head1 NAME

-=PFTPC=- Perl FTP Client v1.0

=head1 DESCRIPTION

Navigate FTP sites.

=head1 README

-=PFTPC=- Perl FTP Client - basic graphical FTP site browser.

=head1 PREREQUISITES

Net-FTP
Tk-ResizeButton
Tk

=head1 COREQUISITES

This script optionally requires:  Tk-Autoscroll

=head1 History

v2  - Added Bookmarks, minor gui enhancements.
v1a - Symlink support.
v1  - Initial release.

=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

any?

=pod SCRIPT CATEGORIES

Networking
Web

=cut