← Back to branch summary

~ubuntu-branches/ubuntu/lucid/wget/lucid-security

« back to all changes in this revision

Viewing changes to tests/FTPServer.pm

  • Committer: Bazaar Package Importer
  • Author(s): Marc Deslauriers
  • Date: 2009-12-12 08:15:59 UTC
  • mfrom: (2.1.5 squeeze)
  • Revision ID: james.westby@ubuntu.com-20091212081559-mvccl4kzdqb138y3
Tags: 1.12-1.1ubuntu1
* Merge from debian testing, remaining changes:
  - Add wget-udeb to ship wget.gnu as alternative to busybox wget
    implementation.
* Keep build dependencies in main:
  - debian/control: remove info2man build-dep
  - debian/patches/00list: disable wget-infopod_generated_manpage.dpatch

Show diffs side-by-side

added added

removed removed

Lines of Context:
tests/FTPServer.pm
1
 
#!/usr/bin/perl -w
2
 
 
3
1
# Part of this code was borrowed from Richard Jones's Net::FTPServer
4
2
# http://www.annexia.org/freeware/netftpserver
5
3
 
6
4
package FTPServer;
7
5
 
8
6
use strict;
 
7
use warnings;
9
8
 
10
9
use Cwd;
11
10
use Socket;
20
19
 
21
20
# connection states
22
21
my %_connection_states = (
23
 
    'NEWCONN'  => 0x01, 
24
 
    'WAIT4PWD' => 0x02, 
 
22
    'NEWCONN'  => 0x01,
 
23
    'WAIT4PWD' => 0x02,
25
24
    'LOGGEDIN' => 0x04,
26
25
    'TWOSOCKS' => 0x08,
27
26
);
28
27
 
29
28
# subset of FTP commands supported by these server and the respective
30
29
# connection states in which they are allowed
31
 
