diff --git a/Koha/File/Transport/FTP.pm b/Koha/File/Transport/FTP.pm index 8fe50baaf2..5600bd4db8 100644 --- a/Koha/File/Transport/FTP.pm +++ b/Koha/File/Transport/FTP.pm @@ -17,6 +17,7 @@ package Koha::File::Transport::FTP; use Modern::Perl; use Net::FTP; +use Time::Local qw( timegm ); use Try::Tiny; use base qw(Koha::File::Transport); @@ -156,7 +157,7 @@ sub _change_directory { Internal method that performs the FTP-specific file listing operation. Returns an array reference of hashrefs with file information. -Each hashref contains: filename, longname, size, perms. +Each hashref contains: filename, longname, size, perms, mtime, type. The listing is obtained with MLSD (RFC 3659), whose machine-readable output is locale- and platform-independent and gives us the filename unambiguously @@ -171,9 +172,7 @@ rmdir() uses for MLSD. That interface has been stable for many releases. The hashref shape is kept consistent with the SFTP and Local transports so that consumers of list_files() (including out-of-tree ones) can rely on the -same structure regardless of transport type. Note that over MLSD the perms -value is the RFC 3659 "perm" fact (e.g. "adfr"), not a Unix mode string, and -size is only present when the server reports it. +same structure regardless of transport type. =cut @@ -200,21 +199,44 @@ sub _list_files { map { my ( $k, $v ) = split /=/, $_, 2; ( lc($k) => $v ) } grep { length } split /;/, $facts_str; - # Skip the directory itself, its parent and any subdirectories - next if ( $fact{type} // q{} ) =~ /^(?:dir|cdir|pdir)$/i; + # Skip only the current/parent directory pseudo-entries; real + # subdirectories (type=dir) are now included like Local and SFTP. + next if ( $fact{type} // q{} ) =~ /^(?:cdir|pdir)$/i; + my $type = + ( $fact{type} // q{} ) eq 'file' ? 'file' + : ( $fact{type} // q{} ) eq 'dir' ? 'directory' + : 'other'; + + my $perms = $self->_perms_from_mlsd_facts( \%fact, $type ); push @file_list, { filename => $filename, longname => $line, size => $fact{size}, - perms => $fact{perm} + perms => $perms, + mtime => $self->_mtime_from_mlsd_fact( $fact{modify} ), + type => $type, }; } } else { - # Fallback for servers without MLSD: NLST returns bare filenames only. + # Fallback for servers without MLSD: NLST returns bare filenames + # only, so probe each entry with SIZE/MDTM (both plain Net::FTP + # methods) to recover size, mtime and a best-effort type. A + # permission-denied file would be misclassified as a directory here + # (SIZE failing is the only signal available) - a rare, accepted + # limitation of this legacy fallback path. perms stays undef: there + # is no way to get Unix permission bits without MLSD/UNIX.mode. my $names = $self->{connection}->ls or return $self->_abort_operation($operation); - @file_list = map { { filename => $_ } } grep { !/^[.]{1,2}$/ } @{$names}; + foreach my $name ( grep { !/^[.]{1,2}$/ } @{$names} ) { + my $size = $self->{connection}->size($name); + push @file_list, { + filename => $name, + size => $size, + mtime => $self->{connection}->mdtm($name), + type => defined $size ? 'file' : 'directory', + }; + } } $self->add_message( @@ -231,6 +253,60 @@ sub _list_files { return \@file_list; } +=head3 _perms_from_mlsd_facts + + my $perms = $self->_perms_from_mlsd_facts( \%fact, $type ); + +Converts MLSD facts into the same C<"%04o"> Unix permission-bits string used +by the Local and SFTP transports. + +Prefers the C vendor-extension fact (exact Unix octal +permissions) when the server provides it. Otherwise approximates from the +RFC 3659 C fact, which describes only what the connected user is +allowed to do (append/create/delete/rename/list/mkdir/read/write/etc.), not +a real owner/group/other split - the resulting triad is mirrored across +owner/group/other since that distinction isn't available. Returns undef if +neither fact is present. + +=cut + +sub _perms_from_mlsd_facts { + my ( $self, $fact, $type ) = @_; + + if ( defined $fact->{'unix.mode'} ) { + return sprintf( "%04o", oct( $fact->{'unix.mode'} ) & oct('07777') ); + } + + my $perm = $fact->{perm}; + return unless defined $perm; + + my $bits = 0; + $bits |= 4 if $perm =~ /r/; + $bits |= 2 if $perm =~ /[wa]/; + $bits |= 1 if $type eq 'directory' && $perm =~ /e/; + + return sprintf( "%04o", ( $bits << 6 ) | ( $bits << 3 ) | $bits ); +} + +=head3 _mtime_from_mlsd_fact + + my $mtime = $self->_mtime_from_mlsd_fact( $fact->{modify} ); + +Converts an MLSD C fact (RFC 3659 C format, +always UTC) into a Unix epoch timestamp. Returns undef if the fact is +missing or doesn't match the expected format. + +=cut + +sub _mtime_from_mlsd_fact { + my ( $self, $modify ) = @_; + + return unless defined $modify; + return unless $modify =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})/; + + return eval { timegm( $6, $5, $4, $3, $2 - 1, $1 ) }; +} + =head3 _rename_file Internal method that performs the FTP-specific file rename operation. diff --git a/Koha/File/Transport/Local.pm b/Koha/File/Transport/Local.pm index 568f30cf5b..e27908b4dc 100644 --- a/Koha/File/Transport/Local.pm +++ b/Koha/File/Transport/Local.pm @@ -19,6 +19,7 @@ use Modern::Perl; use File::Copy qw( copy move ); use File::Spec; use IO::Dir; +use Fcntl qw( S_ISDIR S_ISREG ); use base qw(Koha::File::Transport); @@ -257,7 +258,7 @@ sub _change_directory { Internal method that performs the local file system file listing operation. Returns an array reference of hashrefs with file information. -Each hashref contains: filename, longname, size, perms, mtime. +Each hashref contains: filename, longname, size, perms, mtime, type. =cut @@ -300,14 +301,20 @@ sub _list_files { while ( defined( my $file = $dir_handle->read ) ) { next if $file =~ /^\.\.?$/; # Skip . and .. my $full_path = File::Spec->catfile( $directory, $file ); - next unless -f $full_path; # Only files - # Get file stats for consistency with SFTP format - my @stat = stat($full_path); + # Get file stats for consistency with the SFTP/FTP format + my @stat = stat($full_path); + next unless @stat; # Skip entries we can't stat (e.g. broken symlinks) + my $size = $stat[7] || 0; my $mtime = $stat[9] || 0; my $mode = $stat[2] || 0; + my $type = + S_ISDIR($mode) ? 'directory' + : S_ISREG($mode) ? 'file' + : 'other'; + # Create permissions string (simplified) my $perms = sprintf( "%04o", $mode & oct('07777') ); @@ -316,7 +323,8 @@ sub _list_files { longname => sprintf( "%s %8d %s %s", $perms, $size, scalar( localtime($mtime) ), $file ), size => $size, perms => $perms, - mtime => $mtime + mtime => $mtime, + type => $type, }; } $dir_handle->close; diff --git a/Koha/File/Transport/SFTP.pm b/Koha/File/Transport/SFTP.pm index 51f609a7b8..2ebe9a678e 100644 --- a/Koha/File/Transport/SFTP.pm +++ b/Koha/File/Transport/SFTP.pm @@ -23,7 +23,8 @@ use File::Spec; use IO::File; use Net::SFTP::Foreign; use Try::Tiny; -use JSON qw( decode_json encode_json ); +use JSON qw( decode_json encode_json ); +use Fcntl qw( S_ISDIR S_ISREG ); use base qw(Koha::File::Transport); @@ -172,7 +173,11 @@ sub _change_directory { Internal method that performs the SFTP-specific file listing operation. Returns an array reference of hashrefs with file information. -Each hashref contains: filename, longname, a (attributes). +Each hashref contains: filename, longname, size, perms, mtime, type. + +Net::SFTP::Foreign's ls() natively returns the size/perms/mtime nested inside +a Net::SFTP::Foreign::Attributes object (the 'a' key). Those fields are +flattened out here so the returned shape matches the FTP and Local transports. =cut @@ -182,6 +187,22 @@ sub _list_files { my $file_list = $self->{connection}->ls or return $self->_abort_operation($operation); + my @files = map { + my $attrs = $_->{a}; + my $mode = $attrs ? $attrs->perm : undef; + { + filename => $_->{filename}, + longname => $_->{longname}, + size => $attrs ? $attrs->size : undef, + perms => $attrs && defined $mode ? sprintf( "%04o", $mode & oct('07777') ) : undef, + mtime => $attrs ? $attrs->mtime : undef, + type => !defined $mode ? 'other' + : S_ISDIR($mode) ? 'directory' + : S_ISREG($mode) ? 'file' + : 'other', + } + } @{$file_list}; + $self->add_message( { message => $operation, @@ -194,7 +215,7 @@ sub _list_files { } ); - return $file_list; + return \@files; } =head3 _rename_file diff --git a/t/db_dependent/Koha/File/Transport/FTP.t b/t/db_dependent/Koha/File/Transport/FTP.t index 429add89f7..e781a2f8e3 100755 --- a/t/db_dependent/Koha/File/Transport/FTP.t +++ b/t/db_dependent/Koha/File/Transport/FTP.t @@ -136,7 +136,7 @@ subtest 'change_directory() tests' => sub { }; subtest 'list_files() MLSD tests' => sub { - plan tests => 6; + plan tests => 16; $schema->storage->txn_begin; @@ -151,11 +151,12 @@ subtest 'list_files() MLSD tests' => sub { # MLSD output: "facts filename" per RFC 3659. Facts are locale-independent, # the filename is everything after the facts and a single space (so spaces - # in filenames are handled), and cdir/pdir/dir entries must be skipped. + # in filenames are handled), and cdir/pdir entries must be skipped while + # real subdirectories (type=dir) are now included. my @mlsd_output = ( 'type=file;size=1234;modify=20250101120000;perm=adfr; QUOTES_413514.CEQ', - 'type=file;size=4096;modify=20250214093000; INVOICE_99.CEI', - 'type=dir;modify=20250303080000; subdir', + 'type=file;size=4096;modify=20250214093000;UNIX.mode=0644; INVOICE_99.CEI', + 'type=dir;modify=20250303080000;perm=cpmel; subdir', 'type=cdir;modify=20250303080000; .', 'type=pdir;modify=20250303080000; ..', 'type=file;size=55;modify=20250405091000; name with spaces.CEA', @@ -175,17 +176,34 @@ subtest 'list_files() MLSD tests' => sub { is( ref($files), 'ARRAY', 'list_files() returns an arrayref' ); my @names = sort map { $_->{filename} } @{$files}; - is( scalar @names, 3, 'directory, cdir and pdir entries are skipped' ); + is( scalar @names, 4, 'cdir and pdir entries are skipped, dir entries are now included' ); is_deeply( \@names, - [ 'INVOICE_99.CEI', 'QUOTES_413514.CEQ', 'name with spaces.CEA' ], + [ 'INVOICE_99.CEI', 'QUOTES_413514.CEQ', 'name with spaces.CEA', 'subdir' ], 'filenames parsed from MLSD, spaces preserved' ); - my ($quote) = grep { $_->{filename} eq 'QUOTES_413514.CEQ' } @{$files}; - is( $quote->{size}, 1234, 'size fact parsed correctly' ); - is( $quote->{perms}, 'adfr', 'perm fact captured' ); + my ($quote) = grep { $_->{filename} eq 'QUOTES_413514.CEQ' } @{$files}; + my ($invoice) = grep { $_->{filename} eq 'INVOICE_99.CEI' } @{$files}; + my ($subdir) = grep { $_->{filename} eq 'subdir' } @{$files}; + my ($spaced) = grep { $_->{filename} eq 'name with spaces.CEA' } @{$files}; + + is( $quote->{size}, 1234, 'size fact parsed correctly' ); + is( $quote->{type}, 'file', 'type=file fact maps to "file"' ); + is( $quote->{perms}, '0666', 'perm-only fact (adfr: read+write) approximated to octal' ); + is( $quote->{mtime}, 1735732800, 'modify fact (2025-01-01 12:00:00 UTC) parsed into mtime' ); + + is( $invoice->{perms}, '0644', 'UNIX.mode fact used verbatim when present' ); + is( $invoice->{type}, 'file', 'type=file fact maps to "file"' ); + is( $invoice->{mtime}, 1739525400, 'modify fact (2025-02-14 09:30:00 UTC) parsed into mtime' ); + + is( $subdir->{type}, 'directory', 'type=dir fact maps to "directory"' ); + is( $subdir->{perms}, '0111', 'perm-only fact (cpmel: execute via e) approximated to octal' ); + is( $subdir->{mtime}, 1740988800, 'modify fact is parsed into mtime for directories too' ); + + is( $spaced->{perms}, undef, 'entries with neither perm nor UNIX.mode fact get undef perms' ); + is( $spaced->{mtime}, 1743844200, 'modify fact still parsed into mtime when perms is undef' ); $transport->{connection} = undef; @@ -193,7 +211,7 @@ subtest 'list_files() MLSD tests' => sub { }; subtest 'list_files() NLST fallback tests' => sub { - plan tests => 4; + plan tests => 10; $schema->storage->txn_begin; @@ -205,12 +223,30 @@ subtest 'list_files() NLST fallback tests' => sub { ); # Server without MLSD support: _list_cmd('MLSD') returns nothing, so - # list_files() must fall back to NLST (ls) and return bare filenames. + # list_files() must fall back to NLST (ls) and probe each entry with + # SIZE/MDTM (plain Net::FTP methods) for size/mtime/type. my $ls_called = 0; my $mock_ftp = Test::MockModule->new('Net::FTP'); $mock_ftp->mock( '_list_cmd', sub { return; } ); - $mock_ftp->mock( 'ls', sub { $ls_called = 1; return [ 'QUOTES_1.CEQ', '.', '..', 'INVOICE_2.CEI' ]; } ); - $mock_ftp->mock( 'pwd', sub { return '/incoming/'; } ); + $mock_ftp->mock( + 'ls', + sub { $ls_called = 1; return [ 'QUOTES_1.CEQ', '.', '..', 'INVOICE_2.CEI', 'subdir' ]; } + ); + $mock_ftp->mock( 'pwd', sub { return '/incoming/'; } ); + $mock_ftp->mock( + 'size', + sub { + my ( $s, $name ) = @_; + return { 'QUOTES_1.CEQ' => 100, 'INVOICE_2.CEI' => 200 }->{$name}; + } + ); + $mock_ftp->mock( + 'mdtm', + sub { + my ( $s, $name ) = @_; + return { 'QUOTES_1.CEQ' => 1700000000, 'INVOICE_2.CEI' => 1700000100 }->{$name}; + } + ); $transport->{connection} = bless {}, 'Net::FTP'; $transport->{_user_set_directory} = 1; @@ -220,13 +256,26 @@ subtest 'list_files() NLST fallback tests' => sub { is( $ls_called, 1, 'falls back to ls() when MLSD is unsupported' ); my @names = sort map { $_->{filename} } @{$files}; - is( scalar @names, 2, 'current/parent dir entries filtered from NLST output' ); + is( scalar @names, 3, 'current/parent dir entries filtered from NLST output' ); is_deeply( \@names, - [ 'INVOICE_2.CEI', 'QUOTES_1.CEQ' ], - 'bare filenames returned from NLST fallback' + [ 'INVOICE_2.CEI', 'QUOTES_1.CEQ', 'subdir' ], + 'bare filenames returned from NLST fallback, including the directory' ); - ok( ( exists $files->[0]{filename} ), 'fallback entries expose a filename key' ); + + my ($quote) = grep { $_->{filename} eq 'QUOTES_1.CEQ' } @{$files}; + my ($invoice) = grep { $_->{filename} eq 'INVOICE_2.CEI' } @{$files}; + my ($subdir) = grep { $_->{filename} eq 'subdir' } @{$files}; + + is( $quote->{type}, 'file', 'SIZE succeeding means type "file"' ); + is( $quote->{size}, 100, 'size populated via SIZE probe' ); + is( $quote->{mtime}, 1700000000, 'mtime populated via MDTM probe' ); + + is( $invoice->{type}, 'file', 'SIZE succeeding means type "file"' ); + is( $invoice->{size}, 200, 'size populated via SIZE probe' ); + + is( $subdir->{type}, 'directory', 'SIZE failing is treated as a directory' ); + is( $subdir->{perms}, undef, 'perms stay undef on the NLST fallback path' ); $transport->{connection} = undef; diff --git a/t/db_dependent/Koha/File/Transport/Local.t b/t/db_dependent/Koha/File/Transport/Local.t new file mode 100755 index 0000000000..2653e6dc80 --- /dev/null +++ b/t/db_dependent/Koha/File/Transport/Local.t @@ -0,0 +1,82 @@ +#!/usr/bin/perl + +# This file is part of Koha. +# +# Koha 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 3 of the License, or +# (at your option) any later version. +# +# Koha 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 Koha; if not, see . + +use Modern::Perl; + +use Test::More tests => 2; +use Test::NoWarnings; +use File::Temp qw( tempdir ); +use File::Spec; + +use Koha::File::Transports; + +use t::lib::TestBuilder; +use t::lib::Mocks; + +my $schema = Koha::Database->new->schema; +my $builder = t::lib::TestBuilder->new; + +subtest 'list_files() tests' => sub { + plan tests => 9; + + $schema->storage->txn_begin; + + my $tempdir = tempdir( CLEANUP => 1 ); + my $download_dir = File::Spec->catdir( $tempdir, 'download' ); + mkdir $download_dir or die "Cannot create download_dir: $!"; + + my $file_path = File::Spec->catfile( $download_dir, 'QUOTES_413514.CEQ' ); + open my $fh, '>', $file_path or die "Cannot create test file: $!"; + print $fh 'test content'; + close $fh; + chmod 0644, $file_path; + + my $subdir_path = File::Spec->catdir( $download_dir, 'incoming' ); + mkdir $subdir_path or die "Cannot create subdir: $!"; + chmod 0755, $subdir_path; + + my $transport = $builder->build_object( + { + class => 'Koha::File::Transports', + value => { + transport => 'local', + download_directory => $download_dir, + } + } + ); + + can_ok( $transport, 'list_files' ); + + my $files = $transport->list_files(); + is( ref($files), 'ARRAY', 'list_files() returns an arrayref' ); + is( scalar @{$files}, 2, 'both the file and the directory are returned' ); + + my ($file_entry) = grep { $_->{filename} eq 'QUOTES_413514.CEQ' } @{$files}; + my ($dir_entry) = grep { $_->{filename} eq 'incoming' } @{$files}; + + ok( $file_entry, 'file entry is present' ); + is( $file_entry->{type}, 'file', 'file entry has type "file"' ); + is( $file_entry->{perms}, '0644', 'file entry has expected octal perms' ); + + ok( $dir_entry, 'directory entry is present' ); + is( $dir_entry->{type}, 'directory', 'directory entry has type "directory"' ); + is( $dir_entry->{perms}, '0755', 'directory entry has expected octal perms' ); + + $schema->storage->txn_rollback; +}; + +1; diff --git a/t/db_dependent/Koha/File/Transport/SFTP.t b/t/db_dependent/Koha/File/Transport/SFTP.t index 33ec965ba9..001dd70e71 100755 --- a/t/db_dependent/Koha/File/Transport/SFTP.t +++ b/t/db_dependent/Koha/File/Transport/SFTP.t @@ -23,6 +23,8 @@ use Test::NoWarnings; use Test::Warn; use Test::MockModule; +use Net::SFTP::Foreign::Attributes; + use Koha::Encryption; use Koha::File::Transports; @@ -248,7 +250,10 @@ subtest 'change_directory() tests' => sub { }; subtest 'list_files() tests' => sub { - plan tests => 1; + plan tests => 11; + + $schema->storage->txn_begin; + my $transport = $builder->build_object( { class => 'Koha::File::Transports', @@ -257,6 +262,64 @@ subtest 'list_files() tests' => sub { ); can_ok( $transport, 'list_files' ); + + # Net::SFTP::Foreign::ls() returns an arrayref of hashes, each with + # filename, longname and an 'a' key holding a + # Net::SFTP::Foreign::Attributes object - the fields we need to flatten + # out into the same flat hash shape used by the FTP and Local transports. + my $file_attrs = Net::SFTP::Foreign::Attributes->new; + $file_attrs->set_size(1234); + $file_attrs->set_perm( oct('100644') ); + $file_attrs->set_amtime( 1700000000, 1700000100 ); + + my $dir_attrs = Net::SFTP::Foreign::Attributes->new; + $dir_attrs->set_perm( oct('040755') ); + + my @sftp_ls_output = ( + { + filename => 'QUOTES_413514.CEQ', + longname => '-rw-r--r-- 1 kohauser kohauser 1234 Nov 14 22:15 QUOTES_413514.CEQ', + a => $file_attrs, + }, + { + filename => 'incoming', + longname => 'drwxr-xr-x 2 kohauser kohauser 4096 Nov 14 22:15 incoming', + a => $dir_attrs, + }, + ); + + my $undef; + my $mock_sftp = Test::MockModule->new('Net::SFTP::Foreign'); + $mock_sftp->mock( 'ls', sub { return [@sftp_ls_output]; } ); + $mock_sftp->mock( 'error', sub { return $undef; } ); + $mock_sftp->mock( 'status', sub { return 0; } ); + $mock_sftp->mock( 'cwd', sub { return '/incoming/'; } ); + + # Pretend we are already connected so list_files() skips (re)connection + $transport->{connection} = bless {}, 'Net::SFTP::Foreign'; + $transport->{_user_set_directory} = 1; + + my $files = $transport->list_files(); + + is( ref($files), 'ARRAY', 'list_files() returns an arrayref' ); + is( scalar @{$files}, 2, 'both the file and the directory are returned' ); + + my ($file) = grep { $_->{filename} eq 'QUOTES_413514.CEQ' } @{$files}; + my ($dir) = grep { $_->{filename} eq 'incoming' } @{$files}; + + is( ref( $file->{a} ), '', 'nested Attributes object is not present in the returned hashref' ); + is( $file->{size}, 1234, 'size is flattened out of the Attributes object' ); + is( $file->{mtime}, 1700000100, 'mtime is flattened out of the Attributes object' ); + is( $file->{perms}, '0644', 'perms is flattened out of the Attributes object' ); + is( $file->{type}, 'file', 'regular file gets type "file"' ); + + ok( $dir, 'directory entry is present in the listing' ); + is( $dir->{type}, 'directory', 'directory gets type "directory"' ); + is( $dir->{perms}, '0755', 'directory perms are flattened too' ); + + $transport->{connection} = undef; + + $schema->storage->txn_rollback; }; 1;