#!/usr/bin/perl -w

use strict;
use Config;
use Getopt::Long;
use Pod::Usage;
use Data::UUID;
use File::Basename;
use Time::HiRes qw/gettimeofday usleep/;
use POSIX qw/strftime/;
use URI::Split qw/uri_join uri_split/;

use subs qw/doargs docount dodate dofiles dostdin
  dotest dotiny manpage usage version where/;

$ENV{'PATH'} = join ":", qw(/bin /usr/bin /usr/local/bin /opt/sfw/bin);

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

my $count   = 0;
my $fflag   = 0;
my $tflag   = 0;
my $verbose = 0;

my %options;
my @getopt_args = (
    'b',             # base-64 date UUID
    'c=i',           # count of UUIDs to make
    'd',             # date UUID
    'f',             # UUID for file(s)
    'h|?',           # print usage
    'm',             # print manpage
    's',             # make UUID from stdin
    't',             # short series of tests
    'u',             # make UUID from URI
    'v',             # print version
    'V',             # verbose - print source of UUID
    'w',             # print source location
    );

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

$verbose++  if $options{'V'};
$fflag++    if $options{'f'};
usage()     if $options{'h'};
manpage()   if $options{'m'};
dostdin()   if $options{'s'};
$tflag++    if $options{'t'};
version()   if $options{'v'};
where()     if $options{'w'};

dob64date($verbose) if $options{'b'};
dodate($verbose)    if $options{'d'};

if ($options{'c'}) {
    $count = $options{'c'};
    usage("count must be >= 0") unless $count > 0;
    docount($verbose, $count);
}

if ($options{'u'}) {
    usage("I need a URI") unless @ARGV;
    dotiny($verbose, @ARGV);
}

if (@ARGV) {
    if ($fflag) {
        dofiles(@ARGV);
    }
    else {
        doargs(@ARGV);
    }
}
else {
    if ($tflag) {
        dotest();
    }
    else {
        docount($verbose, 1);
    }
}

exit(0);

#---------------------------------------------------------------------
# Print UUID for each string.

sub doargs {
    my $ug = new Data::UUID;
    my $uuid;

    foreach (@_) {
        $uuid = lc($ug->create_from_name_str(NameSpace_URL, $_));
        print "$uuid <- $_\n";
    }
    1;
}

#---------------------------------------------------------------------
# Print UUID for each file.

sub dofiles {
    my $ug = new Data::UUID;
    my ($uuid, $s, $fh);

    foreach (@_) {
        if (open($fh, "< $_")) {
            undef $/;
            $s = <$fh>;
            close($fh);
            $uuid = lc($ug->create_from_name_str(NameSpace_URL, $s));
            print "$uuid <- $_\n";
        }
        else {
            warn "$_: cannot read: $!\n";
        }
    }
    1;
}

#---------------------------------------------------------------------
# Print series of UUIDs based on time and process ID.

sub docount {
    my ($verbose, $count) = @_;
    my (@lt, $sec, $usec, $ts, $uuid);
    my $ug = new Data::UUID;
    my $hn = $Config{'myhostname'};

    while ($count--) {
        ($sec, $usec) = gettimeofday();
        @lt = localtime($sec);
        $ts = strftime("%Y-%m-%d %T.", @lt)
            . sprintf("%-6.6d.", $usec) . $$ . ".$hn";

        $uuid = lc($ug->create_from_name_str(NameSpace_URL, $ts));
        print "$uuid";
        print $verbose ? " <- $ts\n": "\n";
    }

    exit(0);
}

#---------------------------------------------------------------------
# Print UUID for stdin.

sub dostdin {
    my $ug = new Data::UUID;
    my $s;
    my $uuid;

    if (-f STDIN || -p STDIN) {
        undef $/;
        $s = <STDIN>;
        $uuid = lc($ug->create_from_name_str(NameSpace_URL, $s));
        print "$uuid\n";
    }
    else {
        warn "found nothing on stdin\n";
    }
    exit(0);
}

