File Coverage

bin/vcardtidy

Criterion	Covered	Total	%
statement	68	115	59.1
branch	13	36	36.1
condition	4	14	28.5
subroutine	10	12	83.3
pod			n/a
total	95	177	53.6

#!/usr/bin/env perl
use strict;
use warnings;
use OptArgs2;
use Path::Tiny;
use Text::vCard::Addressbook;
use Time::Piece;

our $VERSION = 'v1.1.0';

my $opts = optargs(
    comment => 'tidy (normalize) VCARD contact files',
    optargs => [
        files => {
            isa     => 'ArrayRef',
            default => sub {
                [ ( -t STDIN ) ? ( die OptArgs2::usage(__PACKAGE__) ) : '-' ]
            },
            greedy  => 1,
            comment => 'file to tidy (default is stdin)',
        },
        debug => {
            isa     => '--Flag',
            alias   => 'd',
            comment => 'output debugging information to STDERR',
        },
        regex => {
            isa      => '--ArrayRef',
            isa_name => 'REGEX',
            alias    => 'r',
            comment  => 'Regular expression to run against $_ first',
            default  => sub { [] },
        },
        force => {
            isa     => '--Flag',
            alias   => 'f',
            comment => 'insert missing fields where required',
        },
        no_rev => {
            isa     => '--Flag',
            alias   => 'R',
            comment => 'do not update REV value'
        },
        nothing => {
            isa     => '--Flag',
            alias   => 'n',
            comment => q{don't modify files, only report errors},
        },
        vcard_version => {
            isa     => '--Str',
            alias   => 'v',
            default => '4.0',
            comment => 'value for vCard VERSION field'
        },
        version => {
            isa     => '--Flag',
            alias   => 'V',
            comment => 'print version information and exit',
            trigger => sub {
                require File::Basename;
                die File::Basename::basename($0)
                  . ' version '
                  . $VERSION . "\n";
            },
        },
    ],
);

my $dtstamp = localtime->strftime('%Y-%m-%dT%H%M%SZ');

my $badcount = 0;
foreach my $f ( @{ $opts->{files} } ) {
    $opts->{input} = $f;
    vcardtidy($opts) || $badcount++;
}

die "vcardtidy failure count: $badcount\n" if $badcount;

sub vcardtidy {
    my $opts = shift;

    my $data;
    my $file;

    if ( $opts->{input} eq '-' ) {
        local $/;
        binmode STDIN, ':raw:encoding(UTF-8)';
        $data = ;
    }
    else {
        $file = path( $opts->{input} );
        $data = $file->slurp( { binmode => ':raw:encoding(UTF-8)' } );
    }

    my $filtered = $data;
    foreach my $user_re ( @{ $opts->{regex} } ) {
        use experimental 're_strict';
        use re 'strict';

        print STDERR "Regex: $user_re\n" if $opts->{debug};
        my $old = $filtered;
        eval {
            local $SIG{ALRM} = sub { die "Timeout\n" };
            alarm 1;
            eval "\$filtered =~ $user_re";
            die $@ if $@;
            alarm 0;
        };

        die "Regex failed: $user_re:" . $@ if $@;
        _diff( $old, $filtered )           if $opts->{debug};
    }

    my $ab =
      eval { Text::vCard::Addressbook->new( { 'source_text' => $filtered } ); };

    if ($@) {
        warn "$opts->{input}: $@";
        return 0;
    }

    my @vcards = $ab->vcards;
    if ( 0 == @vcards ) {
        warn "$opts->{input}: No cards to tidy!\n";
        return 1;    # not considered an error. TODO If '-' then print?
    }

    foreach my $vcard (@vcards) {
        my $i = 0;
        my $u = $vcard->get_simple_type('UID') // do {
            use feature 'state';
            state @c     = ( 'a' .. 'f', 0 .. 9 );
            state $len_c = scalar @c;
            my $uid = join '-', map {
                join '',
                  map { $c[ rand($len_c) ] }
                  @$_
            } [ 1 .. 8 ], [ 1 .. 4 ], [ 1 .. 4 ], [ 1 .. 4 ], [ 1 .. 12 ];

            $vcard->add_node( { 'node_type' => 'UID', } )->value($uid);
            warn qq/$opts->{input}: VCARD $i missing UID (set to "$uid")\n/;
            $uid;
        };
        $u =~ s/-.*//;

        if ( not $vcard->get('FN') ) {
            if ( $opts->{force} ) {
                $vcard->fn($u);
                warn
                  qq/$opts->{input}: VCARD $i missing FN field (set to "$u")\n/;
            }
            else {
                warn qq/$opts->{input}: VCARD $i missing FN field!\n/;
                return 0;
            }
        }

        if ( not $vcard->get('N') ) {
            if ( $opts->{force} ) {
                $vcard->add_node(
                    {
                        'node_type' => 'N',
                        data        => [ { value => $u . ';;;;' } ]
                    }
                );
                warn
                  qq/$opts->{input}: VCARD $i missing N type (set to "$u")\n/;
            }
            else {
                warn qq/$opts->{input}: VCARD $i missing N field!\n/;
                return 0;
            }
        }

        my $v = $vcard->version;
        if ( not length $v ) {
            $vcard->version( $opts->{vcard_version} );
            warn qq/$opts->{input}: VCARD $i missing VERSION /
              . qq/(set to "$opts->{vcard_version}")\n/;
        }
        elsif ( $v ne $opts->{vcard_version} and $opts->{force} ) {
            $vcard->version( $opts->{vcard_version} );
            warn qq/$opts->{input}: forcing VCARD $i VERSION /
              . qq/to $opts->{vcard_version}\n/;
        }

        $vcard->REV($dtstamp) unless $opts->{no_rev};
        $vcard->PRODID("vcardtidy $VERSION");

        $i++;
    }

    # Remove duplicate fields
    my $prev = '';
    my $seen;
    my $tidy = join '', map {
        $seen = $_ eq $prev;
        $prev = $_;
        $seen ? () : $_ . "\x0D\x0A"
    } split "\x0D\x0A", $ab->export;

    # Fix for multiple categories
    while ( $tidy =~ s/^(CATEGORIES:.*?)\\,/$1,/mg ) { }

    if ( $opts->{debug} ) {
        print STDERR "vcardtidy:\n";
        _diff( $data, $tidy );
    }

    if ( $opts->{input} eq '-' ) {
        binmode STDOUT, ':raw:encoding(UTF-8)';
        print $tidy;
    }
    else {
        my $data2 = $data;
        $data2 =~ s/^REV:.*\015\012//m;
        $data2 =~ s/^PRODID:.*\015\012//m;

        my $tidy2 = $tidy;
        $tidy2 =~ s/^REV:.*\015\012//m;
        $tidy2 =~ s/^PRODID:.*\015\012//m;

        $file->spew( { binmode => ':raw:encoding(UTF-8)' }, $tidy )
          unless $opts->{nothing}
          or ( $data2 eq $tidy2 and not $opts->{force} );
    }

    1;
}

sub _diff {
    my ( $t1, $t2 ) = @_;
    require Text::Diff;
    print STDERR ( Text::Diff::diff( \$t1, \$t2 ) || "(No change)\n" ) =~
      s/^/    /gmr;
}

__END__