view release on metacpan or  search on metacpan

lib/App/BPOMUtils/RPO/Checker.pm  view on Meta::CPAN

our %SPEC;

our %argspec0plus_filenames = (
    filenames => {
        schema => ['array*', of=>'filename', 'x.perl.default_value_rules' => [['Path::filenames'=>{recurse=>1}]]],
        pos => 0,
        slurpy => 1,
    },
);

$SPEC{':package'} = {
    v => 1.1,
    summary => 'Various checker utilities to help with Processed Food Registration (RPO - Registrasi Pangan Olahan) at BPOM',
};

$SPEC{bpom_rpo_check_files} = {
    v => 1.1,
    summary => 'Check document files',
    description => <<'_',

By default will check all files in the current directory, recursively.

Here's what it checks:
- filename should not contain unsafe symbols
- file must not be larger than 5MB
- file must be readable
- type of file must be PDF or image (JPG), other types will generate warnings
- file's mime type and extension must match

_
    args => {
        %argspec0plus_filenames,
    },
};
sub bpom_rpo_check_files {
    require Cwd;
    require File::Basename;
    require File::MimeInfo::Magic;

    my %args = @_;

    my $i = 0;
    my @errors;
    my @warnings;
    my %symlinks; # key=abspath of symlink target, val=(first) link filename

  FILE:
    for my $filename (@{ $args{filenames} }) {
        $i++;
        log_info "[%d/%d] Processing file %s ...", $i, scalar(@{ $args{filenames} }), $filename
            unless $args{_no_log};
        my ($basename, $dirname, undef) = File::Basename::fileparse($filename);
        unless (-f $filename) {
            push @errors, {file=>$filename, message=>"File not found or not a regular file"};
            next;
        }

      CHECK_FILENAME: {
            if ($basename =~ /\.[^.]+\./) {
                push @errors, {file=>$filename, message=>"Filename contains multiple dots, currently uploadable but not viewable in ereg-rba"};
            }
            if ($basename =~ /[^A-Za-z0-9 _.-]/) {
                push @warnings, {file=>$filename, message=>"Filename contains symbols, should be avoided to ensure viewable in ereg-rba"};
            }
        }

      CHECK_READABILITY: {
            if (!-r($filename)) {
                push @errors, {file=>$filename, message=>"File cannot be read"};
                next FILE;
            }
        }

      CHECK_SYMLINK_TARGET: {
            if (-l $filename) {
                my $abs_target = File::Spec->rel2abs(readlink($filename), $dirname);
                log_trace "Symlink target (absolute): %s", $abs_target;
                unless ($abs_target) {
                    push @errors, {file=>$filename, message=>"Symlink target cannot be made absolute"}; # should not happen if we already check -f $file
                    next FILE;
                }
                if (defined $symlinks{$abs_target}) {
                    push @warnings, {file=>$filename, message=>"WARNING: Targets to the same file ($abs_target) as link $symlinks{$abs_target}, probably not what we want"}; # should not happen if we already check -f $file
                    next FILE;
                } else {
                    $symlinks{$abs_target} = $filename;
                }
            }
        } # CHECK_SYMLINK_TARGET

      CHECK_SIZE: {
            my $filesize = -s $filename;
            if ($filesize > 5*1024*1024) {
                push @errors, {file=>$filename, message=>"File size too large (>5M)"};
            }
        } # CHECK_SIZE

      CHECK_TYPE_AND_EXTENSION: {
            # because File::MimeInfo::Magic will report mime='inode/symlink' for symlink
            my $realfile = -l $filename ? readlink($filename) : $filename;
            my $mime_type = File::MimeInfo::Magic::mimetype($realfile);
            if ($mime_type eq 'image/jpeg') {
                push @errors, {file=>$filename, message=>"File type is JPEG but extension is not jpg/jpeg"}
                    unless $filename =~ /\.(jpe?g)$/i;
            } elsif ($mime_type eq 'image/gif') {
                push @errors, {file=>$filename, message=>"File type is GIF but extension is not gif"}
            } elsif ($mime_type eq 'image/x-ms-bmp') {
                push @errors, {file=>$filename, message=>"File type is BMP but extension is not bmp"}
                    unless $filename =~ /\.(bmp)$/i;
            } elsif ($mime_type eq 'application/pdf') {
                push @errors, {file=>$filename, message=>"File type is PDF but extension is not pdf"}
                    unless $filename =~ /\.(pdf)$/i;
            } else {
                push @errors, {file=>$filename, message=>"File type is not JPEG/GIF/BMP/PDF"};
            }

        } # CHECK_TYPE_AND_EXTENSION

    }