whereFrom

#!/usr/bin/env perl -w
#
# whereFrom
# 2013-03-16: Written by Steven J. DeRose.
#
use strict;
use Getopt::Long;

use sjdUtils;
use alogging;

our %metadata = (
    'title'        => "whereFrom",
    'description'  => "",
    'rightsHolder' => "Steven J. DeRose",
    'creator'      => "http://viaf.org/viaf/50334488",
    'type'         => "http://purl.org/dc/dcmitype/Software",
    'language'     => "Perl 5.18",
    'created'      => "2013-03-16",
    'modified'     => "2021-09-15",
    'publisher'    => "http://github.com/sderose",
    'license'      => "https://creativecommons.org/licenses/by-sa/3.0/"
);
our $VERSION_DATE = $metadata{'modified'};


=pod


=head1 Usage

whereFrom [options] files

Diplay the extended attribute with the source URI for a file
on MacOSX, and optionally rename to include some of it.

With I<--pull n>, rename the files to include the last I<n>+1
components of the source URI. For example, I<--pull 2> would rename a file
called F<8-1.txt> (presumably the "-1" was added by Finder to avoid
a name conflict), that was downloaded from

    http://www.example.com/pics/friends/john/8.jpg

to

    friends_john_8.jpg

With I<--webdir>, instead of path components from the URI
being incorporated directly into the filename, they are used as a local
path that the file is moved to (directories are created if needed). So the
file in the previous example would end up in

    ./friends/john/8.jpg

B<Note>: The source is extracted via:

    xattr -p com.apple.metadata:kMDItemWhereFroms [file]


=head1 Options

(prefix 'no' to negate where applicable)

=over

=item * B<--pull> I<n>

Rename the file(s) by pulling down I<n> of the containing directory names
from the source URI (see under Usage). The directories will be separated
by "~" instead of "/" so as not to confuse the file system ("~" is not
allowed in URIs, so should not cause conflicts).
See also I<--test> and I<--separator>.

=item * B<--quiet> OR B<-q>
Suppress most messages.

=item * B<--recursive>

Do the whole directory subtree of each arg.

=item * B<--separator> I<s>

Use I<s> instead of the default "~", to separate ancestor directory names
when using I<--pull>.

=item * B<--test>

Don't actually do the renaming with I<--pull>. Just show what it would do.

=item * B<--verbose> OR B<-v>
Add more messages (repeatable).

=item * B<--version>

Show version info and exit.

=item * B<--webdir> I<path>

After retrieving the source URI (when available), move the file into a
directory mirroring the path described in the URI. The I<path> given for
this option is treated as the starting point, and will contain a
subdirectory for each domain, which in turn will contain the directories
and files indicated in the URIs for the files from there. For example, with
I<--webdir '/webStuff'>,

    http://www.example.com/pics/friends/john/8.jpg

would end up in:

    /webStuff/www.example.com/pics/friends/john/8.jpg

=back


=head1 Known Bugs and Limitations

With I<--pull>, moves files to current directory too, which may not be
what you want.

Doesn't know about non-"/" directory separators.

"~" may not be the best default separator.


=head1 Related commands

C<renameFiles> does general file renaming. It has a I<--pullURI> option which
works like the I<--pull> option here.


=head1 To do

  Only do rename if name =~ m/^[-_ \d]+\.\w*$/


=head1 History

  2013-03-16: Written by Steven J. DeRose.
  2014-02-35: Clean up.
  2021-09-16: New layout.
  

=head1 Ownership

This work by Steven J. DeRose is licensed under a Creative Commons
Attribution-Share Alike 3.0 Unported License. For further information on
this license, see http://creativecommons.org/licenses/by-sa/3.0/.

For the most recent version, see http://www.derose.net/steve/utilities/.

=cut


###############################################################################
# Options
#
my $pull          = 0;
my $quiet         = 0;
my $recursive     = 0;
my $separator     = '~';
my $test          = 0;
my $verbose       = 0;
my $webdir        = "";
my $xattrName     = 'com.apple.metadata:kMDItemWhereFroms';

my %getoptHash = (
    "h|help"                  => sub { system "perldoc $0"; exit; },
    "pull=i"                  => \$pull,
    "quiet!"                  => \$quiet,
    "recursive!"              => \$recursive,
    "separator=s"             => \$separator,
    "test!"                   => \$test,
    "v+"                      => \$verbose,
    "version"                 => sub {
        die "Version of $VERSION_DATE, by Steven J. DeRose.\n";
    },
    "webdir=s"                => \$webdir,
    );
