#!Perl $^W = 1; use strict; use Config; use Tk; use Tk::Menu; use Tk::HList; use Tk::ROText; use Fcntl qw(:DEFAULT :flock); #Optional Modules if ($^O eq 'MSWin32') { use Win32::Process; eval { require Win32::Console; Win32::Console::Free() }; if ($@) { warn "Win32::Console is not installed.\n$@"; } } #Declarations# my $VERSION = 1.1; my $screen = 'Log'; my ($after_id, %usr, $pid,); #Main# my $mw = MainWindow->new(); $mw->geometry('+45+50'); &init(); &pftps_gui(); &Tk::MainLoop(); #Subroutines# sub init #-------------------------------------------------------------- { if (open (FH, ">pftps.log")) { print FH "Welcome to PFTPs\n"; close FH; }else{ die "Cannot create pftps.log.\a\n$!"; } unless (-e 'pftps.cfg') { open (FH, ">pftps.cfg") or die "Cannot create pftps.log\a\n$!"; print FH "IP~::~127.0.0.1\n"; print FH "PORT~::~21\n"; print FH "MAXTOT~::~10\n"; print FH "MAXIP~::~1\n"; print FH "TIMEOUT~::~5\n"; print FH "~::~Enabled~::~Deny\n"; close FH; } unless (-e 'pftps.usr') { open (FH, ">pftps.usr") or die "Cannot create pftps.usr\a\n$!"; print FH 'anonymous~::~ok~::~N~::~Y~::~N~::~N~::~N~::~N~::~Y'. "~::~\n"; } unless (-e 'pftps.sec') { open (FH, ">pftps.sec") or die "Cannot create pftps.sec.\a\n$!"; flock(FH, LOCK_EX); close FH; } unless (-e 'PFTPs_T_v1_1.plx') { open (FH, '>PFTPs_T_v1_1.plx') or die "Cannot create PFTPs_T_v1_1.plx\a\n$!"; while() { chomp; print FH "$_\n";} close FH; } } sub pftps_gui #--------------------------------------------------------- { #Widgets my $menu_1 = $mw->Menu(); my $meni_1 = $mw->Menu(-tearoff => '0',); my $meni_2 = $mw->Menu(-tearoff => '0',); my $meni_3 = $mw->Menu(-tearoff => '0',); $menu_1->cascade(-label => 'Server', -underline => '0', -menu => $meni_1,); $menu_1->cascade(-label => 'View', -underline => '0', -menu => $meni_2); $menu_1->cascade(-label => 'Help', -underline => '0', -menu => $meni_3); foreach ('Start', 'Stop', 'Exit',) { if ($_ eq 'Exit') { $meni_1->separator(); } my $x = $_; $meni_1->radiobutton(-label => "$_", -underline => '0', -command => sub {&menu_1_cmd("$x");}); } foreach ('Log', 'Online', 'Accounts', 'Security', 'Configuration',) { my $x = $_; $meni_2->radiobutton(-label => "$_", -underline => '0', -command => sub {&menu_1_cmd("$x");}); } foreach ('Help', 'About',) { my $x = $_; $meni_3->radiobutton(-label => "$_", -underline => '0', -command => sub {&menu_1_cmd("$x");}); } $mw->configure(-menu => $menu_1,); my $fr1_btn = $mw->Frame(-relief => 'groove', -bd => '2',); my $fr2_btn = $mw->Frame(-relief => 'groove', -bd => '2',); my $fr3_btn = $mw->Frame(-relief => 'groove', -bd => '2',); our $fr4_log = $mw->Frame(-relief => 'sunken', -bd => '2',); our $fr5_onl = $mw->Frame(-relief => 'sunken', -bd => '2',); our $fr6_act = $mw->Frame(-relief => 'sunken', -bd => '2',); our $fr7_sec = $mw->Frame(-relief => 'sunken', -bd => '2',); our $fr8_cfg = $mw->Frame(-relief => 'sunken', -bd => '2',); our $fr9_hlp = $mw->Frame(-relief => 'sunken', -bd => '2',); our ($b1, $b2,); $b1 = $mw->Button(-text => 'Start', -bd => 2, -width => '10', -relief => 'raised', -activeforeground => 'green', -disabledforeground => 'green', -command => sub { $b2->configure(-state => 'normal',); $b1->configure(-relief => 'sunken', -state => 'disabled',); &menu_1_cmd('Start'); }); $b2 = $mw->Button(-text => 'Stop', -bd => 2, -width => '10', -state => 'disabled', -relief => 'raised', -activeforeground => 'red', -command => sub { &menu_1_cmd('Stop'); }); my $b3 = $mw->Button(-text => 'Log', -bd => 2, -width => '10', -relief => 'raised', -activeforeground => '#000fff', -command => sub { &menu_1_cmd('Log'); }); my $b4 = $mw->Button(-text => 'Online', -bd => 2, -width => '10', -relief => 'raised', -activeforeground => '#000fff', -command => sub { &menu_1_cmd('Online'); }); my $b5 = $mw->Button(-text => 'Accounts', -bd => 2, -width => '10', -relief => 'raised', -activeforeground => '#000fff', -command => sub { &menu_1_cmd('Accounts'); }); my $b6 = $mw->Button(-text => 'Security', -bd => 2, -width => '10', -relief => 'raised', -activeforeground => '#000fff', -command => sub { &menu_1_cmd('Security'); }); my $b7 = $mw->Button(-text => 'Configuration', -bd => 2, -width => '10', -relief => 'raised', -activeforeground => '#000fff', -command => sub { &menu_1_cmd('Configuration'); }); my $l1_btn = $mw->Label(-text => 'Perl FTP Server', -font => 'Verdana 12', -relief => 'flat',); my $l1_log = $fr4_log->Label(-text => 'Server Log', -relief => 'flat', -anchor => 'w',); our $t1_log = $fr4_log->Scrolled('ROText', -scrollbars => 'e', -fg => '#000000', -bg => '#ffffff', -selectforeground => '#000000', -selectbackground => '#ffffff', -width => '80',); $t1_log->menu(undef); $t1_log->tagConfigure("Blue", -foreground => "#000fff"); $t1_log->tagConfigure("Bold", -font => "Courier 8 bold"); my $f1_log = $fr4_log->Frame(-relief => 'sunken', -bd => '2',); my $b1_log = $fr4_log->Button(-text => 'Save', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &log_cmd('Save'); }); my $b2_log = $fr4_log->Button(-text => 'Clear', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &log_cmd('Clear'); }); our $b3_log; $b3_log = $fr4_log->Button(-text => 'Pause', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { $b3_log->configure (-text => 'Resume', -relief => 'sunken',); &log_cmd('Pause1'); }); my $l1_onl = $fr5_onl->Label(-text => 'Online Users', -anchor => 'w',); my $f1_onl = $fr5_onl->Frame(-relief => 'sunken', -bd => '2',); my $b1_onl = $fr5_onl->Button(-text => 'Kick User', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &onl_cmd('KickUser'); }); my $b2_onl = $fr5_onl->Button(-text => 'Ban User', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &onl_cmd('BanUser'); }); my $b3_onl = $fr5_onl->Button(-text => 'Ban IP', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &onl_cmd('BanIP'); }); our $b4_onl; $b4_onl = $fr5_onl->Button(-text => 'Pause', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { $b4_onl->configure (-text => 'Resume', -relief => 'sunken',); &onl_cmd('Pause1'); }); our $h1_onl = $fr5_onl->Scrolled('HList', -columns => 5, -header => 1, -scrollbars => 'ose', -font => '{Ariel} 8', -width => '80', -background => '#ffffff', -foreground => '#000000', -selectbackground => '#000000', -selectforeground => '#fff000', -selectmode => 'single',); $h1_onl->columnWidth (0, -char => '40'); $h1_onl->columnWidth (1, -char => '10'); $h1_onl->columnWidth (2, -char => '20'); $h1_onl->columnWidth (3, -char => '40'); $h1_onl->columnWidth (4, -char => ''); $h1_onl->headerCreate(0, -text => 'Users',); $h1_onl->headerCreate(1, -text => 'UID',); $h1_onl->headerCreate(2, -text => 'IP Address',); $h1_onl->headerCreate(3, -text => 'Login Time',); my $f1_act = $fr6_act->Frame(); my $f2_act = $fr6_act->Frame(-relief => 'sunken', -bd => '2',); my $l1_act = $fr6_act->Label(-text => 'User Accounts', -anchor => 'w'); my $l2_act = $fr6_act->Label(-text => 'Account Disabled', -anchor => 'w'); my $l3_act = $fr6_act->Label(-text => 'Allow Download', -anchor => 'w'); my $l4_act = $fr6_act->Label(-text => 'Allow Upload', -anchor => 'w'); my $l5_act = $fr6_act->Label(-text => 'Allow Delete', -anchor => 'w'); my $l6_act = $fr6_act->Label(-text => 'Allow Rename', -anchor => 'w'); my $l7_act = $fr6_act->Label(-text => 'Allow Create Directory', -anchor => 'w'); my $l8_act = $fr6_act->Label(-text => 'Allow Concurrent'. 'Connections', -anchor => 'w'); my $l9_act = $fr6_act->Label(-text => 'Home Directory must be '. 'configured to enable account.', -anchor => 'w', -fg => '#080080',); our $e1_act = $fr6_act->Entry(-width => '50', -state => 'disabled', -bg => '#ffffff', -fg => '#000000', -disabledbackground => '#ffffff', -disabledforeground => '#000000',); our $c1_act = $fr6_act->Checkbutton(-variable => \our $act_c1, -command => sub { &act_cmd('Disabled'); }); our $c2_act = $fr6_act->Checkbutton(-variable => \our $act_c2, -command => sub { &act_cmd('Download'); }); our $c3_act = $fr6_act->Checkbutton(-variable => \our $act_c3, -command => sub { &act_cmd('Upload'); }); our $c4_act = $fr6_act->Checkbutton(-variable => \our $act_c4, -command => sub { &act_cmd('Delete'); }); our $c5_act = $fr6_act->Checkbutton(-variable => \our $act_c5, -command => sub { &act_cmd('Rename'); }); our $c6_act = $fr6_act->Checkbutton(-variable => \our $act_c6, -command => sub { &act_cmd('Directory'); }); our $c7_act = $fr6_act->Checkbutton(-variable => \our $act_c7, -command => sub { &act_cmd('Concurrent'); }); our $h1_act = $fr6_act->Scrolled('HList', -scrollbars => 'ose', -header => 1, -columns => 2, -font => '{Ariel} 8', -width => '40', -background => '#ffffff', -foreground => '#000000', -selectbackground => '#000000', -selectforeground => '#fff000', -selectmode => 'single', -browsecmd => \&act_browse); $h1_act->columnWidth (0, -char => '38'); $h1_act->columnWidth (1, -char => ''); $h1_act->headerCreate(0, -text => 'Users',); my $b1_act = $fr6_act->Button(-text => 'Add', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &act_cmd('Add'); }); my $b2_act = $fr6_act->Button(-text => 'Remove', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &act_cmd('Remove'); }); my $b3_act = $fr6_act->Button(-text => "Home\nDirectory", -bd => '2', -width => '10', -relief => 'flat', -activeforeground => '#fff000', -command => sub { &act_cmd('HomeDir'); }); my $f1_sec = $fr7_sec->Label(-relief => 'sunken', -bd => '2',); my $f2_sec = $fr7_sec->Label(-relief => 'sunken', -bd => '2',); my $l1_sec = $fr7_sec->Label(-text => 'Security', -anchor => 'w',); my $l2_sec = $fr7_sec->Label(-text => 'Filter Mode:', -anchor => 'w',); my $l3_sec = $fr7_sec->Label(-text => 'Disable IP Filter', -anchor => 'w',); my $l4_sec = $fr7_sec->Label(-text => 'Allow Specified Addresses', -anchor => 'w',); my $l5_sec = $fr7_sec->Label(-text => 'Deny Specified Addresses', -anchor => 'w',); our $h1_sec = $fr7_sec->Scrolled('HList', -scrollbars => 'ose', -columns => 1, -font => '{Ariel} 8', -width => '80', -background => '#ffffff', -foreground => '#000000', -selectbackground => '#000000', -selectforeground => '#fff000', -selectmode => 'single',); our $c1_sec = $fr7_sec->Checkbutton(-variable => \our $sec_c1, -command => sub { &sec_cmd('Disable'); }); our $c2_sec = $fr7_sec->Checkbutton(-variable => \our $sec_c2, -command => sub { &sec_cmd('Allow'); }); our $c3_sec = $fr7_sec->Checkbutton(-variable => \our $sec_c3, -command => sub { $c2_sec->deselect; &sec_cmd('Deny'); }); my $b1_sec = $fr7_sec->Button(-text => 'Add', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &sec_cmd('Add'); }); my $b2_sec = $fr7_sec->Button(-text => 'Remove', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &sec_cmd('Remove'); }); my $f1_cfg = $fr8_cfg->Frame(-relief => 'sunken', -bd => '2',); my $f2_cfg = $fr8_cfg->Frame(-relief => 'sunken', -bd => '2',); my $l1_cfg = $fr8_cfg->Label(-text => 'Configuration', -anchor => 'w',); my $l2_cfg = $fr8_cfg->Label(-text => 'IP Address', -anchor => 'w', -fg => '#000000',); my $l3_cfg = $fr8_cfg->Label(-text => 'Port', -anchor => 'w', -fg => '#000000',); my $l4_cfg = $fr8_cfg->Label(-text => 'Max Connections (total)', -anchor => 'w', -fg => '#000000',); my $l5_cfg = $fr8_cfg->Label(-text => 'Max Connections (per IP)', -anchor => 'w', -fg => '#000000',); my $l6_cfg = $fr8_cfg->Label(-text => 'Session Timeout', -anchor => 'w', -fg => '#000000',); my $l7_cfg = $fr8_cfg->Label(-text => 'The server must be ' . 'restarted for changes to take ' . 'effect.', -fg => '#080080',); our $e1_cfg = $fr8_cfg->Entry(-width => '15', -bg => '#ffffff', -fg => '#000000', -selectforeground => '#fff000', -selectbackground => '#000000',); our $e2_cfg = $fr8_cfg->Entry(-width => '5', -bg => '#ffffff', -fg => '#000000', -selectforeground => '#fff000', -selectbackground => '#000000',); our $e3_cfg = $fr8_cfg->Entry(-width => '3', -bg => '#ffffff', -fg => '#000000', -selectforeground => '#fff000', -selectbackground => '#000000',); our $e4_cfg = $fr8_cfg->Entry(-width => '3', -bg => '#ffffff', -fg => '#000000', -selectforeground => '#fff000', -selectbackground => '#000000',); our $e5_cfg = $fr8_cfg->Entry(-width => '3', -bg => '#ffffff', -fg => '#000000', -selectforeground => '#fff000', -selectbackground => '#000000',); my $b1_cfg = $fr8_cfg->Button(-text => 'Save', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &cfg_cmd('Save'); }); my $f1_hlp = $fr9_hlp->Frame(-relief => 'sunken', -bd => 2, -bg => '#ffffff',); my $l1_hlp = $fr9_hlp->Label(-text => 'Help/About', -relief => 'flat', -anchor => 'w',); my $b1_hlp = $f1_hlp->Button(-text => 'Server', -fg => '#000000', -bg => '#ffffff', -width => '10', -relief => 'flat', -activeforeground => '#000fff', -activebackground => '#ffffff', -command => sub { &hlp_cmd('Server'); }); my $b2_hlp = $f1_hlp->Button(-text => 'Log', -fg => '#000000', -bg => '#ffffff', -width => '10', -relief => 'flat', -activeforeground => '#000fff', -activebackground => '#ffffff', -command => sub { &hlp_cmd('Log'); }); my $b3_hlp = $f1_hlp->Button(-text => 'Online', -fg => '#000000', -bg => '#ffffff', -width => '10', -relief => 'flat', -activeforeground => '#000fff', -activebackground => '#ffffff', -command => sub { &hlp_cmd('Online'); }); my $b4_hlp = $f1_hlp->Button(-text => 'Accounts', -fg => '#000000', -bg => '#ffffff', -width => '10', -relief => 'flat', -activeforeground => '#000fff', -activebackground => '#ffffff', -command => sub { &hlp_cmd('Accounts'); }); my $b5_hlp = $f1_hlp->Button(-text => 'Security', -fg => '#000000', -bg => '#ffffff', -width => '10', -relief => 'flat', -activeforeground => '#000fff', -activebackground => '#ffffff', -command => sub { &hlp_cmd('Security'); }); my $b6_hlp = $f1_hlp->Button(-text => 'Configuration', -fg => '#000000', -bg => '#ffffff', -width => '10', -relief => 'flat', -activeforeground => '#000fff', -activebackground => '#ffffff', -command => sub { &hlp_cmd('Configuration'); }); my $b7_hlp = $f1_hlp->Button(-text => 'About', -fg => '#000000', -bg => '#ffffff', -width => '10', -relief => 'flat', -activeforeground => '#000fff', -activebackground => '#ffffff', -command => sub { &hlp_cmd('About'); }); our $t1_hlp = $f1_hlp->Scrolled('ROText', -scrollbars => 'oe', -relief => 'groove', -bd => 4, -fg => '#000000', -bg => '#ffffff', -selectforeground => '#000000', -selectbackground => '#ffffff', -width => '80',); $t1_hlp->menu(undef); our $tl1 = $mw->Toplevel(-takefocus => 1,); $tl1->title('New User'); $tl1->geometry('+300+250'); $tl1->resizable(0, 0); $tl1->transient($mw); $tl1->withdraw; my $l1_tl1 = $tl1->Label(-text => 'Username:',); my $l2_tl1 = $tl1->Label(-text => 'Password:',); our $e1_tl1 = $tl1->Entry(-width => '20', -selectforeground => '#fff000', -selectbackground => '#000000', -bg => '#ffffff', -fg => '#000000',); our $e2_tl1 = $tl1->Entry(-width => '20', -show => '*', -selectforeground => '#fff000', -selectbackground => '#000000', -bg => '#ffffff', -fg => '#000000',); my $b1_tl1 = $tl1->Button(-text => 'Save', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &act_cmd('SaveUser'); }); my $b2_tl1 = $tl1->Button(-text => 'Cancel', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { $tl1->withdraw; $mw->update; }); our $tl2 = $mw->Toplevel(-takefocus => 1,); $tl2->title('Add IP'); $tl2->geometry('+300+250'); $tl2->resizable(0, 0); $tl2->transient($mw); $tl2->withdraw; my $l1_tl2 = $tl2->Label(-text => 'IP Address:',); our $e1_tl2 = $tl2->Entry(-width => '20', -selectforeground => '#fff000', -selectbackground => '#000000', -bg => '#ffffff', -fg => '#000000',); my $b1_tl2 = $tl2->Button(-text => 'Save', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { &sec_cmd('SaveIP'); }); my $b2_tl2 = $tl2->Button(-text => 'Cancel', -bd => '2', -width => '10', -relief => 'raised', -activeforeground => '#fff000', -command => sub { $tl2->withdraw; $mw->update; }); #Bindings $l1_btn->bind('' => sub { $l1_btn->configure(-text => ''); $mw->update; $mw->after(500); $l1_btn->configure(-text => 'PFTPs_v1_0'); $mw->update; $mw->after(2000); $l1_btn->configure(-text => ''); $mw->update; $mw->after(500); $l1_btn->configure(-text => 'Perl FTP Server'); }); $mw->protocol (WM_DELETE_WINDOW => sub {&menu_1_cmd('Exit');}); $tl1->protocol(WM_DELETE_WINDOW => sub {$tl1->withdraw;}); $tl2->protocol(WM_DELETE_WINDOW => sub {$tl2->withdraw;}); &FlashButton($b3_act, '#00ff00', '#000000'); &FlashButton($b1_hlp, '#000000', '#000000'); &FlashButton($b2_hlp, '#000000', '#000000'); &FlashButton($b3_hlp, '#000000', '#000000'); &FlashButton($b4_hlp, '#000000', '#000000'); &FlashButton($b5_hlp, '#000000', '#000000'); &FlashButton($b6_hlp, '#000000', '#000000'); &FlashButton($b7_hlp, '#000000', '#000000'); &BindMouseWheel($t1_log); &BindMouseWheel($h1_act); &BindMouseWheel($h1_onl); &BindMouseWheel($h1_sec); &BindMouseWheel($t1_hlp); #Grid $fr1_btn ->grid(-in => $mw, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $fr2_btn ->grid(-in => $mw, -columnspan => '1', -column => '3', -rowspan => '1', -row => '1', -sticky => 'news'); $fr3_btn ->grid(-in => $mw, -columnspan => '1', -column => '5', -rowspan => '1', -row => '1', -sticky => 'news'); $fr4_log ->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $b1 ->grid(-in => $fr1_btn, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $b2 ->grid(-in => $fr1_btn, -columnspan => '1', -column => '2', -rowspan => '1', -row => '1', -sticky => 'news'); $b3 ->grid(-in => $fr2_btn, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $b4 ->grid(-in => $fr2_btn, -columnspan => '1', -column => '2', -rowspan => '1', -row => '1', -sticky => 'news'); $b5 ->grid(-in => $fr2_btn, -columnspan => '1', -column => '3', -rowspan => '1', -row => '1', -sticky => 'news'); $b6 ->grid(-in => $fr2_btn, -columnspan => '1', -column => '4', -rowspan => '1', -row => '1', -sticky => 'news'); $b7 ->grid(-in => $fr2_btn, -columnspan => '1', -column => '5', -rowspan => '1', -row => '1', -sticky => 'news'); $l1_btn ->grid(-in => $fr3_btn, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $l1_log ->grid(-in => $fr4_log, -columnspan => '2', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $t1_log ->grid(-in => $fr4_log, -columnspan => '2', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $f1_log ->grid(-in => $fr4_log, -columnspan => '1', -column => '1', -rowspan => '1', -row => '3', -sticky => 'news'); $b1_log ->grid(-in => $f1_log, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => ''); $b2_log ->grid(-in => $f1_log, -columnspan => '1', -column => '2', -rowspan => '1', -row => '1', -sticky => ''); $b3_log ->grid(-in => $f1_log, -columnspan => '1', -column => '3', -rowspan => '1', -row => '1', -sticky => ''); $l1_onl ->grid(-in => $fr5_onl, -columnspan => '2', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $h1_onl ->grid(-in => $fr5_onl, -columnspan => '2', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $f1_onl ->grid(-in => $fr5_onl, -columnspan => '1', -column => '1', -rowspan => '1', -row => '3', -sticky => 'news'); $b1_onl ->grid(-in => $f1_onl, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => ''); $b2_onl ->grid(-in => $f1_onl, -columnspan => '1', -column => '2', -rowspan => '1', -row => '1', -sticky => ''); $b3_onl ->grid(-in => $f1_onl, -columnspan => '1', -column => '3', -rowspan => '1', -row => '1', -sticky => ''); $b4_onl ->grid(-in => $f1_onl, -columnspan => '1', -column => '4', -rowspan => '1', -row => '1', -sticky => ''); $f1_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '1', -rowspan => '1', -row => '11', -sticky => 'news'); $f2_act ->grid(-in => $f1_act, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $l1_act ->grid(-in => $fr6_act, -columnspan => '3', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $l2_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '2', -sticky => 'news'); $l3_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '3', -sticky => 'news'); $l4_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '4', -sticky => 'news'); $l5_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '5', -sticky => 'news'); $l6_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '6', -sticky => 'news'); $l7_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '7', -sticky => 'news'); $l8_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '8', -sticky => 'news'); $l9_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '9', -sticky => 'news'); $e1_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '3', -rowspan => '1', -row => '10', -sticky => 'w'); $c1_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '2', -sticky => 'e'); $c2_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '3', -sticky => 'e'); $c3_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '4', -sticky => 'e'); $c4_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '5', -sticky => 'e'); $c5_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '6', -sticky => 'e'); $c6_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '7', -sticky => 'e'); $c7_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '8', -sticky => 'e'); $h1_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '1', -rowspan => '9', -row => '2', -sticky => 'news'); $b1_act ->grid(-in => $f2_act, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $b2_act ->grid(-in => $f2_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '1', -sticky => 'news'); $b3_act ->grid(-in => $fr6_act, -columnspan => '1', -column => '2', -rowspan => '1', -row => '10', -sticky => ''); $l1_sec ->grid(-in => $fr7_sec, -columnspan => '3', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $l2_sec ->grid(-in => $fr7_sec, -columnspan => '3', -column => '1', -rowspan => '1', -row => '5', -sticky => 'news'); $l3_sec ->grid(-in => $fr7_sec, -columnspan => '1', -column => '2', -rowspan => '1', -row => '6', -sticky => 'w'); $l4_sec ->grid(-in => $fr7_sec, -columnspan => '1', -column => '2', -rowspan => '1', -row => '7', -sticky => 'w'); $l5_sec ->grid(-in => $fr7_sec, -columnspan => '1', -column => '2', -rowspan => '1', -row => '8', -sticky => 'w'); $h1_sec ->grid(-in => $fr7_sec, -columnspan => '2', -column => '1', -rowspan => '3', -row => '2', -sticky => 'news'); $c1_sec ->grid(-in => $fr7_sec, -columnspan => '1', -column => '1', -rowspan => '1', -row => '6', -sticky => 'w'); $c2_sec ->grid(-in => $fr7_sec, -columnspan => '1', -column => '1', -rowspan => '1', -row => '7', -sticky => 'w'); $c3_sec ->grid(-in => $fr7_sec, -columnspan => '1', -column => '1', -rowspan => '1', -row => '8', -sticky => 'w'); $f1_sec ->grid(-in => $fr7_sec, -columnspan => '1', -column => '3', -rowspan => '2', -row => '2', -sticky => 'news', -padx => '2', -pady => '2',); $b1_sec ->grid(-in => $f1_sec, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => '',); $b2_sec ->grid(-in => $f1_sec, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => '',); $f1_cfg ->grid(-in => $fr8_cfg, -columnspan => '2', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $f2_cfg ->grid(-in => $fr8_cfg, -columnspan => '1', -column => '1', -rowspan => '1', -row => '3', -sticky => 'news'); $l1_cfg ->grid(-in => $fr8_cfg, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $l2_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'nw'); $l3_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => 'nw'); $l4_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '1', -rowspan => '1', -row => '3', -sticky => 'nw'); $l5_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '1', -rowspan => '1', -row => '4', -sticky => 'nw'); $l6_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '1', -rowspan => '1', -row => '5', -sticky => 'nw'); $l7_cfg ->grid(-in => $f1_cfg, -columnspan => '2', -column => '1', -rowspan => '1', -row => '6', -sticky => 's'); $e1_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '2', -rowspan => '1', -row => '1', -sticky => 'w'); $e2_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '2', -rowspan => '1', -row => '2', -sticky => 'w'); $e3_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '2', -rowspan => '1', -row => '3', -sticky => 'w'); $e4_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '2', -rowspan => '1', -row => '4', -sticky => 'w'); $e5_cfg ->grid(-in => $f1_cfg, -columnspan => '1', -column => '2', -rowspan => '1', -row => '5', -sticky => 'w'); $b1_cfg ->grid(-in => $f2_cfg, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $f1_hlp ->grid(-in => $fr9_hlp, -columnspan => '1', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $l1_hlp ->grid(-in => $fr9_hlp, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => 'news'); $b1_hlp ->grid(-in => $f1_hlp, -columnspan => '1', -column => '1', -rowspan => '1', -row => '1', -sticky => ''); $b2_hlp ->grid(-in => $f1_hlp, -columnspan => '1', -column => '2', -rowspan => '1', -row => '1', -sticky => ''); $b3_hlp ->grid(-in => $f1_hlp, -columnspan => '1', -column => '3', -rowspan => '1', -row => '1', -sticky => ''); $b4_hlp ->grid(-in => $f1_hlp, -columnspan => '1', -column => '4', -rowspan => '1', -row => '1', -sticky => ''); $b5_hlp ->grid(-in => $f1_hlp, -columnspan => '1', -column => '5', -rowspan => '1', -row => '1', -sticky => ''); $b6_hlp ->grid(-in => $f1_hlp, -columnspan => '1', -column => '6', -rowspan => '1', -row => '1', -sticky => ''); $b7_hlp ->grid(-in => $f1_hlp, -columnspan => '1', -column => '7', -rowspan => '1', -row => '1', -sticky => ''); $t1_hlp ->grid(-in => $f1_hlp, -columnspan => '8', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $l1_tl1 ->grid(-in => $tl1, -columnspan => '1', -column => '2', -rowspan => '1', -row => '2', -sticky => 'news'); $l2_tl1 ->grid(-in => $tl1, -columnspan => '1', -column => '2', -rowspan => '1', -row => '3', -sticky => 'news'); $e1_tl1 ->grid(-in => $tl1, -columnspan => '1', -column => '3', -rowspan => '1', -row => '2', -sticky => 'w'); $e2_tl1 ->grid(-in => $tl1, -columnspan => '1', -column => '3', -rowspan => '1', -row => '3', -sticky => 'w'); $b1_tl1 ->grid(-in => $tl1, -columnspan => '1', -column => '2', -rowspan => '1', -row => '5', -sticky => 'w'); $b2_tl1 ->grid(-in => $tl1, -columnspan => '1', -column => '3', -rowspan => '1', -row => '5', -sticky => 'e'); $l1_tl2 ->grid(-in => $tl2, -columnspan => '1', -column => '2', -rowspan => '1', -row => '2', -sticky => 'news'); $e1_tl2 ->grid(-in => $tl2, -columnspan => '1', -column => '3', -rowspan => '1', -row => '2', -sticky => 'w'); $b1_tl2 ->grid(-in => $tl2, -columnspan => '1', -column => '2', -rowspan => '1', -row => '4', -sticky => 'w'); $b2_tl2 ->grid(-in => $tl2, -columnspan => '1', -column => '3', -rowspan => '1', -row => '4', -sticky => 'e'); $mw->gridRowconfigure(1, -minsize => 8,); $mw->gridRowconfigure(2, -minsize => 400, -weight => 1,); $mw->gridRowconfigure(3, -minsize => 16,); $mw->gridColumnconfigure(1, -minsize => 8,); $mw->gridColumnconfigure(2, -minsize => 2,); $mw->gridColumnconfigure(3, -minsize => 8,); $mw->gridColumnconfigure(4, -minsize => 2,); $mw->gridColumnconfigure(5, -minsize => 200, -weight => 1,); $fr1_btn->gridRowconfigure(1, -minsize => 8,); $fr1_btn->gridColumnconfigure(1, -minsize => 8,); $fr1_btn->gridColumnconfigure(2, -minsize => 8,); $fr2_btn->gridRowconfigure(1, -minsize => 8,); for (1..5) { $fr2_btn->gridColumnconfigure($_, -minsize => 8,); } $fr3_btn->gridRowconfigure(1, -minsize => 8, -weight => 1,); $fr3_btn->gridColumnconfigure(1, -minsize => 8, -weight => 1,); $fr4_log->gridRowconfigure(1, -minsize => 8,); $fr4_log->gridRowconfigure(2, -minsize => 8, -weight => 1,); $fr4_log->gridRowconfigure(3, -minsize => 8,); $fr4_log->gridColumnconfigure(1, -minsize => 8,); $fr4_log->gridColumnconfigure(2, -minsize => 8, -weight => 1,); $f1_log->gridRowconfigure(1, -minsize => 8,); $f1_log->gridColumnconfigure(1, -minsize => 8,); $f1_log->gridColumnconfigure(2, -minsize => 8,); $f1_log->gridColumnconfigure(3, -minsize => 8,); $fr5_onl->gridRowconfigure(1, -minsize => 8,); $fr5_onl->gridRowconfigure(2, -minsize => 24, -weight => 1,); $fr5_onl->gridRowconfigure(3, -minsize => 8,); $fr5_onl->gridColumnconfigure(1, -minsize => 8,); $fr5_onl->gridColumnconfigure(2, -minsize => 8, -weight => 1,); $f1_onl->gridRowconfigure(1, -minsize => 8,); for (1..4) { $f1_onl->gridColumnconfigure($_, -minsize => 8,); } for (1..9) { $fr6_act->gridRowconfigure($_, -minsize => 8,); } $fr6_act->gridRowconfigure(10, -minsize => 40, -weight => 1,); $fr6_act->gridRowconfigure(11, -minsize => 8,); $fr6_act->gridColumnconfigure(1, -minsize => 8,); $fr6_act->gridColumnconfigure(2, -minsize => 8,); $fr6_act->gridColumnconfigure(3, -minsize => 8, -weight => 1,); $f1_act->gridRowconfigure(1, -minsize => 8,); $f1_act->gridColumnconfigure(1, -minsize => 8,); $f1_act->gridColumnconfigure(2, -minsize => 8, -weight => 1,); $f2_act->gridRowconfigure(1, -minsize => 8,); $f2_act->gridColumnconfigure(1, -minsize => 8,); $f2_act->gridColumnconfigure(2, -minsize => 8,); $fr7_sec->gridRowconfigure(1, -minsize => 8,); $fr7_sec->gridRowconfigure(2, -minsize => 8,); $fr7_sec->gridRowconfigure(3, -minsize => 8,); $fr7_sec->gridRowconfigure(4, -minsize => 24, -weight => 1,); for (5..8) { $fr7_sec->gridRowconfigure($_, -minsize => 8,); } $fr7_sec->gridRowconfigure(9, -minsize => 8, -weight => 1,); $fr7_sec->gridColumnconfigure(1, -minsize => 2,); $fr7_sec->gridColumnconfigure(2, -minsize => 24, -weight => 1,); $fr7_sec->gridColumnconfigure(3, -minsize => 8,); $f1_sec->gridRowconfigure(1, -minsize => 8,); $f1_sec->gridRowconfigure(2, -minsize => 8,); $f1_sec->gridColumnconfigure(1, -minsize => 8,); $fr8_cfg->gridRowconfigure(1, -minsize => 8,); $fr8_cfg->gridRowconfigure(2, -minsize => 8, -weight => 1,); $fr8_cfg->gridRowconfigure(3, -minsize => 8,); $fr8_cfg->gridColumnconfigure(1, -minsize => 8,); $fr8_cfg->gridColumnconfigure(2, -minsize => 8, -weight => 1,); for (1..5) { $f1_cfg->gridRowconfigure($_, -minsize => 8, -pad => 2,); } $f1_cfg->gridRowconfigure(6, -minsize => 8, -weight => 1,); $f1_cfg->gridColumnconfigure(1, -minsize => 8,); $f1_cfg->gridColumnconfigure(2, -minsize => 8, -weight => 1,); $f2_cfg->gridRowconfigure(1, -minsize => 8,); $f2_cfg->gridColumnconfigure(1, -minsize => 8, -weight => 1,); $fr9_hlp->gridRowconfigure(1, -minsize => 8,); $fr9_hlp->gridRowconfigure(2, -minsize => 8, -weight => 1,); $fr9_hlp->gridColumnconfigure(1, -minsize => 8, -weight => 1,); $f1_hlp->gridRowconfigure(1, -minsize => 8,); $f1_hlp->gridRowconfigure(2, -minsize => 8, -weight => 1,); for (1..7) { $f1_hlp->gridColumnconfigure($_, -minsize => 8,); } $f1_hlp->gridColumnconfigure(8, -minsize => 8, -weight => 1,); for (1..6) { $tl1->gridRowconfigure($_, -minsize => 8,); } $tl1->gridColumnconfigure(1, -minsize => 16,); $tl1->gridColumnconfigure(2, -minsize => 8,); $tl1->gridColumnconfigure(3, -minsize => 8,); $tl1->gridColumnconfigure(4, -minsize => 16,); for (1..5) { $tl2->gridRowconfigure($_, -minsize => 8,); } $tl2->gridColumnconfigure(1, -minsize => 16,); $tl2->gridColumnconfigure(2, -minsize => 8,); $tl2->gridColumnconfigure(3, -minsize => 8,); $tl2->gridColumnconfigure(4, -minsize => 16,); #Defaults &menu_1_cmd('Log'); #Callbacks sub menu_1_cmd #---------------------------------------------------- { my $x = $_[0]; undef @_; undef %usr; $mw->Busy(-recurse => '1'); $b4_onl->configure(-text => 'Pause', -relief => 'raised', -command => sub { $b4_onl->configure(-text => 'Resume', -relief => 'sunken',); &onl_cmd('Pause1'); }); $b3_log->configure(-text => 'Pause', -relief => 'raised', -command => sub { $b3_log->configure(-text => 'Resume', -relief => 'sunken',); &log_cmd('Pause1'); }); eval {if ($after_id) {$mw->afterCancel($after_id)}}; $mw->update; if ($x eq 'Start') { if ($^O eq 'MSWin32') { #`"start /MIN PFTPs_T_v1_0.plx"`; my $wid; Win32::Process::Create($wid, $Config::Config{perlpath}, "$Config::Config{perlpath} PFTPs_T_v1_1.plx", 0, NORMAL_PRIORITY_CLASS, ".") || warn "Cannot start PFTPs_T_v1_1.plx\a\n$!"; }else{ my $fid; if ($fid = fork) {} elsif (defined $fid) { system("$Config::Config{perlpath}", 'PFTPs_T_v1_1.plx'); exit; }else{ warn "Cannot fork. Trying 'system'...\a$!"; warn "Cannot start PFTPs_T_v1_1.plx\a\n$!"; } } sleep(5); if (open (FH, "< pftps.log")) { flock(FH, LOCK_SH); while () { chomp; /PID:\s{1}(\d+)/; if ($1) { $pid = $1; } } }$x = 'Log'; } if ($x eq 'Stop') { #stop $b1->configure(-relief => 'raised', -state => 'normal',); $b2->configure(-state => 'disabled',); $mw->update; kill (1, $pid); if (open (FH, ">>pftps.log")) { flock(FH, LOCK_EX); my $now = localtime; print FH "Sever stopped.\t\t\t[$now]\n"; close FH; }else{ warn "Cannot append pftps.log.\a\n$!"; }$x = 'Log'; } if ($x eq 'Exit') { #exit $mw->Busy; $mw->update; if ($pid) {kill (1, $pid);} if (-e 'pftps.tmp') { unlink 'pftps.tmp' or warn "Unable to unlink pftps.tmp\a\n$!"; }exit; } if ($screen eq 'Log') { $fr4_log->gridForget(); } elsif ($screen eq 'Online') { $fr5_onl->gridForget(); } elsif ($screen eq 'Accounts') { $fr6_act->gridForget(); } elsif ($screen eq 'Security') { $fr7_sec->gridForget(); } elsif ($screen eq 'Configuration') { $fr8_cfg->gridForget(); } elsif ($screen eq 'About') { $fr9_hlp->gridForget(); } elsif ($screen eq 'Help') { $fr9_hlp->gridForget(); } if ($x eq 'Log') { $fr4_log->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $screen = $x; &log_update(); }elsif ($x eq 'Online') { $fr5_onl->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $screen = $x; &onl_update(); }elsif ($x eq 'Accounts') { $fr6_act->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $screen = $x; &act_update(); }elsif ($x eq 'Security') { $fr7_sec->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $screen = $x; &sec_update(); }elsif ($x eq 'Configuration') { $fr8_cfg->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $screen = $x; &cfg_update(); } elsif ($x eq 'Help') { $fr9_hlp->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $screen = $x; } elsif ($x eq 'About') { $fr9_hlp->grid(-in => $mw, -columnspan => '5', -column => '1', -rowspan => '1', -row => '2', -sticky => 'news'); $screen = $x; &hlp_cmd('About'); } menu_1_cmd_end: $mw->Unbusy; $mw->update; } sub log_cmd #------------------------------------------------------- { my $x = $_[0]; undef @_; $mw->Busy(-recurse => '1'); if ($x eq 'Save') { my $logtext = $t1_log->get('1.0', 'end'); my $sfile = $mw->getSaveFile( ); if (defined $sfile) { open (FH, "> $sfile"); print FH "$logtext\n"; close FH; } }elsif ($x eq 'Clear') { if (open (FH, ">pftps.log")) { print FH "Welcome to PFTPs\n"; close FH; }else{ warn "\aCannot open pftps.log unable to clear log.\n$!"; } }elsif ($x eq 'Pause1') { eval {if ($after_id) {$mw->afterCancel($after_id)}}; $b3_log->configure(-command => sub { &log_cmd('Pause2'); }); goto log_cmd_end; }elsif ($x eq 'Pause2') { $b3_log->configure(-text => 'Pause', -relief => 'raised', -command => sub { $b3_log->configure(-text => 'Resume', -relief => 'sunken',); &log_cmd('Pause1'); }); } &log_update(); log_cmd_end: $mw->Unbusy; } sub log_update #---------------------------------------------------- { if (open (FH, "< pftps.log")) { flock(FH, LOCK_SH); my @log = (); close FH; $t1_log->delete('1.0', 'end'); foreach (@log) { chomp; unless (/^ONLINEUSER:~::~.+/) { if (/^>>>.*/) { $t1_log->insert('end', "$_\n", ['Blue']); }elsif (/^<<<|^\w.*/) { $t1_log->insert('end', "$_\n"); }else{ $t1_log->insert('end', "$_\n", ['Bold']); } } } } $t1_log->see('end'); $mw->update; $after_id = $mw->after(8000, \&log_update); } sub onl_cmd #------------------------------------------------------- { my $x = $_[0]; undef @_; $mw->Busy(-recurse => '1'); if ($x eq 'KickUser') { #KickUser my @a = $h1_onl->selectionGet(); unless ($a[0]) { &onl_update(); goto onl_cmd_end; } my $kickuser = $h1_onl->itemCget($a[0], 0, -text); my $kickuid = $h1_onl->itemCget($a[0], 1, -text); if (open (FH, "> pftps.tmp")) { flock(FH, LOCK_EX); print FH "KICKUSER:~::~$kickuser~::~$kickuid\n"; close FH; }else{ warn "Cannot create pftps.tmp\a\n$!"; } } elsif ($x eq 'BanUser') { #Ban and KickUser my @a = $h1_onl->selectionGet(); unless ($a[0]) { &onl_update(); goto onl_cmd_end; } my $banuser = $h1_onl->itemCget($a[0], 0, -text); my $kickuid = $h1_onl->itemCget($a[0], 1, -text); if (open (FH, "< pftps.usr")) { flock(FH, LOCK_SH); my @usr = (); close FH; if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; s/($banuser~::~\w+~::~)\w+(.+)/$1Y$2/; print FH "$_\n"; }close FH; }else{ warn "Cannot create pftps.usr\a\n$!"; } }else{ warn "Cannot read pftps.usr\a\n$!"; } if (open (FH, "> pftps.tmp")) { flock(FH, LOCK_EX); print FH "KICKUSER:~::~$banuser~::~$kickuid\n"; close FH; }else{ warn "Cannot create pftps.tmp\a\n$!"; } } elsif ($x eq 'BanIP') { #BanIP and KickUser my @a = $h1_onl->selectionGet(); unless ($a[0]) { &onl_update(); goto onl_cmd_end; } my $banuser = $h1_onl->itemCget($a[0], 0, -text); my $banip = $h1_onl->itemCget($a[0], 1, -text); if (open (FH, ">> pftps.sec")) { flock(FH, LOCK_EX); print FH "$banip\n"; }else{ warn "Cannot append pftps.sec\a\n$!"; } close FH; if (open (FH, "> pftps.tmp")) { flock(FH, LOCK_EX); print FH "KICKUSER: $banuser\n"; close FH; }else{ warn "Cannot create pftps.tmp\a\n$!"; } } elsif ($x eq 'Pause1') { eval {if ($after_id) {$mw->afterCancel($after_id)}}; $b4_onl->configure(-command => sub { &onl_cmd('Pause2'); }); goto onl_cmd_end; } elsif ($x eq 'Pause2') { $b4_onl->configure(-text => 'Pause', -relief => 'raised', -command => sub { $b4_onl->configure(-text => 'Resume', -relief => 'sunken',); &onl_cmd('Pause1'); }); &onl_update(); } onl_cmd_end: $mw->Unbusy; } sub onl_update #---------------------------------------------------- { my %onl; $h1_onl->delete('all'); $mw->update; if (open (FH, "< pftps.log")) { flock(FH, LOCK_SH); my @onl = (); close FH; my $c = 0; foreach (@onl) { chomp; $c++; if (/ONLINEUSER:~::~(.+)~::~(.+)~::~(.+)~::~(.+)/) { $onl{$c} = [$1, $2, $3, $4]; } } $c = 0; foreach (keys %onl) { $c++; $h1_onl->add($c); $h1_onl->itemCreate($c, 0, -itemtype => 'text', -text => "$onl{$_}[0]"); $h1_onl->itemCreate($c, 1, -itemtype => 'text', -text => "$onl{$_}[1]"); $h1_onl->itemCreate($c, 2, -itemtype => 'text', -text => "$onl{$_}[2]"); $h1_onl->itemCreate($c, 3, -itemtype => 'text', -text => "$onl{$_}[3]"); } }else{ warn "Cannot to open pftps.log\a\n" . "Unable to update Online Users screen.\n$!"; } $mw->update; $after_id = $mw->after(10000, \&onl_update); } sub act_cmd #------------------------------------------------------- { my $x = $_[0]; undef @_; $mw->Busy(-recurse => '1'); if ($x eq 'Add') { #add $e1_tl1->delete(0, 'end'); $e2_tl1->delete(0, 'end'); $tl1->deiconify; $tl1->raise; $e1_tl1->focus; goto act_cmd_end; } elsif ($x eq 'Remove') { #remove my @a = $h1_act->selectionGet; unless ($a[0]) {goto act_cmd_end;} if (open (FH, "< pftps.usr")) { flock(FH, LOCK_SH); my @usr = (); close FH; if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; unless (/^$a[0]~/) { print FH "$_\n" } } close FH; delete $usr{$a[0]}; } }else{ warn "\aUnable to open pftps.usr\n" . "Cannot remove user.\n$!"; } &act_update; goto act_cmd_end; } elsif ($x eq 'SaveUser') { #save $tl1->Busy(-recurse => 1,); $tl1->update; my $user = $e1_tl1->get(); my $pass = $e2_tl1->get(); $tl1->Unbusy; $tl1->update; unless ($user) {print "\a"; goto act_cmd_end;} unless ($pass) {print "\a"; goto act_cmd_end;} #disallow duplicate usernames foreach (keys %usr) { if ($user eq $_) { warn "\aUser already exists.\n"; goto act_cmd_end; } } if (open (FH, ">> pftps.usr")) { flock(FH, LOCK_EX); print FH "$user~::~$pass~::~N~::~Y~::~N~::~N~::~N~::~". "N~::~N~::~\n"; close FH; }else{ warn "\aUnable to open pftps.usr\n" . "Cannot create new user.\n$!"; } $tl1->withdraw; &act_update; goto act_cmd_end; } my @a = $h1_act->selectionGet; #checkbuttons unless ($a[0]) {goto act_cmd_end;} my @usr; if (open (FH, "< pftps.usr")) { flock(FH, LOCK_SH); @usr = (); close FH; } if ($x eq 'Disabled') { print "in disabled\n"; my $z; my $user = $h1_act->itemCget($a[0], 0, -text); if ($act_c1) {$z = 'Y';} else {$z = 'N';} if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; if (/$user.*~$/) { #HomeDir not configured warn "HomeDir is not configured.\a\n"; $z = 'Y'; } s/($user~::~\w+~::~)\w+(.+)/$1$z$2/x; print FH "$_\n"; }close FH; } } elsif ($x eq 'Download') { my $z; my $user = $h1_act->itemCget($a[0], 0, -text); if ($act_c2) {$z = 'Y';} else {$z = 'N';} if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; s/($user~::~\w+~::~\w+~::~)\w+(.+)/$1$z$2/x; print FH "$_\n"; }close FH; } } elsif ($x eq 'Upload') { my $z; my $user = $h1_act->itemCget($a[0], 0, -text); if ($act_c3) {$z = 'Y';} else {$z = 'N';} if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; s/($user~::~\w+~::~\w+~::~\w+~::~)\w+(.+)/$1$z$2/x; print FH "$_\n"; }close FH; } } elsif ($x eq 'Delete') { my $z; my $user = $h1_act->itemCget($a[0], 0, -text); if ($act_c4) {$z = 'Y';} else {$z = 'N';} if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; s/($user~::~\w+~::~\w+~::~\w+~::~\w+~::~) \w+(.+)/$1$z$2/x; print FH "$_\n"; }close FH; } } elsif ($x eq 'Rename') { my $z; my $user = $h1_act->itemCget($a[0], 0, -text); if ($act_c5) {$z = 'Y';} else {$z = 'N';} if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; s/($user~::~\w+~::~\w+~::~\w+~::~\w+~::~\w+~::~) \w+(.+)/$1$z$2/x; print FH "$_\n"; }close FH; } } elsif ($x eq 'Directory') { my $z; my $user = $h1_act->itemCget($a[0], 0, -text); if ($act_c6) {$z = 'Y';} else {$z = 'N';} if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; s/($user~::~\w+~::~\w+~::~\w+~::~\w+~::~\w+~::~ \w+~::~)\w+(.+)/$1$z$2/x; print FH "$_\n"; }close FH; } } elsif ($x eq 'Concurrent') { my $z; my $user = $h1_act->itemCget($a[0], 0, -text); if ($act_c7) {$z = 'Y';} else {$z = 'N';} if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; s/($user~::~\w+~::~\w+~::~\w+~::~\w+~::~\w+~::~ \w+~::~\w+~::~)\w+(.+)/$1$z$2/x; print FH "$_\n"; }close FH; } } elsif ($x eq 'HomeDir') { #HomeDir my $dir; eval { $dir = $mw->chooseDirectory(-title => 'Choose a ' . 'download directory.', -initialdir => '.', -mustexist => 1,)}; if($@) {die "Please upgrade Perl/Tk.\a\n$!";} if($dir) { $e1_act->configure(-state => 'normal'); $e1_act->delete(0, 'end'); $e1_act->insert('end', "$dir/"); $e1_act->configure(-state => 'disabled'); $mw->update; $dir = $e1_act->get; my $user = $h1_act->itemCget($a[0], 0, -text); if (open (FH, "> pftps.usr")) { flock(FH, LOCK_EX); foreach (@usr) { chomp; s/($user~::~\w+~::~\w+~::~\w+~::~\w+~::~\w+~::~ \w+~::~\w+~::~\w+~::~)(.*)/$1$dir/x; print FH "$_\n"; }close FH; } } } &act_update(); $h1_act->selectionSet("$a[0]"); &act_browse(); act_cmd_end: $mw->Unbusy; $mw->update; } sub act_update #---------------------------------------------------- { $h1_act->delete('all'); $c1_act->deselect; $c2_act->deselect; $c3_act->deselect; $c4_act->deselect; $c5_act->deselect; $c6_act->deselect; $c7_act->deselect; $e1_act->configure(-state => 'normal'); $e1_act->delete(0, 'end'); $e1_act->configure(-state => 'disabled'); if (open (FH, "< pftps.usr")) { flock(FH, LOCK_SH); my @usr = (); close FH; @usr = sort{$a cmp $b} @usr; foreach (@usr) { chomp; my @a = split ('~::~', $_); my $user = "$a[0]"; $h1_act->add($user); $h1_act->itemCreate($user, 0, -itemtype => 'text', -text => "$user"); $mw->update; } foreach (@usr) { chomp; my @a = split ('~::~', $_); my $k = "$a[0]"; $usr{$k}[0] = "$a[1]"; $usr{$k}[1] = "$a[2]"; $usr{$k}[2] = "$a[3]"; $usr{$k}[3] = "$a[4]"; $usr{$k}[4] = "$a[5]"; $usr{$k}[5] = "$a[6]"; $usr{$k}[6] = "$a[7]"; $usr{$k}[7] = "$a[8]"; if ($a[9]) {$usr{$k}[8] = "$a[9]"} } } } sub act_browse #---------------------------------------------------- { $mw->Busy(-recurse => 1); my @a = $h1_act->selectionGet; unless ($a[0]) {goto act_browse_end;} if ($usr{$a[0]}[1] eq 'Y') {$c1_act->select;} else {$c1_act->deselect;} if ($usr{$a[0]}[2] eq 'Y') {$c2_act->select;} else {$c2_act->deselect;} if ($usr{$a[0]}[3] eq 'Y') {$c3_act->select;} else {$c3_act->deselect;} if ($usr{$a[0]}[4] eq 'Y') {$c4_act->select;} else {$c4_act->deselect;} if ($usr{$a[0]}[5] eq 'Y') {$c5_act->select;} else {$c5_act->deselect;} if ($usr{$a[0]}[6] eq 'Y') {$c6_act->select;} else {$c6_act->deselect;} if ($usr{$a[0]}[7] eq 'Y') {$c7_act->select;} else {$c7_act->deselect;} $e1_act->configure(-state => 'normal'); $e1_act->delete(0, 'end'); if ($usr{$a[0]}[8]) { $e1_act->insert('end', "$usr{$a[0]}[8]"); }else{ $c1_act->select; } $e1_act->configure(-state => 'disabled'); act_browse_end: $mw->Unbusy; $mw->update; } sub sec_cmd #------------------------------------------------------- { my $x = $_[0]; undef @_; $mw->Busy(-recurse => '1'); if ($x eq 'SaveIP') { $tl2->Busy(-recurse => 1,); $tl2->update; my $ip = $e1_tl2->get(); $tl2->Unbusy; $tl2->update; unless ($ip) { print "\a"; goto sec_cmd_end; } if (/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) { unless ($1 > 0 && $1 < 256 && $2 >= 0 && $2 < 256 && $3 >= 0 && $3 < 256 && $4 >= 0 && $4 < 256) { print "\a"; goto sec_cmd_end; } }else{ print "\a"; goto sec_cmd_end; } open (FH, ">>pftps.sec") or warn "Unable to append pftps.sec\a\n$!" and goto sec_cmd_end; flock(FH, LOCK_EX); print FH "$ip\n"; close FH; $tl2->withdraw; } elsif ($x eq 'Add') { $e1_tl2->delete(0, 'end'); $tl2->deiconify; $tl2->raise; $e1_tl2->focus; goto sec_cmd_end; } elsif ($x eq 'Remove') { my @a = $h1_sec->selectionGet; unless ($a[0]) { goto sec_cmd_end; } my $remip = $h1_sec->itemCget($a[0], 0, -text); open (FH, '); close FH; open (FH, '>pftps.sec') or warn "Can't create pftps.sec\a\n$!"; flock(FH, LOCK_EX); foreach (@sec) { chomp; unless ($_ eq $remip) { print FH "$_\n"; } } } elsif ($x eq 'Disable' || $x eq 'Deny' || $x eq 'Allow') { open (FH, '); close FH; open (FH, '>pftps.cfg') or warn "Cannot create pftps.cfg\a\n$!" and goto sec_cmd_end; flock(FH, LOCK_EX); foreach(@cfg) { chomp; unless (/^~::~.*/) { print FH "$_\n" } } if ($sec_c1) { print FH "~::~Disabled"; } else { print FH "~::~Enabled"; } if ($sec_c2) { print FH "~::~Allow" } else { print FH "~::~Deny" } print FH "\n"; close FH; } &sec_update(); sec_cmd_end: $mw->update; $mw->Unbusy; } sub sec_update #---------------------------------------------------- { $h1_sec->delete('all'); $mw->update; open (FH, '); close FH; open (FH, '); close FH; foreach (@cfg) { if (/~::~(.*)~::~(.*)/) { if ($1 eq 'Disabled') { $c1_sec->select; } else { $c1_sec->deselect; } if ($2 eq 'Allow') { $c2_sec->select; $c3_sec->deselect; } if ($2 eq 'Deny') { $c3_sec->select; $c2_sec->deselect; } last; } } my $c = 0; foreach (@sec) { chomp; $c++; $h1_sec->add($c); $h1_sec->itemCreate($c, 0, -itemtype => 'text', -text => "$_"); } $mw->Unbusy; $mw->update; } sub cfg_cmd #------------------------------------------------------- { my $x = $_[0]; undef @_; $mw->Busy(-recurse => '1'); if ($x eq 'Save') { open (FH, "); close FH; my ($state, $mode,); foreach (@cfg) { if (/^~::~(.*)~::~(.*)/) { $state = $1; $mode = $2; } } my $ip = $e1_cfg->get(); my $po = $e2_cfg->get(); my $mt = $e3_cfg->get(); my $mi = $e4_cfg->get(); my $to = $e5_cfg->get(); if ($ip && $ip =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\. (\d{1,3})$/x) { unless ($1 > 0 && $1 < 224 && $2 >= 0 && $2 < 256 && $3 >= 0 && $3 < 256 && $4 >= 0 && $4 < 256) { warn "Invalid IP.\a\n"; $ip = '127.0.0.1'; } }else{ warn "Invalid IP.\a\n"; $ip = '127.0.0.1'; } unless ($po && $po =~ /^[0-65530]{1,5}$/) { warn "Invalid PORT.\a\n"; $po = 21; }unless ($mt && $mt =~ /^[0-999]{1,3}$/) { warn "Invalid MAXTOT.\a\n"; $mt = 10; }unless ($mi && $mi =~ /^[0-999]{1,3}$/) { warn "Invalid MAXIP.\a\n"; $mi = 1; }unless ($to && $to =~ /^[0-999]{1,3}$/) { warn "Invalid TIMEOUT.\a\n"; $to = 5; } if (open (FH, "> pftps.cfg")) { flock(FH, LOCK_EX); print FH "IP~::~$ip\n"; print FH "PORT~::~$po\n"; print FH "MAXTOT~::~$mt\n"; print FH "MAXIP~::~$mi\n"; print FH "TIMEOUT~::~$to\n"; print FH "~::~$state~::~$mode\n"; close FH; }else{ warn "Cannot create pftps.cfg\n" . "Unable to update configuration.\a\n$!"; }&cfg_update(); }&cfg_update(); } sub cfg_update #---------------------------------------------------- { $e1_cfg->delete(0, 'end'); $e2_cfg->delete(0, 'end'); $e3_cfg->delete(0, 'end'); $e4_cfg->delete(0, 'end'); $e5_cfg->delete(0, 'end'); if (open (FH, "< pftps.cfg")) { flock(FH, LOCK_SH); my @cfg = (); close FH; foreach (@cfg) { chomp; if (/^IP~::~(.+)/) { $e1_cfg->insert('end', "$1"); }elsif (/PORT~::~(\d+)/) { $e2_cfg->insert('end', "$1"); }elsif (/MAXTOT~::~(\d+)/) { $e3_cfg->insert('end', "$1"); }elsif (/MAXIP~::~(\d+)/) { $e4_cfg->insert('end', "$1"); }elsif (/TIMEOUT~::~(\d+)/) { $e5_cfg->insert('end', "$1"); } } }else{ warn "Cannot open pftps.log\a\n$!"; } $mw->Unbusy; $mw->update; } sub hlp_cmd #------------------------------------------------------- { my $x = $_[0]; undef @_; $mw->Busy(-recurse => '1'); $t1_hlp->delete('1.0', 'end'); $mw->update; my $text; if ($x eq 'Server') { $text = "Start\nActivates the FTP server.\n\n" . "Stop\nDeactivates the FTP server.\n\n" . "Exit\nDeactivates the FTP server and " . "quits the application.\n\n"; } elsif ($x eq 'Log') { $text = "This is a log, you can save or clear the log.\n". 'Pause will cause the log to stop updating, '. "untill the Resume button is pressed.\n"; } elsif ($x eq 'Online') { $text = "Displays logged in users.\n\n". "KickUser - Disconnects selected user\n". "BanUser - Disconnects selected user ". "and disables their account.\n". "BanIP - Disconnects selected user ". "and adds thier IP address to security.\n\n". 'Pause - Online Users will stop updating, '. "untill the Resume button is pressed.\n"; } elsif ($x eq 'Accounts') { $text = "Add - Creates a new user account.\n". "Remove - Deletes the selected user account.\n\n". 'Home Directory is where you enter the users '. "root directory.\n"; } elsif ($x eq 'Security') { $text = "Prevent IP addresses from connecting\n\n". "Add - Add an IP address.\n". "Remove - Remove the selected IP address.\n\n". "There are three filter modes: ". "Disabled, Deny, and Allow.\n"; } elsif ($x eq 'Configuration') { $text = "Configure the FTP server options\n\n". "IP Address - IP address of the server.\n". "Port - Sever port.\n". "Max total - Number of connections allowed\n". "Max IP - Number of connections per ip\n". "Timeout - Server timeout value.\n"; } elsif ($x eq 'About') { $text = '-=PFTPs=- Perl FTP Server '. "[Version: 1_0 (beta)]\n\n". "Help make this Perl program better.\n". 'Please contact QOS@cpan.org if you have '. 'any bugs, tips, suggestions, etc..'; } $text = "\n" . $text; $t1_hlp->insert('end', "$text"); $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); }); } } #POD Section# =head1 NAME -=PFTPs=- Perl FTP Server =head1 DESCRIPTION A basic FTP server. =head1 README -=PFTPs=- Perl FTP Server (PFTPs_v1_1.plx) A FTP server with a pTk GUI front-end. EXPERIMENTAL release, future versions will be more portable, and shall include non-threaded versions of the server. =head1 PREREQUISITES Perl 5.8.4 or later (with thread support). Tk 804.27 or later (for Tk::chooseDirectory). Path::Class =head1 COREQUISITES Win32::Process (required for MSWin32 only). Win32::Console (optional) Tk::Carp (optional) =head1 History v1_0 - Initial EXPERIMENTAL release (Sept. 2004). v1_1 - Combined GUI and server scripts into 1 script. Fixed a scrollbar bug in View log. =head1 ToDo Integrate server type options(threaded/multiplexed) to configuration. Finish PFTPs_M_v1_0 and integrate it into the gui configuration screen. Add support for IP ranges in the security screen. Create module versions of the servers. Implement the SIZE command (draft-ietf-ftpext-mlst-16.txt). Improve the implementation of the ABOR and TYPE commands. Lots of testing... =head1 Copyright -=PFTPs=- Perl FTP Server 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 - MSWin32, nix/nux/mac? =pod SCRIPT CATEGORIES Networking =cut __DATA__ #!Perl require 5.008_004; $^W = 1; use strict; use threads; use IO::Socket; use Path::Class; use threads::shared; use Fcntl qw(:DEFAULT :flock); my $w32c; if ($^O eq 'MSWin32') { eval { require Win32::Console; Win32::Console::Free() }; if ($@) { warn "Win32::Console is not installed.\n$@"; } else { $w32c++; } }else { $w32c++; } if ($w32c) { eval { use Tk::Carp qw/warningsToDialog fatalsToDialog immediateWarnings/ }; if ($@) { warn "Tk::Carp is not installed.\n$@"; } }undef $w32c; #Declarations# my $VERSION = 1.0; my (%SESSDATA, %usr,); #A blank copy for each thread. my (%cfg, $socket, $server, $counter,); #A copy for each thread. share(my @ips); share(my @con); #Shared by all threads. #Main# &init(); $server = IO::Socket::INET->new( LocalHost => "$cfg{IP}", LocalPort => "$cfg{PORT}", Timeout => "$cfg{TIMEOUT}", Listen => 16, Reuse => 1, Proto => 'tcp',); if ($server) { my $now = localtime; my $msg = "\nServer started.\t\t\t[$now]\t[PID: $$]\n" . "Listening for connections...\t[IP: " . "$cfg{IP}:$cfg{PORT}]\n\n"; &print_log($msg); print "$msg\n" }else{ my $msg = "Cannot create a listening socket\n$@\n$!"; &print_log($msg); warn "$msg"; exit; } #Mainloop# while(1) { $socket = $server->accept; if ($socket) { my $ip = $socket->peerhost; #BANIP open (FH, "); close FH; my ($state, $mode,); foreach (@cfg) { if (/^~::~(.*)~::~(.*)/) { $state = $1; $mode = $2; } } unless ($state eq 'Enabled') { goto BANIP_end; } open (FH, '< pftps.sec') or warn 'Unable to open pftps.sec, BANIP '. "disabled.\a\n$!" and goto BANIP_end; flock(FH, LOCK_SH) or warn "Cannot lock pftps.sec\a\n$!"; my @sec = (); close FH; if ($mode eq 'Deny') { foreach (@sec) { chomp; if ($_ eq $ip) { print $socket '421 Your ip address is currently banned.'. "\015\012"; goto disconnect; } } }else{ my $allowed; foreach (@sec) { chomp; if ($_ eq $ip) { $allowed = 1; } } unless ($allowed) { print $socket '421 Your ip address is currently banned.'. "\015\012"; goto disconnect; } BANIP_end: } #MAXIP my $maxip = 0; foreach(@ips) { unless (defined $_) { shift @ips; } } foreach(@ips) { if ($_ && $_ eq $ip) { $maxip++; } } unless ($maxip < $cfg{'MAXIP'}) { print $socket '421 The connection limit for your ip has been ' . "reached.\015\012"; goto disconnect; } #MAXTOT my $total_connections = scalar @ips; if ($total_connections < $cfg{'MAXTOT'}) { #Begin connection $counter++; threads->new(\&handle_connection, $socket, $counter)->detach; }else{ #Disconnect print $socket "421 The server has reached it's connection " . "limit. Please try later.\015\012"; disconnect: $socket->close; } } } #Subroutines# sub handle_connection #------------------------------------------------- { my $session = $_[0]; my $output = $_[0]; my $uid = $_[1]; my $exit = 0; #Login print $session "220 Welcome.\015\012"; my $userip = $session->peerhost(); &print_log(" Connection established:\t\t[ $userip ]\n"); my $user = &login($session); my $logintime = localtime; #Update online (gui) open (FH, ">>pftps.log") or die "\aUnable to open pftps.log\n"; flock(FH, LOCK_EX) or die "\aCannot lock pftps.log: $!"; print FH "ONLINEUSER:~::~$user~::~$uid~::~$userip~::~$logintime\n"; close FH; #Update ips & con push (@ips, $userip); push (@con, $user) unless $user =~ /^anonymous$/; #Begin session $SESSDATA{$session}[0] = $user; $SESSDATA{$session}[1] = $uid; $SESSDATA{$session}[4] = $usr{$user}[8]; my ($user_input, $bytes, $rnfr,); while ($user_input = (<$session>)) { if ($user_input) {$bytes = 1;} else {$bytes = 0;} #KickUser (gui) if (-e 'pftps.tmp') { my @tmp; open(FH, "); close FH; unlink 'pftps.tmp' or warn "Unable to unlink pftps.tmp\a\n$!"; foreach (@tmp) { chomp; /KICKUSER:~::~(.+)~::~(.+)/; if ($1 && $1 eq $SESSDATA{$session}[0] && $2 eq $SESSDATA{$session}[1]) { goto quit; } } } #Parse commands if ($bytes > 0) { chomp($user_input); $user_input =~ s/\r$//; my $msg = "$user_input\n"; &print_log(">>> $msg"); if ($user_input =~ /^noop$/i) { #noop my $msg = '200 OK'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } elsif ($user_input =~ /^stat\b\s*(.*)/i) { #stat if ($1) { my $msg = '504 Command not implemented for that parameter.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $msg = "211 OK"; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } } elsif ($user_input =~ /^syst$/i) { #syst my $msg = '215 UNIX emulated by Just another Perl hacker.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } elsif ($user_input =~ /^mode\b\s*(.+)/i) { #mode if ($1) { if ($1 =~ /(^S$)/i) { my $msg = "200 Type set to $1"; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $msg = '504 Command not implemented for that parameter.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } } elsif ($user_input =~ /^stru\b\s*(.+)/i) { #stru if ($1) { if ($1 =~ /(^F$)/i) { my $msg = "200 Type set to $1"; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $msg = '504 Command not implemented for that parameter.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } } elsif ($user_input =~ /^type\b\s*(.+)/i) { #type #More information is needed to properly support this. unless ($1) { my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto type_end; } if ($1 =~ /(^A\b\s{0,1}N{0,1}$)/i) {#\015\012 EOL's #type A or type A N my $msg = "200 Type set to $1"; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } elsif ($1 =~ /(^I$)/i) {#8 bit boundry #type I my $msg = "200 Type set to $1"; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } elsif ($1 =~ /(^L\s8$)/i) {#8 bit boundry #type L 8 my $msg = "200 Type set to $1"; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $msg = '504 Command not implemented for that parameter.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } type_end: } elsif ($user_input =~ /^pasv$/i) { #pasv &close_dataconn($session); &open_dataconn ('pasv', $session,); } elsif ($user_input =~ /^port\b\s*(.*)/i) { #port #Some code borrowed from Net::FTPServer to handle this. unless ($1 =~ /^\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s* (\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3})/x) { my $msg = '501 Syntax error in PORT command.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto port_end; } my $h1 = int ($1); my $h2 = int ($2); my $h3 = int ($3); my $h4 = int ($4); my $p1 = int ($5); my $p2 = int ($6); unless ($h1 > 0 && $h1 < 224 && $h2 >= 0 && $h2 < 256 && $h3 >= 0 && $h3 < 256 && $h4 >= 0 && $h4 < 256) { my $msg = "501 Invalid host address."; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto port_end; } my $hostaddr = "$h1.$h2.$h3.$h4"; my $hostport = $p1 * 256 + $p2; unless ($hostport > 0 && $hostport < 65536) { my $msg = '501 Invalid port number.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto port_end; } if ($hostport < 1024) { my $msg = '504 Cannot connect to ports < 1024.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto port_end; } &close_dataconn($session); &open_dataconn ('port', $session, $hostaddr, $hostport); } elsif ($user_input =~ /^abor$/i) { #abor if ($SESSDATA{$session}[2] || $SESSDATA{$session}[3]) { #&close_dataconn(); #my $msg = '426 Connection closed; transfer aborted.'; #print $output "$msg\015\012"; #&print_log("$msg\n"); } my $msg = '226 ABOR okay.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } elsif ($user_input =~ /^list\b\s*(.*)/i) { #list my $msg = '150 Opening ASCII mode data ' . "connection for directory list."; print $output "$msg\015\012"; &print_log("<<< $msg\n"); my ($dir, $dirhandle,); if ($1) { $dir = dir("$SESSDATA{$session}[4]"."$1") }else{ if ($SESSDATA{$session}[5]) { $dir = dir("$SESSDATA{$session}[5]"); }else{ $dir = dir("$SESSDATA{$session}[4]"); } } $dirhandle = $dir->open; unless ($dirhandle) { my $msg = '550 Requested action not taken. ' . 'Path does not exist.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto list_end; } while (my $file = $dirhandle->read) { $file = $dir ->file($file); my $st = $file ->lstat(); unless (@$st[1]) {@$st[1] = 10;} unless (@$st[5]) {@$st[5] = 50;} unless (@$st[4]) {@$st[4] = 'ftpadmin'}; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(@$st[9]); if ($mon == 0) {$mon = 'Jan';} elsif ($mon == 1) {$mon = 'Feb';} elsif ($mon == 2) {$mon = 'Mar';} elsif ($mon == 3) {$mon = 'Apr';} elsif ($mon == 4) {$mon = 'May';} elsif ($mon == 5) {$mon = 'Jun';} elsif ($mon == 6) {$mon = 'Jul';} elsif ($mon == 7) {$mon = 'Aug';} elsif ($mon == 8) {$mon = 'Sep';} elsif ($mon == 9) {$mon = 'Oct';} elsif ($mon == 10) {$mon = 'Nov';} elsif ($mon == 11) {$mon = 'Dec';} $year += 1900; $file = $file->basename; my $date = "$mon $mday $year"; my $size = sprintf '%12s', "@$st[7]"; if (@$st[2] =~ /^1/) {@$st[2] = 'drwxrwsr-x';} else {@$st[2] = '-rwxrwsr-x';} my $msg = "@$st[2] @$st[1] @$st[4] @$st[5] $size " . "$date $file\015\012"; &print_dataconn($session, $msg); } $msg = '226 Transfer complete.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); list_end: &close_dataconn($session); } elsif ($user_input =~ /^nlst\b\s*(.*)/i) { #nlst my $msg = '150 Opening ASCII mode data '. 'connection for directory list.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); my ($dir, $dirhandle,); if ($1) { $dir = dir("$SESSDATA{$session}[4]"."$1") }else{ if ($SESSDATA{$session}[5]) { $dir = dir("$SESSDATA{$session}[5]"); }else{ $dir = dir("$SESSDATA{$session}[4]"); } } $dirhandle = $dir->open; unless ($dirhandle) { my $msg = '550 Requested action not taken. ' . 'Path does not exist.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto nlst_end; } while (my $file = $dirhandle->read) { $file = $dir->file($file); $file = $file->basename; my $msg = "$file\015\012"; &print_dataconn($session, $msg); } $msg = '226 Transfer complete'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); nlst_end: &close_dataconn($session); } elsif ($user_input =~ /^cwd\b\s*(.*)/i) { #cwd test if ($1) { my $s1 = $1; #handle '..', '.', and '/' if ($s1 eq '..') { goto cdup; goto cwd_end; } elsif ($s1 eq '.' || $s1 eq '/./' || $s1 =~ /^[\/\\]+\.\./) { my $msg = '550 Requested action not taken. ' . 'Access denied.'; &close_dataconn($session); print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto cwd_end; } elsif ($s1 =~ /^[\/\\]+$/) { $SESSDATA{$session}[5] = $SESSDATA{$session}[4]; my $msg = '257 "/" is current directory.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto cwd_end; } if ($s1 =~ /^[\/|\\]+.*[\/|\\]*.*/) { #absolute path my $path = "$SESSDATA{$session}[4]"."$s1"; my $x = &check_path($session, "$path"); if ($x eq 'ok') { $SESSDATA{$session}[5] = "$SESSDATA{$session}[4]"."$s1"; }else{ goto cwd_end; } }else{ #relative path unless ($SESSDATA{$session}[5]) { my $path = "$SESSDATA{$session}[4]".'/'."$s1"; my $x = &check_path($session, "$path"); if ($x eq 'ok') { $SESSDATA{$session}[5] = "$SESSDATA{$session}[4]" . '/'."$s1"; goto cwd_ok; } goto cwd_end; } if ($SESSDATA{$session}[5] =~ /^.*[\/|\\]{2}(.*)/) { if ($1) { my $path = "$SESSDATA{$session}[4]".'/'."$1".'/'."$s1"; my $x = &check_path($session, "$path"); if ($x eq 'ok') { $SESSDATA{$session}[5] = "$SESSDATA{$session}[4]".'/'."$1".'/'."$s1"; }else{ goto cwd_end; } }else{ my $path = "$SESSDATA{$session}[4]".'/'."$s1"; my $x = &check_path($session, "$path"); if ($x eq 'ok') { $SESSDATA{$session}[5] = "$SESSDATA{$session}[4]" . '/'."$s1"; }else{ goto cwd_end; } } }else{ my $path = "$SESSDATA{$session}[4]".'/'."$s1"; my $x = &check_path($session, "$path"); if ($x eq 'ok') { $SESSDATA{$session}[5] = "$SESSDATA{$session}[4]" . '/'."$s1"; }else{ goto cwd_end; } } } cwd_ok: my $msg = '257 "' . "$s1" . '" is current directory.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $msg = '501 Syntax error: Invalid number of ' . 'parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } cwd_end: } elsif ($user_input =~ /^pwd$/i) { #pwd pwd: if ($SESSDATA{$session}[5]) { if ($SESSDATA{$session}[5] =~ /[\/|\\]([\/|\\].*$)/ || $SESSDATA{$session}[5] =~ /[\/|\\]*([\/|\\]\w*$)/) { my $msg = '257 "' . "$1" . '" is current directory.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $msg = '257 "/" is current directory.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '257 "/" is current directory.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } } elsif ($user_input =~ /^cdup$/i) { #cdup cdup: if ($SESSDATA{$session}[5]) { $SESSDATA{$session}[5] =~ /^(.*)\//; if ($1) { if ($SESSDATA{$session}[4] eq $SESSDATA{$session}[5]) { my $msg = '550 Requested action not ' . 'taken. Access denied.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ $SESSDATA{$session}[5] = $1; $SESSDATA{$session}[5] =~ /[\/|\\]([\/|\\].*$)/; my $msg; if ($SESSDATA{$session}[4] eq $1) { $msg = '200 "'."/".'" is current directory.'; }else{ $msg = '200 "'."$1".'" is current directory.'; } print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '200 "/"is current directory.'; print $output "$msg\015\012"; print_log("<<< $msg\n"); } }else{ my $msg = '550 Requested action not taken. Access denied.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } } elsif ($user_input =~ /^retr\b\s*(.*)/i){ #retr test my $perms = &check_perms($session, 2); unless ($perms eq 'ok') { goto retr_end; } if ($1) { my $s1 = $1; my $s2; if ($s1 =~ /(.*[\\|\/].*)*([\\|\/].*)/) { $s1 = $2; } else { $s1 = '/'.$s1; } if ($1) { $s2 = $1; } else { $s2 = '/'; } my $file; if ($SESSDATA{$session}[5]) { $file = "$SESSDATA{$session}[5]"."$s1"; unless (-e "$file") { $file = "$SESSDATA{$session}[4]"."$s2$s1"; } }else{ $file = "$SESSDATA{$session}[4]"."$s2$s1"; } if (-e "$file" && -f "$file") { if (open (RETR, "<$file")) { if (-B "$file") { #binary my $msg = '150 Opening BINARY mode data connection ' . 'for file transfer.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); my ($buf, $len, $ofs, $written); my $blksize = (stat RETR)[11] || 16384; while ($len = sysread RETR, $buf, $blksize) { if (!defined $len) { next if $! =~ /^Interrupted/; die "System read error: $!\n"; } $ofs = 0; my $client; if ($SESSDATA{$session}[2]) { $client = $SESSDATA{$session}[2]; } elsif ($SESSDATA{$session}[3]) { $client = $SESSDATA{$session}[3]; }else{ my $msg = '451 Requested action aborted. BINARY ' . 'transfer requires data channel.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto retr_end; } while ($len) { defined($written = syswrite $client, $buf, $len, $ofs) or goto retr_451; $len -= $written; $ofs += $written; }; } close RETR; }else{ #text my $msg = '150 Opening ASCII mode data connection ' . 'for file transfer.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); undef $msg; while () {#ASCII Type chomp; s/\r$//; $msg .= "$_\015\012"; } close RETR; &print_dataconn($session, $msg,); } $msg = '226 Closing data connection. ' . 'Requested file action successful'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ retr_451: my $msg = '451 Requested action aborted. Local error ' . 'in processing.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); &close_dataconn($session); } }else{ my $msg = '550 File not found.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } &close_dataconn($session); retr_end: } elsif ($user_input =~ /^stor\b\s*(.*)/i) { #stor test my $perms = &check_perms($session, 3); unless ($perms eq 'ok') { goto stor_end; } if ($1) { my $s1 = $1; my $file; if ($s1 =~ /.*[\/|\\]+.*$/) { #absolute path $file = "$SESSDATA{$session}[4]"."$s1"; }else{ #relative path if ($SESSDATA{$session}[5]) { $file = "$SESSDATA{$session}[5]". '/' . "$s1"; }else{ $file = "$SESSDATA{$session}[4]"."$s1"; } } if (-e $file) { my $msg = '451 Requested action aborted. ' . 'File already exists.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto stor_end; } if (open (STOR, ">$file")) { my $msg = '150 Opening BINARY mode data connection ' . 'for file transfer.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); my $blksize = 16384; my ($buf, $len, $ofs, $written, $client); if ($SESSDATA{$session}[2]) { $client = $SESSDATA{$session}[2]; } elsif ($SESSDATA{$session}[3]) { $client = $SESSDATA{$session}[3]; }else{ my $msg = '451 Requested action aborted. ' . 'STOR requires a data channel.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto stor_end; } while ($len = sysread $client, $buf, $blksize) { if (!defined $len) { next if $! =~ /^Interrupted/; goto stor_451; } $ofs = 0; while ($len) { defined($written = syswrite STOR, $buf, $len, $ofs) or die "Syswrite error: $!\n"; $len -= $written; $ofs += $written; }; } close STOR; $msg = '226 Closing data connection. '. 'Requested file action successful.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); &close_dataconn($session); }else{ stor_451: my $msg = '451 Requested action aborted. Local error '. 'in processing.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } stor_end: } elsif ($user_input =~ /^dele\b\s*(.*)/i) { #dele my $perms = &check_perms($session, 4); unless ($perms eq 'ok') { goto dele_end; } if ($1) { my $s1 = $1; if ($s1 =~ /.*([\\|\/].*)/) { $s1 = $1; } else { $s1 = '/'.$s1; }; my $file; if ($SESSDATA{$session}[5]) { $file = "$SESSDATA{$session}[5]"."$s1"; }else{ $file = "$SESSDATA{$session}[4]"."$s1"; } if (-e "$file" && -f "$file") { if (unlink $file) { my $msg = '250 Requested file action completed.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $err = "$!"; my $msg = "450 Requested file action not taken. $err."; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '550 Requested action not taken. Not a file.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } dele_end: } elsif ($user_input =~ /^rmd\b\s*(.*)/i) { #rmd my $perms = &check_perms($session, 4); unless ($perms eq 'ok') { goto rmd_end; } if ($1) { my $s1 = $1; if ($s1 =~ /.*([\\|\/].*)/) {$s1 = $1;} else {$s1 = '/'.$s1;}; my $dir; if ($SESSDATA{$session}[5]) { $dir = "$SESSDATA{$session}[5]"."$s1"; }else{ $dir = "$SESSDATA{$session}[4]"."$s1"; } if (-e "$dir" && -d "$dir") { if (rmdir $dir) { my $msg = '250 Requested file action completed.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $err = "$!"; my $msg = "450 Requested file action not taken. $err."; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '550 Requested action not taken. '. 'Not a Directory.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } rmd_end: } elsif ($user_input =~ /^mkd\b\s*(.*)/i) { #mkd my $perms = &check_perms($session, 6); unless ($perms eq 'ok') { goto mkd_end; } if ($1) { my $s1 = $1; if ($s1 =~ /.*([\\|\/].*)/) {$s1 = $1;} else {$s1 = '/'.$s1;}; my $dir; if ($SESSDATA{$session}[5]) { $dir = "$SESSDATA{$session}[5]"."$s1"; }else{ $dir = "$SESSDATA{$session}[4]"."$s1"; } if (mkdir $dir) { my $msg = '250 Requested file action completed.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $err = "$!"; my $msg = "450 Requested file action not taken. $err."; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } mkd_end: } elsif ($user_input =~ /^rnfr\b\s*(.*)/i) { #rnfr my $perms = &check_perms($session, 5); unless ($perms eq 'ok') { goto rnfr_end; } if ($1) { if ($SESSDATA{$session}[5]) { $rnfr = "$SESSDATA{$session}[5]".'/'.$1; }else{ $rnfr = "$SESSDATA{$session}[4]".'/'.$1; } unless (-e "$rnfr") { my $msg = '450 Requested file action not taken. ' . 'File not found.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); undef $rnfr; goto rnfr_end; } my $msg = '350 Requested file action pending further ' . 'information..'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } rnfr_end: } elsif ($user_input =~ /^rnto\b\s*(.*)/i) { #rnto unless ($rnfr) { my $msg = '503 Bad sequence of commands. RNTO must be '. 'preceded by RNFR.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); goto rnto_end; } if ($1) { my $rnto = $1; if ($1 =~ /(.*[\\|\/])(.*)/) { $rnto = $2; } $rnfr =~ /(.*[\\|\/])(.*)/; $rnto = $1.$rnto; if (rename("$rnfr", "$rnto")) { my $msg = '250 Requested file action completed.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); }else{ my $err = "$!"; my $msg = "450 Requested file action not taken. $err."; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } }else{ my $msg = '501 Syntax error: Invalid number of parameters.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } rnto_end: undef $rnfr; } elsif ($user_input =~ /^user\b\s*(.*)/i) { #user my $msg = '500 Already logged in.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } elsif ($user_input =~ /^pass\b\s*(.*)/i) { #pass my $msg = '500 Already logged in.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } elsif ($user_input =~ /^quit$/i) { #quit quit: unless ($SESSDATA{$session}[0]) { $SESSDATA{$session}[0] = 'Not logged in.'; } my $msg = '220 Goodbye, '."$SESSDATA{$session}[0]."; print $output "$msg\015\012"; &print_log("<<< $msg\n"); $session->close; $exit = 1; }else{ my $msg = '502 Command not implemented.'; print $output "$msg\015\012"; &print_log("<<< $msg\n"); } if ($exit) { goto handle_connection_end; } #disconnect }else{ $session->close; $exit = 1; } if ($exit) { goto handle_connection_end; } } handle_connection_end: #Update Log &print_log(" Connection disconnected:\t\t[ $userip ]\n"); #Update MAXIP my $index = 0; foreach (@ips) { if ($_ && $userip && $_ eq $userip) { undef $ips["$index"]; } $index++; } #Update Concurrent $index = 0; foreach (@con) { if ($_ && $user && $_ eq $user) { undef $con["$index"]; } $index++; } #Update ONLINEUSER open (FH, "< pftps.log") or warn "Cannot open pftps.log\a\n$!"; flock(FH, LOCK_SH | LOCK_NB); my @a = (); close FH; open (FH, "> pftps.log") or warn "Cannot create pftps.log\a\n$!"; flock(FH, LOCK_EX) or warn "Cannot flock pftps.log\a\n$!"; foreach (@a) { chomp; if ($SESSDATA{$session}[0] && $SESSDATA{$session}[1]) { unless (/ONLINEUSER:~::~$SESSDATA{$session}[0]~::~ $SESSDATA{$session}[1]~::~.*/ix) { print FH "$_\n"; } } } close FH; } sub login #------------------------------------------------------------- { my $sess = $_[0]; undef @_; my ($input, $bytes, $u, $ip, $time, $msg,); open (FH, "< pftps.usr") or die "Unable to open pftps.usr\a\n$!"; flock(FH, LOCK_SH) or die "Cannot lock pftps.usr\a\n$!"; my @usr = (); close FH; foreach (@usr) { chomp; my @a = split ('~::~', $_); my $k = "$a[0]"; $usr{$k}[0] = "$a[1]"; $usr{$k}[1] = "$a[2]"; $usr{$k}[2] = "$a[3]"; $usr{$k}[3] =