#!/usr/bin/perl

# Description: a small script to save attached files from emails (and do something)
# Author: Lilia <nursery at s8.xrea.com>
# License: Perl License
# Revision: 1.0.1
# Date: 2006-07-31 02:52:52 +09:00

use strict;
use warnings;

use MIME::Parser;  # see http://search.cpan.org/perldoc?MIME%3A%3AParser
use File::Compare;  # optional

use vars qw($Win32API_loaded);
BEGIN { # for Win32; see http://search.cpan.org/perldoc?Win32API%3A%3AFile%3A%3ATime
	$Win32API_loaded = 0;
	if($^O =~ /Win32/i) {
		eval q{ use Win32API::File::Time qw(:win);  1; }
			and $Win32API_loaded++;
	}
}

use constant {
	TIME       => time,
	EXCLUDE    => 1,
	COMPILED   => 1,
};

our($Script_Dir) = $0 =~ m#^(.*?)[/\\ ]*[^/\\ ]+$#;
$Script_Dir =~ s#\\#/#g;

# config
our $Cfg = {
	Store_Dir   => "$Script_Dir",  # directory to store files
	Temp_Dir    => "$Script_Dir/tmp",  # directory for output temp files
	File_RE     => [ qr/.+\.jpe?g$/i, 0, COMPILED ],  # regex, EXCLUDE (with exclusive pattern) or 0, COMPILED (using qr() operator) or 0
	Max_Parts   => 20,  # limits the number of MIME parts to be parsed; if set to -1, then no maximum limit is enforced
	Rmdir_Temp  => 1,  # rmdir empty Temp_Dir at the end
	Touch       => sub ($) { # touch each of the files; see a simpler func in this script: _touch()
		my $file_path = shift or return;
		my $r = 0;

		use Image::Info qw(image_info);  # to change file info based on Exif data; see http://search.cpan.org/perldoc?Image%3A%3AInfo

		my($file_name) = $file_path =~ m#([^/\\]+)$#;
		my $orig_time = 0;
		my $info = image_info($file_path);
		if($info->{DateTimeOriginal}) {
			$orig_time = date2time($info->{DateTimeOriginal});
		} elsif($file_name =~ /(\d\d)-(\d\d?)-(\d\d?)_(\d\d)-(\d\d)-?(\d\d)?/) { # an example (based on the file name)
			$orig_time = date2time(sprintf('%04d:%02d:%02d %02d:%02d:%02d', ($1 < 70 ? $1 +2000 : $1 +1900), $2, $3, $4, $5, ($6 ? $6 : 0)));
		}
		if($orig_time) {
			if($Win32API_loaded && defined &SetFileTime) {
				SetFileTime($file_path, TIME, $orig_time, $orig_time) and $r++;
			} else {
				utime(TIME, $orig_time, $file_path) and $r++;
			}
		}
		$r;  # return true or false
	},
	New_Name    => sub ($) { # rename each of the files; no rename if not defined
		my $file_path = shift;
		my($old_name) = $file_path =~ m"^.*/([^/]+)$";
		my($base,$ext) = $old_name =~ /^(.*)(\.[^\.]*)$/ ? ($1,$2) : ($old_name,'');
		my $new_name = $old_name;

		use Image::Info qw(image_info);  # to change file info based on Exif data

		my $orig_time = 0;
		my $info = image_info($file_path);
		if($info->{DateTimeOriginal} && $info->{DateTimeOriginal} =~ /^(\d\d\d\d)\D(\d\d?)\D(\d\d?)\D+(\d\d):(\d\d):(\d\d)/) {
#			$new_name = sprintf '%04d%02d%02d_%02d%02d%02d%s', $1, $2, $3, $4, $5, $6, $ext;
			$new_name = sprintf '%02d-%02d-%02d_%02d-%02d%s', substr($1, 2), $2, $3, $4, $5, $ext;
		} elsif($info->{Comment} && $info->{Comment} =~ /\D(\d\d\d\d)\D?(\d\d)\D?(\d\d)\D+(\d\d):(\d\d):(\d\d)/) {
			$new_name = sprintf '%02d-%02d-%02d_%02d-%02d%s', substr($1, 2), $2, $3, $4, $5, $ext;
#		} elsif($old_name =~ /(\d\d)-(\d\d?)-(\d\d?)_(\d\d)-(\d\d)-?(\d\d)?/) {
#			$new_name = sprintf '%04d%02d%02d_%02d%02d%02d%s', ($1 < 70 ? $1 +2000 : $1 +1900), $2, $3, $4, $5, ($6 ? $6 : 0), $ext;
		}
		$new_name;  # return new name
	},
};