Getopt::Long::Configure ("ignore_case");
GetOptions(%getoptHash) || die "Bad options.\n";

($pull && $webdir) && die
    "Can't use -pull and -webdir together.\n";


###############################################################################
# Main
#
my $nNoWhereFrom  = 0;
my $nMkdir        = 0;
my $nRename       = 0;
my $nDirs         = 0;
my $nRenamed      = 0;

(scalar(@ARGV)) || die "No file(s) specified.\n";

while (my $arg = shift) {
    ($verbose) && warn "*** $arg\n";
    doOneItem($arg);
}

if (!$quiet) {
    printf("Files lacking WhereFrom data: %6d\n", $nNoWhereFrom);
    if ($pull>0) {
        printf("Files successfully renamed:   %6d\n", $nRenamed);
        printf("File-renames failed:          %6d\n", $nRename);
    }
    ($webdir) &&
        printf("mkdirs failed:                %6d\n", $nMkdir);
    printf("Directories encountered:      %6d\n", $nDirs);
}

exit;


###############################################################################
#
sub doOneItem {
    my ($item) = @_;
    if (-d $item) {
        $nDirs++;
        if ($recursive) {
            ($verbose) && warn "Opening dir '$item'\n";
            if (!opendir(DIR, $item)) {
                warn "*** opendir failed.\n";;
                return;
            }
            while (my $name = readdir(DIR)) {
                next if (substr($name,0,1) eq ".");
                doOneItem("$item/$name");
            }
            closedir(DIR);
        }
    }
    elsif (-f $item) {
        my $uri = doOneFile($item);
        if (!$uri) {
            $nNoWhereFrom++;
            return;
        }
        elsif ($pull > 0) {
            $uri =~ s/^(\w+:\/\/)//;
            my $scheme = $1 || "";
            my @parts = split(/\//, $uri);
            while (scalar(@parts)>$pull+1) {
                shift @parts;
            }
            my $newName = join($separator, @parts);
            ($quiet) || print "" . ($test ? "Test: ":"") . "$item\n    $newName\n";
            if (!$test) {
                if (!rename($item, $newName)) {
                    print "Failed to move $item to $newName\n";
                    $nRename++;
                }
                else {
                    $nRenamed++;
                }
            }
        } # pull
        elsif ($webdir) {
            $uri =~ s/^(\w+:\/\/)//;
            my $scheme = $1 || "";
            my @parts = split(/\//, $uri);
            my $newName = pop @parts;
            my $path = $webdir . "/" . join("/", @parts);
            ($quiet) || print "" . ($test ? "Test: ":"") .
                "$item\n    $path/$newName\n";
            return if ($test); ### -test ####
            if (!-d $path) {
                system "mkdir -p $path";
                if (!-d $path) {
                    warn "mkdir -p $path FAILED.\n";
                    $nMkdir++;
                    return;
                }
            }
            if (!rename($item, "$path/$newName")) {
                print "Failed to move $item to $path/$newName\n";
                $nRename++;
            }
            else {
                $nRenamed++;
            }
        } # webdir
    } # -f
    else {
        ($quiet) || warn "Skipped non -f file '$item'.\n";
    }
} # doOneItem

sub doOneFile {
    my ($file) = @_;
    print "$file\n";
    my $cmd = "xattr -p $xattrName '$file' 2>/dev/null";
    my $val = `$cmd` || "";
    if (!$val) {
    	($quiet) || print
	        "    xattr -p com.apple.metadata:kMDItemWhereFroms failed.\n";
	    return("");
    }

    if (" $val" =~ m/^(\s[0-9A-F][0-9A-F])+\s*$/s) {
        my $vstr = x2str($val);
        $vstr =~ s/^bplist.......(.)//;
        my $len = ord($1);
        my $uri = substr($vstr,0,$len);
        ($quiet) || print "    $uri\n";
        if ($verbose) {
            print "    Raw: [\n$val']\n";
            print "    Length: $len\n";
            print "    Rest: '" . substr($vstr,$len) . "'\n";
        }
        return($uri);
    }
    ($quiet) || print "    Unexpected format: Raw: [\n$val\n]\n";
    return("");
}


sub x2str { # Doesn't handle utf8 or ucs2
    my ($s) = @_;
    my $buf = "";
    while ($s =~ m/\s*([0-9a-f][0-9a-f])/ig) {
    	my $c = chr(hex("0x".$1));
        $buf .= $c;
    }
    return($buf);
}

sub x2int {
    my ($s) = @_;
    return(hex("0x".$s));
}