root/tags/FuzzyOcr-3.5.1/FuzzyOcr.pm

# FuzzyOcr plugin, version 3.4
#
# written by Christian Holler (decoder_at_own-hero_dot_net)
#   and Jorge Valdes (jorge_at_joval_dot_info)

package FuzzyOcr;

use strict;
use warnings;
use Mail::SpamAssassin;
use Mail::SpamAssassin::Logger;
use Mail::SpamAssassin::Util;
use Mail::SpamAssassin::Timeout;
use Mail::SpamAssassin::Plugin;

use Time::HiRes qw( gettimeofday tv_interval );
use String::Approx 'adistr';
use FileHandle;
use Fcntl ':flock';
use POSIX;

use lib qw(/etc/mail/spamassassin); # Allow placing of FuzzyOcr in siteconfigdir

use FuzzyOcr::Logging qw(debuglog errorlog warnlog infolog);
use FuzzyOcr::Config qw(kill_pid
    get_tmpdir
    set_tmpdir
    get_all_tmpdirs
    get_pms
    save_pms
    get_timeout
    get_mysql_ddb
    get_scansets
    get_wordlist
    set_config
    get_config
    parse_config
    finish_parsing_end
    read_words);
use FuzzyOcr::Hashing qw(check_image_hash_db add_image_hash_db calc_image_hash);
use FuzzyOcr::Deanimate qw(deanimate);
use FuzzyOcr::Scoring qw(wrong_ctype wrong_extension corrupt_img known_img_hash);
use FuzzyOcr::Misc qw(max removedir removedirs save_execute);

our @ISA = qw(Mail::SpamAssassin::Plugin);

# constructor: register the eval rule
sub new {
    my ( $class, $mailsa ) = @_;
    $class = ref($class) || $class;
    my $self = $class->SUPER::new($mailsa);
    bless( $self, $class );
    $self->register_eval_rule("fuzzyocr_check");
    $self->register_eval_rule("dummy_check");
    $self->set_config($mailsa->{conf});
    return $self;
}

sub dummy_check {
    return 0;
}

sub fuzzyocr_check {
    my ( $self, $pms ) = @_;
    my $conf = get_config();

    save_pms($pms);

    my $end;
    my $begin = [gettimeofday];
    if ($conf->{focr_global_timeout}) {
        my $t = get_timeout();
        debuglog("Global Timeout set at ".$conf->{focr_timeout}." sec.");
        $t->run(sub {
            $end = fuzzyocr_do( $self, $conf, $pms );
        });
        if ($t->timed_out()) {
            infolog("Scan timed out after $conf->{focr_timeout} seconds.");
            infolog("Killing possibly running pid...");
            my ($ret, $pid) = kill_pid();
            if ($ret > 0) {
                    infolog("Successfully killed PID $pid");
            } elsif ($ret < 0) {
                infolog("No processes left... exiting");
            } else {
                infolog("Failed to kill PID $pid, stale process!");
            }
            infolog("Removing possibly leftover tempdirs...");
            removedirs(get_all_tmpdirs());
            return 0;
        }
    } else {
        $end = fuzzyocr_do( $self, $conf, $pms );
    }
    debuglog("Processed in ".
        sprintf("%.6f",tv_interval($begin, [gettimeofday]))
        ." sec.");
    return $end;
}