our $Mail = shift;
die "Usage: $0 <file path>\n" unless defined $Mail;

local *touch = (defined $Cfg->{Touch}  && ref($Cfg->{Touch})  eq 'CODE') ? $Cfg->{Touch}  : \&_touch;
local *new_name = (defined $Cfg->{New_Name} && ref($Cfg->{New_Name}) eq 'CODE') ? $Cfg->{New_Name} : sub ($) { shift };
local *compare = (defined &compare) ? \&compare : sub { 1 };  # no compare, then the files are considered unequal

# do pre/post-process if defined
&pre_proc()  if defined &pre_proc;
&process();
&post_proc() if defined &post_proc;

#BEGIN { # debug
#	(my $error_log = $0) =~ s#[^/\\ ]+$#error.log#;
#	$error_log =~ s#\\#/#g;
#	use CGI::Carp qw(carpout);
#	open(my $eh, '>>', $error_log)
#		or die "Unable to open error.log: $!";
#	carpout($eh);
#}

#sub pre_proc {
#	# do something before &process
#}

#sub post_proc {
#	# do something after &process
#}

sub process {
	# directories prepared?
	-d $Cfg->{Store_Dir} or mkdir $Cfg->{Store_Dir}
		or die "Unable to mkdir $Cfg->{Store_Dir}: $!";
	-d $Cfg->{Temp_Dir}  or mkdir $Cfg->{Temp_Dir}
		or die "Unable to mkdir $Cfg->{Temp_Dir}: $!";

	my $parser = MIME::Parser->new();
	$parser->output_dir($Cfg->{Temp_Dir});
	$parser->max_parts($Cfg->{Max_Parts});

	# die a clean death
	local $SIG{__DIE__} = sub (@) {
		$parser->filer->purge;
		rmdir $Cfg->{Temp_Dir} if $Cfg->{Rmdir_Temp};
		die @_;
	};

	my $msg = eval { $parser->parse_open($Mail) };
	if(!$msg) { # parse failed
		die "Unable to parse $Mail: $@";
	} else {    # parse succeeded
		# move temp files to $Cfg->{Store_Dir}
		my($file_re,$re_x,$re_compiled) = @{$Cfg->{File_RE}} ? @{$Cfg->{File_RE}} : ('^\.', 1, 0);
		$file_re = qr/$file_re/ unless $re_compiled;
		opendir(my $dh, $Cfg->{Temp_Dir})
			or die "Unable to opendir $Cfg->{Temp_Dir}: $!";
		my @files;
		foreach(sort { lc($a) cmp lc($b) } grep { $re_x ? !/$file_re/ : /$file_re/ } readdir($dh)) {
			my $temp_name = $_;
			my $temp_path = "$Cfg->{Temp_Dir}/$_";
			next unless(-f $temp_path && -s _);


			my $store_path = $Cfg->{Store_Dir} . '/' . new_name($temp_path);
			my $store_path_orig = $store_path;
			my $i = 1;
			while(-f $store_path && compare($temp_path, $store_path)) { # $store_path already exists and the files are unequal
				$store_path = $store_path_orig;
				my($base,$ext) = $store_path =~ /^(.*)(\.[^\.]*)$/ ? ($1,$2) : ($store_path,'');
				$store_path =~ s/^\Q$base/${base}_$i/;
				$i++;
			}
			rename $temp_path => $store_path
				or die "Unable to rename $temp_path => $store_path: $!";

			touch($store_path)
				or die "Unable to set file times for $store_path: $!";
		}
		closedir($dh);
	}
	$parser->filer->purge;
	rmdir $Cfg->{Temp_Dir} if $Cfg->{Rmdir_Temp};  # rmdir temp directory if empty
} # process end

sub _touch($) {
	my $file_path = shift;
	utime TIME, TIME, $file_path;
} # _touch end

sub date2time($) { # converts "YYYY:MM:DD HH:MM:SS" into a UNIX timestamp
	require Time::Local;
	my $str = shift or return undef;
	my $time = -1;
	if($str =~ /^(\d\d\d\d)\D(\d\d?)\D(\d\d?)\D+(\d\d):(\d\d):(\d\d)/) {
		$time = Time::Local::timelocal($6, $5, $4, $3, $2 -1, $1 -1900);
		return ($time < 0) ? undef : $time;
	} else {
		return undef;
	}
} # date2time end

# End of script