#!/usr/bin/perl
#<getperm: save owner, group, modtime, and permissions for files.

use Modern::Perl;
use Getopt::Long qw(GetOptions);
use Pod::Usage;
use File::Basename;
use Memoize;
use Readonly;

use subs qw(manpage myuuid usage version where);
local $ENV{'PATH'} = join ":",
  qw(/bin /usr/bin /usr/local/bin /opt/sfw/bin);

my $myname = basename($0);
$myname =~ s/\.\w*$//;    # strip any extension

# Command-line options.

my %options;
my @getopt_args = (
    'h|?',    # print usage
    'm',      # print manpage
    'u',      # print UUID
    'v',      # print version
    'w',      # print source location
    '0',      # use NUL-terminated input for weird filenames
    );

Getopt::Long::config("noignorecase", "bundling");
usage unless GetOptions(\%options, @getopt_args);

manpage   if $options{'m'};
myuuid    if $options{'u'};
version   if $options{'v'};
where     if $options{'w'};
usage     if $options{'h'};
$/ = "\0" if $options{'0'};

# Cache results from password/group file lookups.

my ($file, $mode, $uid, $usr, $gid, $grp, $mtime);

memoize('saveusr');
memoize('savegrp');

sub saveusr {
    my $u = shift;
    return getpwuid($u) || $u;
}

sub savegrp {
    my $g = shift;
    return getgrgid($g) || $g;
}

# Stat each file, print user-group-mode-modtime-filename.
# Skip the file if stat fails.

Readonly my $MODE => 2;    # see "perldoc -f stat"
Readonly my $UID  => 4;
Readonly my $GID  => 5;
Readonly my $MT   => 9;

# Sanity check the input; we're not expecting newline terminators if
# the -0 option is used.  Occasionally people will do stupid things like
# actually putting a newline in a filename, so make sure the filename
# length is legal just in case.
#
# We can's use setvbuf to limit the STDIN buffer size any more, so you
# might have to read all of stdin before you know the line's too long.

Readonly my $MAXPATHLEN => 1024;

while (<>) {
    chomp;

    if ($options{'0'}) {
        die "line $.: unexpected newlines; did you want the -0 option?\n"
          if /\n/ and length($_) > $MAXPATHLEN;
    }

    $file = $_;
    ($mode, $uid, $gid, $mtime) = (stat($file))[$MODE, $UID, $GID, $MT];

    if (defined $mode) {
        $usr = saveusr($uid);
        $grp = savegrp($gid);
        $mode &= oct(7777);

        # URL-encode the filename.  Do this inline since we do it a lot,
        # and the characters we encode aren't the same as URI::Escape.
        # Decode: $fname =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;
        $file =~ s/([^a-z0-9\/\-_.!~,()+])/sprintf "%%%02X", ord($1)/gei;

        printf "%s|%s|0%o|%d|%s\n", $usr, $grp, $mode, $mtime, $file;
    }
    else {
        warn "$file: stat failed: $!\n";
    }
}
exit(0);

#---------------------------------------------------------------------
# Print a usage message from the comments and exit.

sub usage {
    my ($emsg) = @_;
    use Pod::Usage qw(pod2usage);
    warn "$emsg\n" if defined $emsg;
    pod2usage(-verbose => 99, -sections => "NAME|SYNOPSIS|OPTIONS");
    return;
}

sub manpage {
    my @args = ("perldoc", "$0");
    exec {$args[0]} @args;    # safe even with one-arg list
    die("should not get here\n");
}

#---------------------------------------------------------------------
# Print the UUID, current version, or source location.

sub myuuid {
    my $UUID = $1
      if q$UUID: ad36ee74-654e-3e11-8566-49e1a8ca4dd2 $ =~ /UUID: (.*) /;
    print "$UUID\n";
    exit(0);
}

sub version {
    use version; our $VERSION = qv((qw$Revision: 2.5 $)[-1]);
    my $DATE = $1 if q$Date: 2023-11-18 19:48:13-05 $ =~ /Date: (.*) /;
    print "$myname $VERSION $DATE\n";
    exit(0);
}

sub where {
    my $SOURCE = $1
      if q$Source: /home/vogelke/bin/RCS/getperm,v $ =~ /Source: (.*) /;
    my $HOST = $1 if q$Host: furbag.my.domain $ =~ /Host: (.*) /;
    print "file://$HOST", "$SOURCE\n";
    exit(0);
}

#---------------------------------------------------------------------
__END__

=head1 NAME

getperm - save UID, GID, modtime and filemode for files

=head1 SYNOPSIS

getperm [-0hmuvw]

find . -print | getperm > /tmp/perm

find . -print0 | getperm -0 > /tmp/perm

=head1 OPTIONS

=over 4

=item B<-0>

Input lines are terminated by a null character instead of whitespace.

=item B<-h>

Print a brief help message and exit.

=item B<-m>

Print the manual page and exit.

=item B<-u>

Print the script UUID and exit.

=item B<-v>

Print the version and exit.

=item B<-w>

Print the canonical source location and exit.

=back

=head1 DESCRIPTION

B<getperm> will save owner and permissions settings for supplied files.
Intended for use with companion program B<setperm>.

Filenames can be URL-encoded to safely deal with character like spaces, etc.
that don't work and play nicely with Unix.  Do this inline since we do it
a lot; the characters encoded are a subset of those used in URI::Escape.

These characters are left alone:  A-Z a-z 0-9 / - _ . ! ~ , ( ) +

=head1 AUTHOR

 Karl Vogel <vogelke+unix@pobox.com>
 Array Information Technology

=cut