view release on metacpan or  search on metacpan

lib/App/winmaildat2tar.pm  view on Meta::CPAN

package App::winmaildat2tar;

our $VERSION = "0.9902";

use v5.14;
use warnings;
use Pod::Usage;
use Getopt::EX::Long qw(:DEFAULT Configure ExConfigure);
ExConfigure BASECLASS => [ __PACKAGE__, "Getopt::EX" ];
Configure "bundling";

my $default_format = $0 =~ /2(\w+)$/ ? $1 : 'tar';

use Getopt::EX::Hashed; {
    has format  => 'f =s' , is => 'ro', default => $default_format;
    has verbose => 'v   ' , is => 'ro';

    has help    => 'h',
	action  => sub { pod2usage -verbose => 99, -sections => [ qw(SYNOPSIS VERSION) ] };
    has version => ' ',
	action  => sub { say $VERSION; exit };
}
no  Getopt::EX::Hashed;

sub run {
    (my $app, local @ARGV) = splice @_;
    $app->getopt or pod2usage();

    my $archive;

    @ARGV or usage();
    for my $file (@ARGV) {
	use Convert::TNEF;
	my $tnef = Convert::TNEF->read_in($file, { output_to_core => 'ALL' })
	    or die $Convert::TNEF::errstr;
	my @attachments = $tnef->attachments or do {
	    warn "$file: no attachment data\n";
	    next;
	};
	for my $ent (@attachments) {
	    my $name = $ent->longname // $ent->name // unknown();
	    warn "$name\n" if $app->verbose;
	    ($archive //= App::winmaildat2tar::Archive->new($app->format))
		->add($name, $ent->data);
	}
    }

    print $archive->write if $archive;

    exit;
}

sub unknown {
    my $seq = (state $_seq)++;
    sprintf "unknown%s.dat", $seq ? "_$seq" : "";
}

1;

######################################################################

package App::winmaildat2tar::Archive {
    use v5.14;
    use warnings;
    use Data::Dumper;

    use Moo; {
	has format  => ( is => 'ro', required => 1 );
	has archive => ( is => 'rw' );
	around BUILDARGS => sub {
	    my ($orig, $class, $format) = @_;
	    $format =~ s/^([a-z\d])([a-z\d]*)$/\u$1\L$2/i
		or die "$format: invalid format.\n";
	    $class->$orig(format => $format);
	};
	sub BUILD {
	    my($obj, $args) = @_;
	    my $class = ref $obj;
	    my $format = $obj->format;
	    my $subclass = "$class\::$format";
	    bless $obj, $subclass;
	    $obj->can('newarchive') or die "$format: unknown format.\n";
	    $obj->newarchive or die;
	}
    } no Moo;