#---------------------------------------------------------------------
# Print a small set of tests.

sub dotest {
    my $ug = new Data::UUID;
    my $s;
    my $uuid;

    print "BASIC TESTS:\n";
    $uuid = lc($ug->create_str());
    print "$uuid <- create\n";

    $s = "0123456789abcdefghijklmnopqrstuvwxyz";
    $uuid = lc($ug->create_from_name_str(NameSpace_URL, $s));
    print "$uuid <- $s\n";

    $s = scalar localtime(time());
    $uuid = lc($ug->create_from_name_str(NameSpace_URL, $s));
    print "$uuid <- $s\n";

    $s = "www.mycompany.com";
    $uuid = lc($ug->create_from_name_str(NameSpace_URL, $s));
    print "$uuid <- $s\n";

    $uuid = lc($ug->create_str());
    print "$uuid <- create\n";
    1;
}

#---------------------------------------------------------------------
# Print tiny url for each URL using part of UUID.

sub dotiny {
    my $ug = new Data::UUID;
    my $uuid;
    my ($uri, $scheme, $host, $path, $query, $frag);
    my $verbose = shift;

    foreach (@_) {

        # strip trailing slashes for consistency; they're included
        # in the parsed URI if found, and we don't want a tiny URL
        # to change depending on a trailing slash.
        s!//*$!!g;

        ($scheme, $host, $path, $query, $frag) = uri_split($_);

        if (defined($scheme) && defined($host) && length($path)) {
            $uuid = lc($ug->create_from_name_str(NameSpace_URL, $_));
            $path = '/tiny/' . substr($uuid, 0, 6);
            $uri = uri_join($scheme, $host, $path);
            print "$uri";
            print $verbose ? " <- $_\n": "\n";
        }
        elsif (defined($scheme) && defined($host)) {
            print STDERR "$_: no tiny URL needed.\n";
        }
        else {
            print STDERR "$_: not a URI.\n";
        }
    }

    exit(0);
}

#---------------------------------------------------------------------
# Print Base-64 UUID for current date/time.
#            regular base-64 alphabet: [A-Za-z0-9+/=]
#    filesystem-safe base-64 alphabet: [A-Za-z0-9+.=]

sub dob64date {
    my $verbose = shift;
    my $ug = new Data::UUID;
    my ($sec, $usec) = gettimeofday();
    my @lt = localtime($sec);
    my $ts = strftime("%Y-%m-%d %T.", @lt) . sprintf("%-6.6d", $usec);
    $_ = $ug->create_from_name_b64(NameSpace_URL, $ts);
    tr!/!.!;
    print "$_";
    print $verbose ? " <- $ts\n": "\n";
    exit(0);
}

#---------------------------------------------------------------------
# Print UUID for current date/time.

sub dodate {
    my $verbose = shift;
    my $ug = new Data::UUID;
    my ($sec, $usec) = gettimeofday();
    my @lt = localtime($sec);
    my $ts = strftime("%Y-%m-%d %T.", @lt) . sprintf("%-6.6d", $usec);
    $_ = lc($ug->create_from_name_str(NameSpace_URL, $ts));
    print "$_";
    print $verbose ? " <- $ts\n": "\n";
    exit(0);
}

#---------------------------------------------------------------------
# Print a usage message from the comment header and exit.

sub usage {
    my ($emsg) = @_;

    use Pod::Usage qw(pod2usage);
    warn "$emsg\n" if defined $emsg;
    pod2usage(-verbose => 99, -sections => "NAME|SYNOPSIS|OPTIONS");
    exit(0);
}

sub manpage {
    use Pod::Man();

    my $parser = Pod::Man->new();
    open(STDOUT, "| groff -T ascii -man | gcat -s | less") || die "groff\n";
    $parser->parse_from_file($0);

    close STDOUT || die "$myname: can't close stdout: $!\n";
    $? = 1 if $? == 255;    # from die
    exit($?);
}