my %_commands = ( 
 
30
my %_commands = (
32
31
    # Standard commands from RFC 959.
33
32
    'CWD'  => $_connection_states{LOGGEDIN} |
34
 
              $_connection_states{TWOSOCKS}, 
 
33
              $_connection_states{TWOSOCKS},
35
34
#   'EPRT' => $_connection_states{LOGGEDIN},
36
 
#   'EPSV' => $_connection_states{LOGGEDIN}, 
37
 
    'LIST' => $_connection_states{TWOSOCKS}, 
 
35
#   'EPSV' => $_connection_states{LOGGEDIN},
 
36
    'LIST' => $_connection_states{TWOSOCKS},
38
37
#   'LPRT' => $_connection_states{LOGGEDIN},
39
 
#   'LPSV' => $_connection_states{LOGGEDIN}, 
40
 
    'PASS' => $_connection_states{WAIT4PWD}, 
41
 
    'PASV' => $_connection_states{LOGGEDIN}, 
42
 
    'PORT' => $_connection_states{LOGGEDIN}, 
 
38
#   'LPSV' => $_connection_states{LOGGEDIN},
 
39
    'PASS' => $_connection_states{WAIT4PWD},
 
40
    'PASV' => $_connection_states{LOGGEDIN},
 
41
    'PORT' => $_connection_states{LOGGEDIN},
43
42
    'PWD'  => $_connection_states{LOGGEDIN} |
44
 
              $_connection_states{TWOSOCKS}, 
 
43
              $_connection_states{TWOSOCKS},
45
44
    'QUIT' => $_connection_states{LOGGEDIN} |
46
 
              $_connection_states{TWOSOCKS}, 
47
 
    'REST' => $_connection_states{TWOSOCKS}, 
48
 
    'RETR' => $_connection_states{TWOSOCKS}, 
 
45
              $_connection_states{TWOSOCKS},
 
46
    'REST' => $_connection_states{TWOSOCKS},
 
47
    'RETR' => $_connection_states{TWOSOCKS},
49
48
    'SYST' => $_connection_states{LOGGEDIN},
50
49
    'TYPE' => $_connection_states{LOGGEDIN} |
51
50
              $_connection_states{TWOSOCKS},
52
 
    'USER' => $_connection_states{NEWCONN}, 
 
51
    'USER' => $_connection_states{NEWCONN},
53
52
    # From ftpexts Internet Draft.
54
53
    'SIZE' => $_connection_states{LOGGEDIN} |
55
54
              $_connection_states{TWOSOCKS},
62
61
sub _CWD_command
63
62
{
64
63
    my ($conn, $cmd, $path) = @_;
 
64
    my $paths = $conn->{'paths'};
65
65
 
66
66
    local $_;
67
 
    my $newdir = $conn->{dir};
68
 
 
69
 
    # If the path starts with a "/" then it's an absolute path.
70
 
    if (substr ($path, 0, 1) eq "/") {
71
 
        $newdir = "";
72
 
        $path =~ s,^/+,,;
73
 
    }
 
67
    my $new_path = FTPPaths::path_merge($conn->{'dir'}, $path);
74
68
 
75
69
    # Split the path into its component parts and process each separately.
76
 
    my @elems = split /\//, $path;
77
 
 
78
 
    foreach (@elems) {
79
 
        if ($_ eq "" || $_ eq ".") { 
80
 
            # Ignore these.
81
 
            next;
82
 
        } elsif ($_ eq "..") {
83
 
            # Go to parent directory.
84
 
            if ($newdir eq "") {
85
 
                print {$conn->{socket}} "550 Directory not found.\r\n";
86
 
                return;
87
 
            }
88
 
            $newdir = substr ($newdir, 0, rindex ($newdir, "/"));
89
 
        } else {
90
 
            # Go into subdirectory, if it exists.
91
 
            $newdir .= ("/" . $_);
92
 
            if (! -d $conn->{rootdir} . $newdir) {
93
 
                print {$conn->{socket}} "550 Directory not found.\r\n";
94
 
                return;
95
 
            }
96
 
        }
 
70
    if (! $paths->dir_exists($new_path)) {
 
71
        print {$conn->{socket}} "550 Directory not found.\r\n";
 
72
        return;
97
73
    }
98
74
 
99
 
    $conn->{dir} = $newdir;
 
75
    $conn->{'dir'} = $new_path;
 
76
    print {$conn->{socket}} "200 directory changed to $new_path.\r\n";
100
77
}
101
78
 
102
79
sub _LIST_command
103
80
{
104
81
    my ($conn, $cmd, $path) = @_;
 
82
    my $paths = $conn->{'paths'};
105
83
 
106
84
    # This is something of a hack. Some clients expect a Unix server
107
85
    # to respond to flags on the 'ls command line'. Remove these flags
108
86
    # and ignore them. This is particularly an issue with ncftp 2.4.3.
109
87
    $path =~ s/^-[a-zA-Z0-9]+\s?//;
110
88
 
111
 
    my $dir = $conn->{dir};
 
89
    my $dir = $conn->{'dir'};
112
90
 
113
91
    print STDERR "_LIST_command - dir is: $dir\n";
114
92
 
115
 
    # Absolute path?
116
 
    if (substr ($path, 0, 1) eq "/") {
117
 
        $dir = "/";
118
 
        $path =~ s,^/+,,;
119
 
    }
120
 
    
121
93
    # Parse the first elements of the path until we find the appropriate
122
94
    # working directory.
123
 
    my @elems = split /\//, $path;
124
 
    my ($wildcard, $filename);
125
95
    local $_;
126
96
 
127
 
    for (my $i = 0; $i < @elems; ++$i) {
128
 
        $_ = $elems[$i];
129
 
        my $lastelement = $i == @elems-1;
130
 
 
131
 
        if ($_ eq "" || $_ eq ".") { next } # Ignore these.
132
 
        elsif ($_ eq "..") {
133
 
            # Go to parent directory.
134
 
            unless ($dir eq "/") {
135
 
                $dir = substr ($dir, 0, rindex ($dir, "/"));
136
 
            }
137
 
        } else {
138
 
            if (!$lastelement) { # These elements can only be directories.
139
 
                unless (-d $conn->{rootdir} . $dir . $_) {
140
 
                    print {$conn->{socket}} "550 File or directory not found.\r\n";
141
 
                    return;
142
 
                }
143
 
                $dir .= $_;
144
 
            } else { # It's the last element: check if it's a file, directory or wildcard.
145
 
                if (-f $conn->{rootdir} . $dir . $_) { 
146
 
                    # It's a file.
147
 
                    $filename = $_;
148
 
                } elsif (-d $conn->{rootdir} . $dir . $_) { 
149
 
                    # It's a directory.
150
 
                    $dir .= $_;
151
 
                } elsif (/\*/ || /\?/) {
152
 
                    # It is a wildcard.
153
 
                    $wildcard = $_;
154
 
                } else {
155
 
                    print {$conn->{socket}} "550 File or directory not found.\r\n";
156
 
                    return;
157
 
                }
158
 
            }
159
 
        }
 
97
    $dir = FTPPaths::path_merge($dir, $path);
 
98
    my $listing = $paths->get_list($dir);
 
99
    unless ($listing) {
 
100
        print {$conn->{socket}} "550 File or directory not found.\r\n";
 
101
        return;
160
102
    }
161
 
    
 
103
 
162
104
    print STDERR "_LIST_command - dir is: $dir\n" if $log;
163
 
    
 
105
 
164
106
    print {$conn->{socket}} "150 Opening data connection for file listing.\r\n";
165
107
 
166
108
    # Open a path back to the client.
167
109
    my $sock = __open_data_connection ($conn);
168
 
 
169
110
    unless ($sock) {
170
111
        print {$conn->{socket}} "425 Can't open data connection.\r\n";
171
112
        return;
172
113
    }
173
114
 
174
 
    # If the path contains a directory name, extract it so that
175
 
    # we can prefix it to every filename listed.
176
 
    my $prefix = (($filename || $wildcard) && $path =~ /(.*\/).*/) ? $1 : "";
177
 
    
178
 
    print STDERR "_LIST_command - prefix is: $prefix\n" if $log;
179
 
 
180
 
    # OK, we're either listing a full directory, listing a single
181
 
    # file or listing a wildcard.
182
 
    if ($filename) {            # Single file.
183
 
        __list_file ($sock, $prefix . $filename);
184
 
    } else {                    # Wildcard or full directory $dirh.
185
 
        unless ($wildcard) {
186
 
            # Synthesize (fake) "total" field for directory listing.
187
 
            print $sock "total 1 \r\n";
188
 
        }
189
 
 
190
 
        foreach (__get_file_list ($conn->{rootdir} . $dir, $wildcard)) {
191
 
            __list_file ($sock, $prefix . $_);
192
 
        }
 
115
    for my $item (@$listing) {
 
116
        print $sock "$item\r\n";
193
117
    }
194
 
    
 
118
 
195
119
    unless ($sock->close) {
196
120
        print {$conn->{socket}} "550 Error closing data connection: $!\r\n";
197
121
        return;
208
132
 
209
133
    print STDERR "switching to LOGGEDIN state\n" if $log;
210
134
    $conn->{state} = $_connection_states{LOGGEDIN};
211
 
    
 
135
 
212
136
    if ($conn->{username} eq "anonymous") {
213
137
        print {$conn->{socket}} "202 Anonymous user access is always granted.\r\n";
214
138
    } else {
219
143
sub _PASV_command
220
144
{
221
145
    my ($conn, $cmd, $rest) = @_;
222
 
    
 
146
 
223
147
    # Open a listening socket - but don't actually accept on it yet.
224
148
    "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
225
149
    my $sock = IO::Socket::INET->new (LocalHost => '127.0.0.1',
246
170
    my $p2 = $sockport % 256;
247
171
 
248
172
    $conn->{state} = $_connection_states{TWOSOCKS};
249
 
    
 
173
 
250
174
    # We only accept connections from localhost.
251
175
    print {$conn->{socket}} "227 Entering Passive Mode (127,0,0,1,$p1,$p2)\r\n";
252
176
}
294
218
sub _PWD_command
295
219
{
296
220
    my ($conn, $cmd, $rest) = @_;
297
 
    
 
221
 
298
222
    # See RFC 959 Appendix II and draft-ietf-ftpext-mlst-11.txt section 6.2.1.
299
223
    my $pathname = $conn->{dir};
300
224
    $pathname =~ s,/+$,, unless $pathname eq "/";
306
230
sub _REST_command
307
231
{
308
232
    my ($conn, $cmd, $restart_from) = @_;
309
 
    
 
233
 
310
234
    unless ($restart_from =~ /^([1-9][0-9]*|0)$/) {
311
235
        print {$conn->{socket}} "501 REST command needs a numeric argument.\r\n";
312
236
        return;
320
244
sub _RETR_command
321
245
{
322
246
    my ($conn, $cmd, $path) = @_;
323
 
    
324
 
    my $dir = $conn->{dir};
325
 
 
326
 
    # Absolute path?
327
 
    if (substr ($path, 0, 1) eq "/") {
328
 
        $dir = "/";
329
 
        $path =~ s,^/+,,;
330
 
        $path = "." if $path eq "";
331
 
    }
332
 
 
333
 
    # Parse the first elements of path until we find the appropriate
334
 
    # working directory.
335
 
    my @elems = split /\//, $path;
336
 
    my $filename = pop @elems;
337
 
 
338
 
    foreach (@elems) {
339
 
        if ($_ eq "" || $_ eq ".") { 
340
 
            next # Ignore these.
341
 
        } elsif ($_ eq "..") {
342
 
            # Go to parent directory.
343
 
            unless ($dir eq "/") {
344
 
                $dir = substr ($dir, 0, rindex ($dir, "/"));
345
 
            }
346
 
        } else {
347
 
            unless (-d $conn->{rootdir} . $dir . $_) {
348
 
                print {$conn->{socket}} "550 File or directory not found.\r\n";
349
 
                return;
350
 
            }
351
 
            $dir .= $_;
352
 
        }
353
 
    }
354
 
 
355
 
    unless (defined $filename && length $filename) {
356
 
        print {$conn->{socket}} "550 File or directory not found.\r\n";
357
 
            return;
358
 
    }
359
 
 
360
 
    if ($filename eq "." || $filename eq "..") {
361
 
        print {$conn->{socket}} "550 RETR command is not supported on directories.\r\n";
362
 
            return;
363
 
    }
364
 
    
365
 
    my $fullname = $conn->{rootdir} . $dir . $filename;
366
 
    unless (-f $fullname) {
367
 
        print {$conn->{socket}} "550 RETR command is only supported on plain files.\r\n";
368
 
        return;
369
 
    }
370
 
 
371
 
    # Try to open the file.
372
 
    unless (open (FILE, '<', $fullname)) {
373
 
        print {$conn->{socket}} "550 File or directory not found.\r\n";
 
247
 
 
248
    $path = FTPPaths::path_merge($conn->{dir}, $path);
 
249
    my $info = $conn->{'paths'}->get_info($path);
 
250
 
 
251
    unless ($info->{'_type'} eq 'f') {
 
252
        print {$conn->{socket}} "550 File not found.\r\n";
374
253
        return;
375
254
    }
376
255
 
377
256
    print {$conn->{socket}} "150 Opening " .
378
257
        ($conn->{type} eq 'A' ? "ASCII mode" : "BINARY mode") .
379
 
        " data connection for file $filename.\r\n";
 
258
        " data connection.\r\n";
380
259
 
381
260
    # Open a path back to the client.
382
261
    my $sock = __open_data_connection ($conn);
386
265
        return;
387
266
    }
388
267
 
 
268
    my $content = $info->{'content'};
 
269
 
 
270
    # Restart the connection from previous point?
 
271
    if ($conn->{restart}) {
 
272
        $content = substr($content, $conn->{restart});
 
273
        $conn->{restart} = 0;
 
274
    }
 
275
 
389
276
    # What mode are we sending this file in?
390
277
    unless ($conn->{type} eq 'A') # Binary type.
391
278
    {
392
279
        my ($r, $buffer, $n, $w);
393
280
 
394
 
        # Restart the connection from previous point?
395
 
        if ($conn->{restart}) {
396
 
            # VFS seek method only required to support relative forward seeks
397
 
            #
398
 
            # In Perl = 5.00503, SEEK_CUR is exported by IO::Seekable,
399
 
            # in Perl >= 5.6, SEEK_CUR is exported by both IO::Seekable
400
 
            # and Fcntl. Hence we 'use IO::Seekable' at the top of the
401
 
            # file to get this symbol reliably in both cases.
402
 
            sysseek (FILE, $conn->{restart}, SEEK_CUR);
403
 
            $conn->{restart} = 0;
404
 
        }
405
281
 
406
282
        # Copy data.
407
 
        while ($r = sysread (FILE, $buffer, 65536))
 
283
        while ($buffer = substr($content, 0, 65536))
408
284
        {
 
285
            $r = length $buffer;
 
286
 
409
287
            # Restart alarm clock timer.
410
288
            alarm $conn->{idle_timeout};
411
289
 
416
294
                # Cleanup and exit if there was an error.
417
295
                unless (defined $w) {
418
296
                    close $sock;
419
 
                    close FILE;
420
297
                    print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n";
421
298
                    return;
422
299
                }
428
305
            if ($GOT_SIGURG) {
429
306
                $GOT_SIGURG = 0;
430
307
                close $sock;
431
 
                close FILE;
432
308
                print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n";
433
309
                return;
434
310
            }
437
313
        # Cleanup and exit if there was an error.
438
314
        unless (defined $r) {
439
315
            close $sock;
440
 
            close FILE;
441
316
            print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n";
442
317
            return;
443
318
        }
444
319
    } else { # ASCII type.
445
 
        # Restart the connection from previous point?
446
 
        if ($conn->{restart}) {
447
 
            for (my $i = 0; $i < $conn->{restart}; ++$i) {
448
 
                getc FILE;
449
 
            }
450
 
            $conn->{restart} = 0;
451
 
        }
452
 
 
453
320
        # Copy data.
454
 
        while (defined ($_ = <FILE>)) {
 
321
        my @lines = split /\r\n?|\n/, $content;
 
322
        for (@lines) {
455
323
            # Remove any native line endings.
456
324
            s/[\n\r]+$//;
457
325
 
465
333
            if ($GOT_SIGURG) {
466
334
                $GOT_SIGURG = 0;
467
335
                close $sock;
468
 
                close FILE;
469
336
                print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n";
470
337
                return;
471
338
            }
472
339
        }
473
340
    }
474
341
 
475
 
    unless (close ($sock) && close (FILE)) {
 
342
    unless (close ($sock)) {
476
343
        print {$conn->{socket}} "550 File retrieval error: $!.\r\n";
477
344
        return;
478
345
    }
483
350
sub _SIZE_command
484
351
{
485
352
    my ($conn, $cmd, $path) = @_;
486
 
    
487
 
    my $dir = $conn->{dir};
488
 
 
489
 
    # Absolute path?
490
 
    if (substr ($path, 0, 1) eq "/") {
491
 
        $dir = "/";
492
 
        $path =~ s,^/+,,;
493
 
        $path = "." if $path eq "";
494
 
    }
495
 
 
496
 
    # Parse the first elements of path until we find the appropriate
497
 
    # working directory.
498
 
    my @elems = split /\//, $path;
499
 
    my $filename = pop @elems;
500
 
 
501
 
    foreach (@elems) {
502
 
        if ($_ eq "" || $_ eq ".") { 
503
 
            next # Ignore these.
504
 
        } elsif ($_ eq "..") {
505
 
            # Go to parent directory.
506
 
            unless ($dir eq "/") {
507
 
                $dir = substr ($dir, 0, rindex ($dir, "/"));
508
 
            }
509
 
        } else {
510
 
            unless (-d $conn->{rootdir} . $dir . $_) {
511
 
                print {$conn->{socket}} "550 File or directory not found.\r\n";
512
 
                return;
513
 
            }
514
 
            $dir .= $_;
515
 
        }
516
 
    }
517
 
 
518
 
    unless (defined $filename && length $filename) {
 
353
 
 
354
    $path = FTPPaths::path_merge($conn->{dir}, $path);
 
355
    my $info = $conn->{'paths'}->get_info($path);
 
356
    unless ($info) {
519
357
        print {$conn->{socket}} "550 File or directory not found.\r\n";
520
 
            return;
 
358
        return;
521
359
    }
522
360
 
523
 
    if ($filename eq "." || $filename eq "..") {
 
361
    if ($info->{'_type'} eq 'd') {
524
362
        print {$conn->{socket}} "550 SIZE command is not supported on directories.\r\n";
525
 
            return;
526
 
    }
527
 
 
528
 
    my $fullname = $conn->{rootdir} . $dir . $filename;
529
 
    unless (-f $fullname) {
530
 
        print {$conn->{socket}} "550 SIZE command is only supported on plain files.\r\n";
531
363
        return;
532
364
    }
533
365
 
534
 
    my $size = 0;
535
 
    if ($conn->{type} eq 'A') {
536
 
        # ASCII mode: we have to count the characters by hand.
537
 
        unless (open (FILE, '<', $filename)) {
538
 
            print {$conn->{socket}} "550 Cannot calculate size of $filename.\r\n";
539
 
            return;
540
 
        }
541
 
        $size++ while (defined (getc(FILE)));
542
 
        close FILE;
543
 
    } else {
544
 
        # BINARY mode: we can use stat
545
 
        $size = (stat($filename))[7];
546
 
    }
 
366
    my $size = length $info->{'content'};
547
367
 
548
368
    print {$conn->{socket}} "213 $size\r\n";
549
369
}
551
371
sub _SYST_command
552
372
{
553
373
    my ($conn, $cmd, $dummy) = @_;
554
 
    
 
374
 
555
375
    print {$conn->{socket}} "215 UNIX Type: L8\r\n";
556
376
}
557
377
 
558
378
sub _TYPE_command
559
379
{
560
380
    my ($conn, $cmd, $type) = @_;
561
 
    
 
381
 
562
382
    # See RFC 959 section 5.3.2.
563
383
    if ($type =~ /^([AI])$/i) {
564
384
        $conn->{type} = 'A';
583
403
 
584
404
    print STDERR "switching to WAIT4PWD state\n" if $log;
585
405
    $conn->{state} = $_connection_states{WAIT4PWD};
586
 
    
 
406
 
587
407
    if ($conn->{username} eq "anonymous") {
588
408
        print {$conn->{socket}} "230 Anonymous user access granted.\r\n";
589
409
    } else {
617
437
}
618
438
 
619
439
 
620
 
sub __list_file
621
 
{
622
 
    my $sock = shift;
623
 
    my $filename = shift;
624
 
 
625
 
    # Get the status information.
626
 
    my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
627
 
        $atime, $mtime, $ctime, $blksize, $blocks)
628
 
      = lstat $filename;
629
 
 
630
 
    # If the file has been removed since we created this
631
 
    # handle, then $dev will be undefined. Return immediately.
632
 
    return unless defined $dev;
633
 
 
634
 
    # Generate printable user/group.
635
 
    my $user = getpwuid ($uid) || "-";
636
 
    my $group = getgrgid ($gid) || "-";
637
 
 
638
 
    # Permissions from mode.
639
 
    my $perms = $mode & 0777;
640
 
 
641
 
    # Work out the mode using special "_" operator which causes Perl
642
 
    # to use the result of the previous stat call.
643
 
    $mode = (-f _ ? 'f' :
644
 
             (-d _ ? 'd' :
645
 
              (-l _ ? 'l' :
646
 
               (-p _ ? 'p' :
647
 
                (-S _ ? 's' :
648
 
                 (-b _ ? 'b' :
649
 
                  (-c _ ? 'c' : '?')))))));
650
 
 
651
 
    # Generate printable date (this logic is taken from GNU fileutils:
652
 
    # src/ls.c: print_long_format).
653
 
    my $time = time;
654
 
    my $fmt;
655
 
    if ($time > $mtime + 6 * 30 * 24 * 60 * 60 || $time < $mtime - 60 * 60) {
656
 
        $fmt = "%b %e  %Y";
657
 
    } else {
658
 
        $fmt = "%b %e %H:%M";
659
 
    }
660
 
 
661
 
    my $fmt_time = strftime $fmt, localtime ($mtime);
662
 
 
663
 
    # Generate printable permissions.
664
 
    my $fmt_perms = join "",
665
 
      ($perms & 0400 ? 'r' : '-'),
666
 
      ($perms & 0200 ? 'w' : '-'),
667
 
      ($perms & 0100 ? 'x' : '-'),
668
 
      ($perms & 040 ? 'r' : '-'),
669
 
      ($perms & 020 ? 'w' : '-'),
670
 
      ($perms & 010 ? 'x' : '-'),
671
 
      ($perms & 04 ? 'r' : '-'),
672
 
      ($perms & 02 ? 'w' : '-'),
673
 
      ($perms & 01 ? 'x' : '-');
674
 
 
675
 
    # Printable file type.
676
 
    my $fmt_mode = $mode eq 'f' ? '-' : $mode;
677
 
 
678
 
    # If it's a symbolic link, display the link.
679
 
    my $link;
680
 
    if ($mode eq 'l') {
681
 
        $link = readlink $filename;
682
 
        die "readlink: $!" unless defined $link;
683
 
    }
684
 
    my $fmt_link = defined $link ? " -> $link" : "";
685
 
 
686
 
    # Display the file.
687
 
    my $line = sprintf
688
 
      ("%s%s%4d %-8s %-8s %8d %s %s%s\r\n",
689
 
       $fmt_mode,
690
 
       $fmt_perms,
691
 
       $nlink,
692
 
       $user,
693
 
       $group,
694
 
       $size,
695
 
       $fmt_time,
696
 
       $filename,
697
 
       $fmt_link);
698
 
    $sock->print ($line);
699
 
}
700
 
 
701
 
 
702
 
sub __get_file_list
703
 
{
704
 
    my $dir = shift;
705
 
    my $wildcard = shift;
706
 
 
707
 
    opendir (DIRHANDLE, $dir)
708
 
        or die "Cannot open directory!!!";
709
 
 
710
 
    my @allfiles = readdir DIRHANDLE;
711
 
    my @filenames = ();
712
 
    
713
 
    if ($wildcard) {
714
 
        # Get rid of . and ..
715
 
        @allfiles = grep !/^\.{1,2}$/, @allfiles;
716
 
        
717
 
        # Convert wildcard to a regular expression.
718
 
        $wildcard = __wildcard_to_regex ($wildcard);
719
 
 
720
 
        @filenames = grep /$wildcard/, @allfiles;
721
 
    } else {
722
 
        @filenames = @allfiles;
723
 
    }
724
 
 
725
 
    closedir (DIRHANDLE);
726
 
 
727
 
    return sort @filenames;
728
 
}
729
 
 
730
 
 
731
 
sub __wildcard_to_regex
732
 
{
733
 
    my $wildcard = shift;
734
 
 
735
 
    $wildcard =~ s,([^?*a-zA-Z0-9]),\\$1,g; # Escape punctuation.
736
 
    $wildcard =~ s,\*,.*,g; # Turn * into .*
737
 
    $wildcard =~ s,\?,.,g;  # Turn ? into .
738
 
    $wildcard = "^$wildcard\$"; # Bracket it.
739
 
 
740
 
    return $wildcard;
741
 
}
742
 
 
743
 
 
744
440
###########################################################################
745
441
# FTPSERVER CLASS
746
442
###########################################################################
747
443
 
748
444
{
749
445
    my %_attr_data = ( # DEFAULT
750
 
        _localAddr  => 'localhost',
751
 
        _localPort  => 8021,
752
 
        _reuseAddr  => 1,
753
 
        _rootDir    => Cwd::getcwd(),
 
446
        _input           => undef,
 
447
        _localAddr       => 'localhost',
 
448
        _localPort       => undef,
 
449
        _reuseAddr       => 1,
 
450
        _rootDir         => Cwd::getcwd(),
 
451
        _server_behavior => {},
754
452
    );
755
 
    
 
453
 
756
454
    sub _default_for
757
455
    {
758
456
        my ($self, $attr) = @_;
759
457
        $_attr_data{$attr};
760
458
    }
761
459
 
762
 
    sub _standard_keys 
 
460
    sub _standard_keys
763
461
    {
764
462
        keys %_attr_data;
765
463
    }
781
479
            $self->{$attrname} = $self->_default_for($attrname);
782
480
        }
783
481
    }
 
482
    # create server socket
 
483
    "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
 
484
    $self->{_server_sock}
 
485
                    = IO::Socket::INET->new (LocalHost => $self->{_localAddr},
 
486
                                             LocalPort => $self->{_localPort},
 
487
                                             Listen => 1,
 
488
                                             Reuse => $self->{_reuseAddr},
 
489
                                             Proto => 'tcp',
 
490
                                             Type => SOCK_STREAM)
 
491
                                        or die "bind: $!";
784
492
    return $self;
785
493
}
786
494
 
787
495
 
788
 
sub run 
 
496
sub run
789
497
{
790
498
    my ($self, $synch_callback) = @_;
791
499
    my $initialized = 0;
803
511
    my $old_ils = $/;
804
512
    $/ = "\r\n";
805
513
 
806
 
    # create server socket
807
 
    "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
808
 
    my $server_sock = IO::Socket::INET->new (LocalHost => $self->{_localAddr},
809
 
                                             LocalPort => $self->{_localPort},
810
 
                                             Listen => 1,
811
 
                                             Reuse => $self->{_reuseAddr},
812
 
                                             Proto => 'tcp',
813
 
                                             Type => SOCK_STREAM) or die "bind: $!";
814
 
 
815
514
    if (!$initialized) {
816
515
        $synch_callback->();
817
516
        $initialized = 1;
818
517
    }
819
518
 
820
519
    $SIG{CHLD} = sub { wait };
 
520
    my $server_sock = $self->{_server_sock};
821
521
 
822
522
    # the accept loop
823
523
    while (my $client_addr = accept (my $socket, $server_sock))
824
 
    {    
 
524
    {
825
525
        # turn buffering off on $socket
826
526
        select((select($socket), $|=1)[0]);
827
 
        
828
 
        # find out who connected    
 
527
 
 
528
        # find out who connected
829
529
        my ($client_port, $client_ip) = sockaddr_in ($client_addr);
830
530
        my $client_ipnum = inet_ntoa ($client_ip);
831
531
 
833
533
        print STDERR "got a connection from: $client_ipnum\n" if $log;
834
534
 
835
535
        # fork off a process to handle this connection.
836
 
        my $pid = fork();
837
 
        unless (defined $pid) {
838
 
            warn "fork: $!";
839
 
            sleep 5; # Back off in case system is overloaded.
840
 
            next;
841
 
        }
 
536
        # my $pid = fork();
 
537
        # unless (defined $pid) {
 
538
        #     warn "fork: $!";
 
539
        #     sleep 5; # Back off in case system is overloaded.
 
540
        #     next;
 
541
        # }
842
542
 
843
 
        if ($pid == 0) { # Child process.
 
543
        if (1) { # Child process.
844
544
 
845
545
            # install signals
846
 
            $SIG{URG}  = sub { 
847
 
                $GOT_SIGURG  = 1; 
 
546
            $SIG{URG}  = sub {
 
547
                $GOT_SIGURG  = 1;
848
548
            };
849
549
 
850
550
            $SIG{PIPE} = sub {
856
556
                print STDERR "Connection idle timeout expired. Closing server.\n";
857
557
                exit;
858
558
            };
859
 
            
 
559
 
860
560
            #$SIG{CHLD} = 'IGNORE';
861
561
 
862
562
 
863
563
            print STDERR "in child\n" if $log;
864
564
 
865
 
            my $conn = { 
866
 
                'socket'       => $socket, 
867
 
                'state'        => $_connection_states{NEWCONN},
868
 
                'dir'          => '/',
869
 
                'restart'      => 0,
870
 
                'idle_timeout' => 60, # 1 minute timeout
871
 
                'rootdir'      => $self->{_rootDir},
 
565
            my $conn = {
 
566
                'paths'           => FTPPaths->new($self->{'_input'},
 
567
                                        $self->{'_server_behavior'}),
 
568
                'socket'          => $socket,
 
569
                'state'           => $_connection_states{NEWCONN},
 
570
                'dir'             => '/',
 
571
                'restart'         => 0,
 
572
                'idle_timeout'    => 60, # 1 minute timeout
 
573
                'rootdir'         => $self->{_rootDir},
872
574
            };
873
 
        
 
575
 
874
576
            print {$conn->{socket}} "220 GNU Wget Testing FTP Server ready.\r\n";
875
577
 
876
578
            # command handling loop
911
613
                    print {$conn->{socket}} "530 Not logged in.\r\n";
912
614
                    next;
913
615
                }
914
 
                
 
616
 
915
617
                # Handle the QUIT command specially.
916
618
                if ($cmd eq "QUIT") {
917
619
                    print {$conn->{socket}} "221 Goodbye. Service closing connection.\r\n";
918
620
                    last;
919
621
                }
920
622
 
 
623
                if (defined ($self->{_server_behavior}{fail_on_pasv})
 
624
                        && $cmd eq 'PASV') {
 
625
                    undef $self->{_server_behavior}{fail_on_pasv};
 
626
                    close $socket;
 
627
                    last;
 
628
                }
 
629
 
921
630
                # Run the command.
922
631
                &{$command_table->{$cmd}} ($conn, $cmd, $rest);
923
632
            }
924
633
        } else { # Father
925
634
            close $socket;
926
635
        }
927
 
    } 
 
636
    }
928
637
 
929
638
    $/ = $old_ils;
930
639
}
931
640
 
 
641
sub sockport {
 
642
    my $self = shift;
 
643
    return $self->{_server_sock}->sockport;
 
644
}
 
645
 
 
646
 
 
647
package FTPPaths;
 
648
 
 
649
use POSIX qw(strftime);
 
650
 
 
651
# not a method
 
652
sub final_component {
 
653
    my $path = shift;
 
654
 
 
655
    $path =~ s|.*/||;
 
656
    return $path;
 
657
}
 
658
 
 
659
# not a method
 
660
sub path_merge {
 
661
    my ($a, $b) = @_;
 
662
 
 
663
    return $a unless $b;
 
664
 
 
665
    if ($b =~ m.^/.) {
 
666
        $a = '';
 
667
        $b =~ s.^/..;
 
668
    }
 
669
    $a =~ s./$..;
 
670
 
 
671
    my @components = split('/', $b);
 
672
 
 
673
    foreach my $c (@components) {
 
674
        if ($c =~ /^\.?$/) {
 
675
            next;
 
676
        } elsif ($c eq '..') {
 
677
            next if $a eq '';
 
678
            $a =~ s|/[^/]*$||;
 
679
        } else {
 
680
            $a .= "/$c";
 
681
        }
 
682
    }
 
683
 
 
684
    return $a;
 
685
}
 
686
 
 
687
sub new {
 
688
    my ($this, @args) = @_;
 
689
    my $class = ref($this) || $this;
 
690
    my $self = {};
 
691
    bless $self, $class;
 
692
    $self->initialize(@args);
 
693
    return $self;
 
694
}
 
695
 
 
696
sub initialize {
 
697
    my ($self, $urls, $behavior) = @_;
 
698
    my $paths = {_type => 'd'};
 
699
 
 
700
    # From a path like '/foo/bar/baz.txt', construct $paths such that
 
701
    # $paths->{'foo'}->{'bar'}->{'baz.txt'} is
 
702
    # $urls->{'/foo/bar/baz.txt'}.
 
703
    for my $path (keys %$urls) {
 
704
        my @components = split('/', $path);
 
705
        shift @components;
 
706
        my $x = $paths;
 
707
        for my $c (@components) {
 
708
            unless (exists $x->{$c}) {
 
709
                $x->{$c} = {_type => 'd'};
 
710
            }
 
711
            $x = $x->{$c};
 
712
        }
 
713
        %$x = %{$urls->{$path}};
 
714
        $x->{_type} = 'f';
 
715
    }
 
716
 
 
717
    $self->{'_paths'} = $paths;
 
718
    $self->{'_behavior'} = $behavior;
 
719
}
 
720
 
 
721
sub get_info {
 
722
    my ($self, $path, $node) = @_;
 
723
    $node = $self->{'_paths'} unless $node;
 
724
    my @components = split('/', $path);
 
725
    shift @components if @components && $components[0] eq '';
 
726
 
 
727
    for my $c (@components) {
 
728
        if ($node->{'_type'} eq 'd') {
 
729
            $node = $node->{$c};
 
730
        } else {
 
731
            return undef;
 
732
        }
 
733
    }
 
734
    return $node;
 
735
}
 
736
 
 
737
sub dir_exists {
 
738
    my ($self, $path) = @_;
 
739
    return $self->exists($path, 'd');
 
740
}
 
741
 
 
742
sub exists {
 
743
    # type is optional, in which case we don't check it.
 
744
    my ($self, $path, $type) = @_;
 
745
    my $paths = $self->{'_paths'};
 
746
 
 
747
    die "Invalid path $path (not absolute).\n" unless $path =~ m.^/.;
 
748
    my $info = $self->get_info($path);
 
749
    return 0 unless defined($info);
 
750
    return $info->{'_type'} eq $type if defined($type);
 
751
    return 1;
 
752
}
 
753
 
 
754
sub _format_for_list {
 
755
    my ($self, $name, $info) = @_;
 
756
 
 
757
    # XXX: mode should be specifyable as part of the node info.
 
758
    my $mode_str;
 
759
    if ($info->{'_type'} eq 'd') {
 
760
        $mode_str = 'dr-xr-xr-x';
 
761
    } else {
 
762
        $mode_str = '-r--r--r--';
 
763
    }
 
764
 
 
765
    my $size = 0;
 
766
    if ($info->{'_type'} eq 'f') {
 
767
        $size = length  $info->{'content'};
 
768
        if ($self->{'_behavior'}{'bad_list'}) {
 
769
            $size = 0;
 
770
        }
 
771
    }
 
772
    my $date = strftime ("%b %e %H:%M", localtime);
 
773
    return "$mode_str 1  0  0  $size $date $name";
 
774
}
 
775
 
 
776
sub get_list {
 
777
    my ($self, $path) = @_;
 
778
    my $info = $self->get_info($path);
 
779
    return undef unless defined $info;
 
780
    my $list = [];
 
781
 
 
782
    if ($info->{'_type'} eq 'd') {
 
783
        for my $item (keys %$info) {
 
784
            next if $item =~ /^_/;
 
785
            push @$list, $self->_format_for_list($item, $info->{$item});
 
786
        }
 
787
    } else {
 
788
        push @$list, $self->_format_for_list(final_component($path), $info);
 
789
    }
 
790
 
 
791
    return $list;
 
792
}
 
793
 
932
794
1;
933
795
 
934
796
# vim: et ts=4 sw=4
935