sub fuzzyocr_do {
    my ( $self, $conf, $pms ) = @_;

    my $internal_score = 0;
    my $current_score = $pms->get_score();
    my $score = $conf->{focr_autodisable_score} || 100;

    if ( $current_score > $score ) {
        infolog("Scan canceled, message has already more than $score points ($current_score).");
        return 0;
    }

    my $nscore = $conf->{focr_autodisable_negative_score} || -100;
    if ( $current_score < $nscore ) {
        infolog("Scan canceled, message has less than $nscore points ($current_score).");
        return 0;
    }

    my $imgdir;
    my %imgfiles = ();
    my @found    = ();
    my @hashes   = ();
    my $cnt      = 0;
    my $imgerr   = 0;
    my $main     = $self->{main};

    debuglog("Starting FuzzyOcr...");
    
    #Show PMS info if asked to
    if ($conf->{focr_log_pmsinfo}) {
        my $msgid = $pms->get('Message-Id') ? $pms->get('Message-Id') : "<no messageid>";
        my $from = $pms->get('From') ? $pms->get('From') : "<no sender>";
        my $to = $pms->get('To') ? $pms->get('To') : "<no receipients>";
        chomp($from, $to, $msgid);
        infolog("Processing Message with ID \"$msgid\" ($from -> $to)");
    }

    foreach my $p (
        $pms->{msg}->find_parts(qr(^image\b)i),
        $pms->{msg}->find_parts(qr(Application/Octet-Stream)i)
    ) {
        my $ctype = $p->{'type'};
        my $fname = $p->{'name'} || 'unknown';
        if (($fname eq 'unknown') and
            (defined $p->{'headers'}->{'content-id'})
            ){
            $fname = join('',@{$p->{'headers'}->{'content-id'}});
            $fname =~ s/[<>]//g;
            $fname =~ tr/\@\$\%\&/_/s;
        }

        my $filename = $fname; $filename =~ tr{a-zA-Z0-9\-.}{_}cs;
        debuglog("fname: \"$fname\" => \"$filename\"");
        my $pdata = $p->decode();
        my $pdatalen = length($pdata);
        my $w = 0; my $h = 0;

        if ( substr($pdata,0,3) eq "\x47\x49\x46" ) {
            ## GIF File
            $imgfiles{$filename}{ftype} = 1; 
            ($w,$h) = unpack("vv",substr($pdata,6,4));
            infolog("GIF: [${h}x${w}] $filename ($pdatalen)");
            $imgfiles{$filename}{width}  = $w;
            $imgfiles{$filename}{height} = $h;
        } elsif ( substr($pdata,0,2) eq "\xff\xd8" ) {
            ## JPEG File
            my @Markers = (0xC0,0xC1,0xC2,0xC3,0xC5,0xC6,0xC7,0xC9,0xCA,0xCB,0xCD,0xCE,0xCF);
            my $pos = 2;
            while ($pos < $pdatalen) {
                my ($b,$m) = unpack("CC",substr($pdata,$pos,2)); $pos += 2;
                if ($b != 0xff) {
                   infolog("Invalid JPEG image");
                   $pos = $pdatalen + 1;
                   last;
                }
                my $skip = 0;
                foreach my $mm (@Markers) {
                    if ($mm == $m) {
                        $skip++; last;
                    }
                }
                last if ($skip);
                $pos += unpack("n",substr($pdata,$pos,2));
            }
            if ($pos > $pdatalen) {
                errorlog("Cannot find image dimensions");
            } else {
                ($h,$w) = unpack("nn",substr($pdata,$pos+3,4));
                infolog("JPEG: [${h}x${w}] $filename ($pdatalen)");
                $imgfiles{$filename}{ftype} = 2;
                $imgfiles{$filename}{height} = $h;
                $imgfiles{$filename}{width}  = $w;
            }
        } elsif ( substr($pdata,0,4) eq "\x89\x50\x4e\x47" ) {
            # PNG File
            ($w,$h) = unpack("NN",substr($pdata,16,8));
            $imgfiles{$filename}{ftype}  = 3;
            $imgfiles{$filename}{width}  = $w;
            $imgfiles{$filename}{height} = $h;
            infolog("PNG: [${h}x${w}] $filename ($pdatalen)");
        } elsif ( substr($pdata,0,2) eq "BM" ) {
            ## BMP File
            ($w,$h) = unpack("VV",substr($pdata,18,8));
            $imgfiles{$filename}{ftype}  = 4;
            $imgfiles{$filename}{width}  = $w;
            $imgfiles{$filename}{height} = $h;
            infolog("BMP: [${h}x${w}] $filename ($pdatalen)");
        } elsif (
            ## TIFF File
            (substr($pdata,0,4) eq "\x4d\x4d\x00\x2a") or
            (substr($pdata,0,4) eq "\x49\x49\x2a\x00")
                ) {
            my $worder = (substr($pdata,0,2) eq "\x4d\x4d") ? 0 : 1;
            my $offset = unpack($worder?"V":"N",substr($pdata,4,4));
            my $number = unpack($worder?"v":"n",substr($pdata,$offset,2)) - 1;
            foreach my $n (0 .. $number) {
                my $add = 2 + ($n * 12);
                my ($id,$tag,$cnt,$val)  = unpack($worder?"vvVV":"nnNN",substr($pdata,$offset+$add,12));
                $h = $val if ($id == 256);
                $w = $val if ($id == 257);
                last if ($h != 0 and $w != 0);
            }
            infolog("TIFF: [${h}x${w}] $filename ($pdatalen) ($worder)");
            infolog("Cannot determine size of TIFF image, setting to '1x1'") if ($h == 0 and $w == 0);
            $imgfiles{$filename}{ftype}  = 5;
            $imgfiles{$filename}{width}  = $w ? $w : 1;
            $imgfiles{$filename}{height} = $h ? $h : 1;
        }

        #Skip unless we found the right header
        unless (defined $imgfiles{$filename}{ftype}) {
            infolog("Skipping file with content-type=\"$ctype\" name=\"$fname\"");
            delete $imgfiles{$filename};
            next;
        }

        #Skip images that cannot contain text
        if ($imgfiles{$filename}{height} < $conf->{focr_min_height}) {
            infolog("Skipping image: height < $conf->{focr_min_height}");
            delete $imgfiles{$filename};
            next;
        }

        #Skip images that cannot contain text
        if ($imgfiles{$filename}{width} < $conf->{focr_min_width}) {
            infolog("Skipping image: width < $conf->{focr_min_width}");
            delete $imgfiles{$filename};
            next;
        }

        #Skip too big images, screenshots etc
        if ($imgfiles{$filename}{height} > $conf->{focr_max_height}) {
            infolog("Skipping image: height > $conf->{focr_max_height}");
            delete $imgfiles{$filename};
            next;
        }

        #Skip too big images, screenshots etc
        if ($imgfiles{$filename}{width} > $conf->{focr_max_width}) {
            infolog("Skipping image: width > $conf->{focr_max_width}");
            delete $imgfiles{$filename};
            next;
        }

        #Found Image!! Get a temporary dir to save image
        $imgdir = Mail::SpamAssassin::Util::secure_tmpdir();
        unless ($imgdir) {
            errorlog("Scan canceled, cannot create Image TMPDIR.");
            return 0;
        }
        set_tmpdir($imgdir);

        #Generete unique filename to store image
        my $imgfilename = Mail::SpamAssassin::Util::untaint_file_path(
            $imgdir . "/" . $filename
        );
        my $unique = 0;
        while (-e $imgfilename) {
            $imgfilename = Mail::SpamAssassin::Util::untaint_file_path(
                $imgdir . "/" . chr(65+$unique) . "." . $filename
            );
            $unique++;
        }

        #Save important constants
        $imgfiles{$filename}{fname} = $fname;
        $imgfiles{$filename}{ctype} = $ctype;
        $imgfiles{$filename}{fsize} = $pdatalen;
        $imgfiles{$filename}{fpath} = $imgfilename;

        #Save Image to disk.
        unless (open PICT, ">$imgfilename") {
            errorlog("Cannot write \"$imgfilename\", skipping...");
            delete $imgfiles{$filename};
            removedir($imgdir);
            next;
        }
        binmode PICT;
        print PICT $pdata;
        close PICT;
        debuglog("Saved: $imgfilename");

        #Increment valid image file counter
        $cnt++;

        #keep raw email for debugging later
        my $rawfilename = $imgdir . "/raw.eml";
        if (open RAW, ">$rawfilename") {
            print RAW $pms->{msg}->get_pristine();
            close RAW;
            debuglog("Saved: $rawfilename");
        }

    }

    if ($cnt == 0) {
        debuglog("Skipping OCR, no image files found...");
        return 0;
    }
    infolog("Found: $cnt images"); $cnt = 0;
    if ($conf->{focr_enable_image_hashing} == 3) {
        $conf->{focr_mysql_ddb} = get_mysql_ddb();
    }

    # Try to load personal wordlist
    unless ($conf->{focr_no_homedirs}) {
        if ($conf->{focr_personal_wordlist} =~ m/^\//) {
            read_words( $conf->{focr_personal_wordlist} );
        } else {
            my $peruserlist = $main->sed_path($conf->{focr_personal_wordlist});
            if ( -r $peruserlist ) {
                read_words( $peruserlist );
            } else {
                # Only complain if the file exists
                if ( -e $peruserlist ) {
                    errorlog("Cannot read personal_wordlist: $peruserlist, skipping...");
                }
            }
        }
    }
    my $haserr;
    foreach my $filename (keys %imgfiles) {
        my $pic = $imgfiles{$filename};
        #infolog("Analyzing file with content-type=\"$$pic{ctype}\"");
        my @used_scansets = ();
        my $corrupt = 0;
        my $suffix = 0;
        my $generic_ctype = 0;
        my $digest;
        my $file  = $$pic{fpath};
        my $tfile = $file;
        my $pfile = $file . ".pnm";
        my $efile = $file . ".err";
        debuglog("pfile => $pfile");
        debuglog("efile => $efile");

        #Open ERRORLOG
        $haserr = $Mail::SpamAssassin::Logger::LOG_SA{level} == 3;

        if ($haserr) {
            $haserr = open RAWERR, ">$imgdir/raw.err";
            debuglog("Errors to: $imgdir/raw.err") if ($haserr>0);
        }

        my $mimetype = $$pic{ctype};
        if($mimetype =~ m'application/octet-stream'i) {
            $generic_ctype = 1;
        }

        if($$pic{fname} =~ /\.([\w-]+)$/) {
            $suffix = $1;
        }
        if ($suffix) {
            debuglog("File has Content-Type \"$mimetype\" and File Extension \"$suffix\"");
        } else {
            debuglog("File has Content-Type \"$mimetype\" and no File Extension");
        }

        if ( $$pic{ftype} == 1 ) {
            infolog("Found GIF header name=\"$$pic{fname}\"");
            if ($conf->{focr_skip_gif}) {
                infolog("Skipping image check");
                next;
            }
            if (defined($conf->{focr_max_size_gif}) and ($$pic{fsize} > $conf->{focr_max_size_gif})) {
                infolog("GIF file size ($$pic{fsize}) exceeds maximum file size for this format, skipping...");
                next;
            }

            if ( ($$pic{ctype} !~ /gif/i) and not $generic_ctype) {
                wrong_ctype( "GIF", $$pic{ctype} );
                $internal_score += $conf->{'focr_wrongctype_score'};
            }

            if ( $suffix and $suffix !~ /gif/i) {
                wrong_extension( "GIF", $suffix);
                $internal_score += $conf->{'focr_wrongext_score'};
            }

            my $interlaced_gif = 0;
            my $image_count = 0;

            foreach my $a (qw/gifsicle giftext giffix gifinter giftopnm/) {
                unless (defined $conf->{"focr_bin_$a"}) {
                    errorlog("Cannot exec $a, skipping image");
                    next;
                }
            }

            my @stderr_data;
            my ($retcode, @stdout_data) = save_execute(
                "$conf->{focr_bin_giftext} $file",
                undef,
                ">$imgdir/giftext.info",
                ">>$imgdir/giftext.err", 1);

            if ($retcode<0) { # only care if we timed out
                chomp $retcode;
                errorlog("$conf->{focr_bin_giftext} Timed out [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            }

            foreach (@stdout_data) {
                unless ($interlaced_gif) {
                    if ( $_ =~ /Image is Interlaced/i ) {
                        $interlaced_gif = 1;
                    }
                }
                if ( $_ =~ /^Image #/ ) {
                    $image_count++;
                }
            }
            if ($interlaced_gif or ($image_count > 1)) {
                infolog("Image is interlaced or animated...");
            }
            else {
                infolog("Image is single non-interlaced...");
                $tfile .= "-fixed.gif";
                printf RAWERR "## $conf->{focr_bin_giffix} $file >$tfile 2>>$efile\n" if ($haserr>0);

                $retcode = save_execute("$conf->{focr_bin_giffix} $file", undef, ">$tfile", ">>$efile");

                if ($retcode<0) { # only care if we timed out
                    chomp $retcode;
                    errorlog("$conf->{focr_bin_giffix}: Timed out [$retcode], skipping...");
                    printf RAWERR "?? Timed out > $retcode\n" if ($haserr>0);
                    ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
                }

                if (open ERR, $efile) {
                    @stderr_data = <ERR>;
                    close ERR;
                    foreach (@stderr_data) {
                        if ( $_ =~ /GIF-LIB error/i ) {
                            $corrupt = $_;
                            last;
                        }
                    }
                }
            }
            my $fixedsize = (stat($tfile))[7];
            if (defined($conf->{focr_max_size_gif}) and ($fixedsize > $conf->{focr_max_size_gif})) {
                infolog("Fixed GIF file size ($fixedsize) exceeds maximum file size for this format, skipping...");
                next;
            }

            if ($corrupt) {
                if ($interlaced_gif or ($image_count > 1)) {
                    infolog("Skipping corrupted interlaced image...");
                    corrupt_img($conf->{focr_corrupt_unfixable_score}, $corrupt);
                    $internal_score += $conf->{focr_corrupt_unfixable_score};
                    next;
                }
                if (-z $tfile) {
                    infolog("Uncorrectable corruption detected, skipping non-interlaced image...");
                    corrupt_img($conf->{focr_corrupt_unfixable_score}, $corrupt);
                    $internal_score += $conf->{focr_corrupt_unfixable_score};
                    next;
                }
                infolog("Image is corrupt, but seems fixable, continuing...");
                corrupt_img($conf->{focr_corrupt_score}, $corrupt);
                $internal_score += $conf->{focr_corrupt_score};
            }

            if ($image_count > 1) {
                infolog("File contains <$image_count> images, deanimating...");
                $tfile = deanimate($tfile);
            }

            if ($interlaced_gif) {
                infolog("Processing interlaced_gif $tfile...");
                my $cfile = $tfile;
                if ($tfile =~ m/\.gif$/i) {
                    $tfile =~ s/\.gif$/-fixed.gif/i;
                } else {
                    $tfile .= ".gif";
                }
                printf RAWERR qq(## $conf->{focr_bin_gifinter} $cfile >$tfile 2>>$efile\n) if ($haserr>0);
        
                $retcode = save_execute("$conf->{focr_bin_gifinter} $cfile", undef, ">$tfile", ">>$efile");

                if ($retcode<0) {
                    chomp $retcode;
                    printf RAWERR "?? Timed out > $retcode\n" if ($haserr>0);
                    errorlog("$conf->{focr_bin_gifinter}: Timed out [$retcode], skipping...");
                    ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
                } elsif ($retcode>0) {
                    chomp $retcode;
                    printf RAWERR "?? [$retcode] returned from $conf->{focr_bin_gifinter}\n" if ($haserr>0);
                    errorlog("$conf->{focr_bin_gifinter}: Returned [$retcode], skipping...");
                    ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
                }
            }

            printf RAWERR qq(## $conf->{focr_bin_giftopnm} $tfile >$pfile 2>>$efile\n) if ($haserr>0);

            $retcode = save_execute("$conf->{focr_bin_giftopnm} $tfile", undef, ">$pfile", ">>$efile");

            if ($retcode<0) {
                chomp $retcode;
                printf RAWERR "?? Timed out > $retcode\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_giftopnm}: Timed out [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            } elsif ($retcode>0) {
                chomp $retcode;
                printf RAWERR "?? [$retcode] returned from $conf->{focr_bin_giftopnm}\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_giftopnm}: Returned [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            }
        }
        elsif ( $$pic{ftype} == 2 ) {
            infolog("Found JPEG header name=\"$$pic{fname}\"");
            if ($conf->{focr_skip_jpeg}) {
                infolog("Skipping image check");
                next;
            }

            if (defined($conf->{focr_max_size_jpeg}) and ($$pic{fsize} > $conf->{focr_max_size_jpeg})) {
                infolog("JPEG file size ($$pic{fsize}) exceeds maximum file size for this format, skipping...");
                next;
            }
            if ( ($$pic{ctype} !~ /(jpeg|jpg)/i) and not $generic_ctype) {
                wrong_ctype( "JPEG", $$pic{ctype} );
                $internal_score += $conf->{'focr_wrongctype_score'};
            }

            if ( $suffix and $suffix !~ /(jpeg|jpg|jfif)/i) {
                wrong_extension( "JPEG", $suffix);
                $internal_score += $conf->{'focr_wrongext_score'};
            }

            foreach my $a (qw/jpegtopnm/) {
                unless (defined $conf->{"focr_bin_$a"}) {
                    errorlog("Cannot exec $a, skipping image");
                    next;
                }
            }
            printf RAWERR qq(## $conf->{focr_bin_jpegtopnm} $file >$pfile 2>>$efile\n) if ($haserr>0);
            my $retcode = save_execute("$conf->{focr_bin_jpegtopnm} $file", undef, ">$pfile", ">>$efile");

            if ($retcode<0) {
                chomp $retcode;
                printf RAWERR "?? Timed out > $retcode\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_jpegtopnm}: Timed out [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            } elsif ($retcode>0) {
                chomp $retcode;
                printf RAWERR "?? [$retcode] returned from $conf->{focr_bin_jpegtopnm}\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_jpegtopnm}: Returned [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            }
        }
        elsif ( $$pic{ftype} == 3 ) {
            infolog("Found PNG header name=\"$$pic{fname}\"");
            if ($conf->{focr_skip_png}) {
                infolog("Skipping image check");
                next;
            }
            if (defined($conf->{focr_max_size_png}) and ($$pic{fsize} > $conf->{focr__max_size_png})) {
                infolog("PNG file size ($$pic{fsize}) exceeds maximum file size for this format, skipping...");
                next;
            }
            if ( ($$pic{ctype} !~ /png/i) and not $generic_ctype) {
                wrong_ctype( "PNG", $$pic{ctype} );
                $internal_score += $conf->{'focr_wrongctype_score'};
            }
            if ( $suffix and $suffix !~ /(png)/i) {
                wrong_extension( "PNG", $suffix);
                $internal_score += $conf->{'focr_wrongext_score'};
            }
            foreach my $a (qw/pngtopnm/) {
                unless (defined $conf->{"focr_bin_$a"}) {
                    errorlog("Cannot exec $a, skipping image");
                    next;
                }
            }

            printf RAWERR qq(## $conf->{focr_bin_pngtopnm} $file >$pfile 2>>$efile\n) if ($haserr>0);
            my $retcode = save_execute("$conf->{focr_bin_pngtopnm} $file", undef, ">$pfile", ">>$efile");

            if ($retcode<0) {
                chomp $retcode;
                printf RAWERR "?? Timed out > $retcode\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_pngtopnm}: Timed out [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            } elsif ($retcode>0) {
                chomp $retcode;
                printf RAWERR "?? [$retcode] returned from $conf->{focr_bin_pngtopnm}\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_pngtopnm}: Returned [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            }
        }
        elsif ( $$pic{ftype} == 4 ) {
            infolog("Found BMP header name=\"$$pic{fname}\"");
            if ($conf->{focr_skip_bmp}) {
                infolog("Skipping image check");
                next;
            }
            if (defined($conf->{focr_max_size_bmp}) and ($$pic{fsize} > $conf->{focr_max_size_bmp})) {
                infolog("BMP file size ($$pic{fsize}) exceeds maximum file size for this format, skipping...");
                next;
            }
            if ( ($$pic{ctype} !~ /bmp/i) and not $generic_ctype) {
                wrong_ctype( "BMP", $$pic{ctype} );
                $internal_score += $conf->{'focr_wrongctype_score'};
            }
            if ( $suffix and $suffix !~ /(bmp)/i) {
                wrong_extension( "BMP", $suffix);
                $internal_score += $conf->{'focr_wrongext_score'};
            }
            foreach my $a (qw/bmptopnm/) {
                unless (defined $conf->{"focr_bin_$a"}) {
                    errorlog("Cannot exec $a, skipping image");
                    next;
                }
            }
            printf RAWERR qq(## $conf->{focr_bin_bmptopnm} $file >$pfile 2>>$efile\n) if ($haserr>0);

            my $retcode = save_execute("$conf->{focr_bin_bmptopnm} $file", undef, ">$pfile", ">>$efile");
            if ($retcode<0) {
                chomp $retcode;
                printf RAWERR "?? Timed out > $retcode\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_bmptopnm}: Timed out [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            } elsif ($retcode>0) {
                chomp $retcode;
                printf RAWERR "?? [$retcode] returned from $conf->{focr_bin_bmptopnm}\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_bmptopnm}: Returned [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            }
        }
        elsif ( $$pic{ftype} == 5 ) {
            infolog("Found TIFF header name=\"$$pic{fname}\"");
            if ($conf->{focr_skip_tiff}) {
                infolog("Skipping image check");
                next;
            }
            if (defined($conf->{focr_max_size_tiff}) and ($$pic{fsize} > $conf->{focr_max_size_tiff})) {
                infolog("TIFF file size ($$pic{fsize}) exceeds maximum file size for this format, skipping...");
                next;
            }
            if ( ($$pic{ctype} !~ /tif/i) and not $generic_ctype) {
                wrong_ctype( "TIFF", $$pic{ctype} );
                $internal_score += $conf->{'focr_wrongctype_score'};
            }
            if ( $suffix and $suffix !~ /tif/i) {
                wrong_extension( "TIFF", $suffix);
                $internal_score += $conf->{'focr_wrongext_score'};
            }

            foreach my $a (qw/tifftopnm/) {
                unless (defined $conf->{"focr_bin_$a"}) {
                    errorlog("Cannot exec $a, skipping image");
                    next;
                }
            }
            printf RAWERR qq(## $conf->{focr_bin_tifftopnm} $file >$pfile 2>>$efile\n) if ($haserr>0);
            my $retcode = save_execute("$conf->{focr_bin_tifftopnm} $file", undef, ">$pfile", ">>$efile");

            if ($retcode<0) {
                chomp $retcode;
                printf RAWERR "?? Timed out > $retcode\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_tifftopnm}: Timed out [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            } elsif ($retcode>0) {
                chomp $retcode;
                printf RAWERR "?? [$retcode] returned from $conf->{focr_bin_tifftopnm}\n" if ($haserr>0);
                errorlog("$conf->{focr_bin_tifftopnm}: Returned [$retcode], skipping...");
                ++$imgerr if $conf->{focr_keep_bad_images}>0; next;
            }
        }
        else {
            errorlog("Image type not recognized, unknown format. Skipping this image...");
            next;
        }

        if($conf->{focr_enable_image_hashing}) {
            infolog("Calculating image hash for: $pfile");
            ($corrupt, $digest) = calc_image_hash($pfile,$pic);
            if ($corrupt) {
                infolog("Error calculating the image hash, skipping hash check...");
            } else {
                my ($score, $dinfo, $whash);
                $whash = <