#---------------------------------------------------------------------
# Print the current version and source location.

sub version {
    my $VERSION = sprintf("%d.%02d", q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/);
    my $DATE =
      sprintf("%s", q$Date: 2009/06/15 00:45:51 $ =~ /Date: (.*) /);
    print "$myname $VERSION $DATE\n";
    exit(0);
}

sub where {
    my $SOURCE = sprintf("%s",
      q$Source: /home/vogelke/bin/RCS/uuid,v $ =~ /Source: (.*) /);
    print "$SOURCE\n";
    exit(0);
}

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

=head1 NAME

uuid - generates UUIDs

=head1 SYNOPSIS

uuid [-cn] [-bdstuvV] [str ...]

uuid -f file [file ...]

=head1 DESCRIPTION

Generated UUIDs based on dates, URIs, file contents, or string contents.
The default UUID generated is based on time to the microsecond and the
process ID.

=head1 OPTIONS

=over 4

=item B<-b>

creates a Base-64 UUID based on the time only.

=item B<-c>n

creates N different UUIDs based on time to the microsecond and the
process ID.

=item B<-d>

creates a UUID based on the time only.

=item B<-f>

prints UUIDs for one or more files.

=item B<-s>

prints UUID based on stdin.

=item B<-t>

prints test cases.

=item B<-u> URI

prints tiny URLs using part of a UUID.

=item B<-v>

prints the version and exits.

=item B<-V>

verbose - prints source of UUID as well as the UUID itself.

=item B<str>

is a string used to generate a UUID.

=back

=head1 EXAMPLE

 me% uuid
 af16eecc-237a-31f6-a1cb-cf9bc3b69f2a

 me% uuid -V
 af16eecc-237a-31f6-a1cb-cf9bc3b69f2a <- 2008-04-03 14:36:39.196506.900.host

 me% uuid -c5 -V
 102e0263-4850-386f-8bcc-43664b85ad9f <- 2008-04-03 14:37:13.203598.907.host
 8e588153-bbd7-35f6-8bdb-abfe77415256 <- 2008-04-03 14:37:13.204346.907.host
 9939f302-0713-36b4-9dc1-cffe2c3fbe27 <- 2008-04-03 14:37:13.204457.907.host
 fdd29b1e-fda4-341a-a2ce-78fa01bc74d1 <- 2008-04-03 14:37:13.204544.907.host
 a7bc4193-2662-36ce-a7b3-17f6170bda08 <- 2008-04-03 14:37:13.204627.907.host

 me% uuid -uV http://www.iana.org/test/urn-namespaces
 http://www.iana.org/tiny/6b99bd <- http://www.iana.org/test/urn-namespaces

 me% uuid -u http://www.iana.org/test/urn-namespaces
 http://www.iana.org/tiny/6b99bd

 me% uuid -u http://www.iana.org/test/urn-namespaces/
 http://www.iana.org/tiny/6b99bd

 me% uuid -u http://www.iana.org/test/urn-namespaces///
 http://www.iana.org/tiny/6b99bd

 me% uuid -uV http://www.w3.org/Addressing/
 http://www.w3.org/tiny/7dffa6 <- http://www.w3.org/Addressing

 me% uuid -u http://www.w3.org
 http://www.w3.org: no tiny URL needed.

 me% uuid -u junk
 junk: not a URI.
 
 me% uuid -t
 df2a5842-ec1b-11d9-a868-e5d27932fd30 <- create
 19df3967-42be-3652-98a8-6100992dcee4 <- 0123456789abcdefghijklmnopqrstuvwxyz
 d7788411-ef61-3e67-bc52-eaae2d89c0d1 <- Thu Apr 3 14:36:39 2008
 5e9eb78a-6a64-303e-a122-23903d7e9183 <- www.mycompany.com
 df2a6d14-ec1b-11d9-a868-e5d27932fd30 <- create

=head1 AUTHOR

 Karl Vogel <vogelke@pobox.com>
 Sumaria Systems, Inc.

=cut