View | Details | Raw Unified | Return to bug 19512
Collapse All | Expand All

(-)a/Koha/Exceptions/File.pm (+51 lines)
Line 0 Link Here
1
package Koha::Exceptions::File;
2
3
use Modern::Perl;
4
5
use File::Basename;
6
7
use Koha::File;
8
9
use Koha::Exceptions;
10
11
use Exception::Class (
12
13
    'Koha::Exceptions::File' => {
14
        isa => 'Koha::Exceptions::Exception',
15
        description => 'Problem with a file',
16
        fields => ['path', 'stat'],
17
    },
18
);
19
20
=head2 throw
21
@OVERLOADS
22
23
Adds diagnostic information regarding the file with issues
24
25
=cut
26
27
sub throw {
28
    my ($self, %args) = @_;
29
    my @pwuid = getpwuid($<);
30
    my $realUser = $pwuid[0];
31
    @pwuid = getpwuid($>);
32
    my $effectiveUser = $pwuid[0];
33
34
    my $stat = 'File permissions:> ';
35
    if (-e $args{path}) {
36
        $stat .= Koha::File::getDiagnosticsString($args{path});
37
    }
38
    else {
39
        $stat .= "FILE NOT EXISTS.";
40
        my $parentDir = File::Basename::dirname($args{path});
41
        $stat .= " Parent directory '$parentDir' permissions:> ".(Koha::File::getDiagnosticsString(  $parentDir  ) || 'DIR NOT EXISTS');
42
    }
43
44
    $stat .= ", Real user:> $realUser, Effective user:> $effectiveUser";
45
    $args{stat} = $stat;
46
47
    $args{error} .= '. '.$stat;
48
    $self->SUPER::throw(%args);
49
}
50
51
1;
(-)a/Koha/File.pm (+53 lines)
Line 0 Link Here
1
package Koha::File;
2
3
use Modern::Perl;
4
5
use Fcntl;
6
7
=head1 SYNOPSIS
8
9
This package providers helper methods to work with files
10
Maybe even be a wrapper in Koha for working with files some day?
11
12
=cut
13
14
our @filetypes; #Save the translation table for filetypes for global access
15
$filetypes[Fcntl::S_IFDIR] = "d";
16
$filetypes[Fcntl::S_IFCHR] = "c";
17
$filetypes[Fcntl::S_IFBLK] = "b";
18
$filetypes[Fcntl::S_IFREG] = "-";
19
$filetypes[Fcntl::S_IFIFO] = "p";
20
$filetypes[Fcntl::S_IFLNK] = "l";
21
$filetypes[Fcntl::S_IFSOCK] = "s";
22
23
=head2 getDiagnostics
24
25
@PARAM1 String, path to a file
26
@RETURNS HASHRef, file properties in clear text.
27
         undef, if no such file found
28
@THROWS nothing, do not throw from here, especially not File-exceptions,
29
                 because this subroutine is used in File-exception diagnostics and could cause a circular recursion when no file is found.
30
31
=cut
32
33
sub getDiagnostics {
34
    my ($path) = @_;
35
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = lstat($path);
36
    return undef unless $dev; #No such file
37
38
    my %rv;
39
    $rv{user} =        getpwuid($uid);
40
    $rv{group} =       getgrgid($gid);
41
    $rv{permissions} = sprintf "%04o", Fcntl::S_IMODE($mode);
42
    $rv{filetype} =    $filetypes[ Fcntl::S_IFMT($mode) ];
43
44
    return \%rv;
45
}
46
47
our $diagnosticsStringFormat = '%s %s %s:%s';
48
sub getDiagnosticsString {
49
    my $stat = getDiagnostics(@_);
50
    return sprintf($diagnosticsStringFormat, $stat->{filetype}, $stat->{permissions}, $stat->{user}, $stat->{group});
51
}
52
53
1;
(-)a/t/Koha/Exceptions/File.t (+35 lines)
Line 0 Link Here
1
use Modern::Perl;
2
use Test::More;
3
4
use Try::Tiny;
5
use File::Basename;
6
7
use Koha::Exceptions::File;
8
9
#file diagnostics are more throughly tested in t/Koha/File.t
10
subtest "Catch File-exception and inspect diagnostics", \&getDiagnostics;
11
sub getDiagnostics {
12
    my $file = $ENV{KOHA_PATH}.'/kohaversion.pl';
13
    my $parentDir = File::Basename::dirname($file);
14
    try {
15
        Koha::Exceptions::File->throw(error => "error", path => $file);
16
        ok(0, "??Why no throw exception??");
17
    } catch { my $e = $_;
18
        ok($e->isa('Koha::Exceptions::File'), "Given the expected exception");
19
        like($e->stat, qr/^\w+/, "Then the file diagnostics look legit");
20
    };
21
22
    $file = $ENV{KOHA_PATH}.'/koha-aversion.pl';
23
    try {
24
        Koha::Exceptions::File->throw(error => "error", path => $file);
25
        ok(0, "??Why no throw exception??");
26
    } catch { my $e = $_;
27
        ok($e->isa('Koha::Exceptions::File'), "Given the expected exception");
28
        like($e->stat, qr/^\w+/, "Then the file diagnostics look legit");
29
        like($e->stat, qr/FILE NOT EXISTS/, "And file doesn't exist");
30
        like($e->stat, qr/Parent directory '$parentDir' permissions/, "And parent directory diagnostics delivered");
31
    };
32
}
33
34
35
done_testing;
(-)a/t/Koha/File.t (-1 / +38 lines)
Line 0 Link Here
0
- 
1
use Modern::Perl;
2
use Test::More;
3
4
use Koha::File;
5
6
subtest "Test file diagnostic", \&getDiagnostics;
7
sub getDiagnostics {
8
    _testDiagnostics($ENV{KOHA_PATH}.'/kohaversion.pl',   '-');
9
    _testDiagnostics($ENV{KOHA_PATH}.'/xt',               'd');
10
}
11
12
13
done_testing;
14
15
16
sub _testDiagnostics {
17
    my ($filepath, $expectedFiletype) = @_;
18
    my @expected = (
19
        $expectedFiletype,
20
        sprintf("%04o", ((lstat($filepath))[2] & 07777)), #$expectedPermissions,
21
        scalar(getpwuid((lstat($filepath))[4])),          #$expectedUser,
22
        scalar(getgrgid((lstat($filepath))[5])),          #$expectedGroup,
23
    );
24
25
    ok( my $diag = Koha::File::getDiagnostics($filepath),
26
       "Given file '$filepath' exists and diagnostics received");
27
    is( $diag->{user},  $expected[2],
28
       "Then file owner matches");
29
    is( $diag->{group}, $expected[3],
30
       "Then file group matches");
31
    is( $diag->{permissions}, $expected[1],
32
       "Then file permissions match");
33
    is( $diag->{filetype}, $expected[0],
34
       "Then filetype is $expected[0]");
35
36
    is(Koha::File::getDiagnosticsString($filepath), sprintf($Koha::File::diagnosticsStringFormat, @expected),
37
       "Then the diagnostic string matches");
38
}

Return to bug 19512