#!/usr/bin/env perl

##
## Cowsay
##

use Cwd 'abs_path';
use File::Basename;
use File::Find;
use Getopt::Std;
use Text::Tabs qw(expand);
use Text::Wrap qw(wrap fill $columns);

$Getopt::Std::STANDARD_HELP_VERSION = 1;

$VERSION = "3.8.4";
$progname = basename($0);
$eyes = "oo";
$tongue = "  ";
$pathsep = detect_pathsep();
@cowpath = pick_cowpath();
@message = ();
$thoughts = "";

# Yeah, this is rude, I know. But hopefully it gets around a nasty little version
# dependency.

$Text::Wrap::initial_tab = 8;
$Text::Wrap::subsequent_tab = 8;
$Text::Wrap::tabstop = 8;

%opts = (
    'e'         =>      'oo',
    'f'         =>      'default.cow',
    'n'         =>      0,
    'T'         =>      '  ',
    'W'         =>      40,
);

getopts('bCde:f:ghlLnNprstT:wW:y', \%opts);

if ($opts{'h'}) {
    &HELP_MESSAGE;
    exit(0);
}
&list_cowfiles if $opts{'l'};

$random = $opts{'r'};
$enable_full_color = $opts{'C'};
$borg = $opts{'b'};
$dead = $opts{'d'};
$greedy = $opts{'g'};
$paranoid = $opts{'p'};
$stoned = $opts{'s'};
$tired = $opts{'t'};
$wired = $opts{'w'};
$young = $opts{'y'};
$eyes = substr($opts{'e'}, 0, 2);
$tongue = substr($opts{'T'}, 0, 2);
$specified_cow = $opts{'f'};
$cow_file_path = "";
$the_cow = "";

&slurp_input;
$Text::Wrap::columns = $opts{'W'};
@message = ($opts{'n'} ? expand(@message) : 
            split("\n", fill("", "", @message)));
&construct_balloon;
&construct_face;
&pick_cow;
&read_cow;
print @balloon_lines;
print $the_cow;

sub detect_pathsep {
    # One of these days, we'll get it ported to Windows. Yeah, right.
    if (($^O eq "MSWin32") or ($^O eq "Windows_NT")) {  # Many perls, eek!
        return ';';
    } else {
        return ':';
    }
}

sub pick_cowpath {
    my $exe_file = abs_path(__FILE__);
    my $parent_dir = dirname($exe_file);
    my $parent_dir_base = basename($parent_dir);
    my ($prefix_dir, $share_cowsay, $real_prefix_dir, $etc_dir);
    # prefix is the parent dir of bin/, in which cowsay must live
    $prefix_dir = dirname($parent_dir);
    $share_cowsay = "$prefix_dir/share/cowsay";
    $real_prefix_dir = abs_path($prefix_dir);
    if ($real_prefix_dir eq "/usr") {
        $etc_dir = "/etc";
    } else {
        $etc_dir = "$real_prefix_dir/etc";
    }

    my @cowpath;
    my @default_cowpath = ("$share_cowsay/site-cows", "$share_cowsay/cows");

    my $cowpath_d_dir = "$etc_dir/cowsay/cowpath.d";
    if (-d $cowpath_d_dir) {
        my $dh;
        opendir($dh, $cowpath_d_dir);
        my @files = readdir($dh);
        closedir($dh);
        foreach (@files) {
            my $file = "$cowpath_d_dir/$_";
            if (-f $file && $file =~ /\.path$/) {
                open my $fh, '<', $file
                    or die "Could not read cowpath file $file: $!\n";
                while (my $entry = <$fh>) {
                    chomp $entry;
                    push @default_cowpath, $entry;
                }
                close($fh);
            }
        }
    }

    if ($ENV{'COWPATH'}) {
        my @user_cowpath = split(/$pathsep/, $ENV{'COWPATH'});
        if ($ENV{'COWSAY_ONLY_COWPATH'} == 1) {
            @cowpath = @user_cowpath;
        } else {
            @cowpath = (@default_cowpath, @user_cowpath);
        }
    } else {
        @cowpath = @default_cowpath;
    }

    @cowpath = uniquify_list(@cowpath);

    return @cowpath;
}

sub uniquify_list {
    my %seen;
    my @unique = grep { !$seen{$_}++ } @_;
    return @unique;
}

sub list_cowfiles {
    if (-t STDOUT) {
        list_cowfiles_pretty();
    } else {
        list_cowfiles_parseable();
    }
    exit(0);
}

my @found_cows;
my $search_start_dir;

sub find_cowfile_callback() {
    if (-f && /\.(cow)$/) {
        my $rel_file = substr($File::Find::name, length($search_start_dir) + 1);
        my $cow_name = $rel_file;
        $cow_name =~ s/\.(cow)$//;
        push @found_cows, $cow_name;
    }
}

sub list_cows_in_cowdir {
    my ($cowdir) = @_;
    @found_cows = ();
    $search_start_dir = $cowdir;
    find(\&find_cowfile_callback, $cowdir);
    return \@found_cows;
}

sub list_cowfiles_parseable {
    my $cows = defined_cows();
    print join("\n", @$cows), "\n";
}

sub defined_cows {
    my $basedir;
    my %cowfiles;
    for my $d (@cowpath) {
        next unless -d $d;
        my $cows = list_cows_in_cowdir($d);
        for my $cow (@$cows) {
            $cowfiles{$cow} = $cow;
        }
    }
    my @cowfiles = sort keys %cowfiles;
    return \@cowfiles;
}

sub defined_cows_structured {
    my $cows = defined_cows();
    my %cows;
    my @truecolor = ();
    my @basic = ();
    for (@$cows) {
        if (m|^truecolor/|) {
            push @truecolor, $_;
        } else {
            push @basic, $_;
        }
    }
    my @all = (@basic, @truecolor);
    return {
        basic => \@basic,
        truecolor => \@truecolor,
        all => \@all
    };
}

sub list_cowfiles_pretty {
    my $basedir;
    my @dirfiles;
    my $first = 1;
    for my $d (@cowpath) {
        next unless -d $d;
        my $cows = list_cows_in_cowdir($d);
        next unless @$cows;
        print "\n" unless $first;
        $first = 0;
        print "Cow files in $d:\n";
        print wrap("", "", sort @$cows), "\n";
    }
}

sub slurp_input {
    if ($ARGV[0]) {
        if ($opts{'n'}) {
            # -n only works with stdin input
            &HELP_MESSAGE;
            exit(1);
        }
        @message = join(' ', @ARGV);
    } else {
        chomp(@message = <STDIN>);
    }
}

sub maxlength {
    my ($l, $m);
    $m = 0;
    for my $i (@_) {
        $l = length $i;
        $m = $l if ($l > $m);
    }
    return $m;
}

sub construct_balloon {
    my $max = &maxlength(@message);
    my $max2 = $max + 2;        # border space fudge.
    my $format = "%s %-${max}s %s\n";
    my @border; # up-left, up-right, down-left, down-right, left, right
    if ($0 =~ /think/i) {
        $thoughts = 'o';
        @border = qw[ ( ) ( ) ( ) ];
    } elsif (@message < 2) {
        $thoughts = '\\';
        @border = qw[ < > ];
    } else {
        $thoughts = '\\';
        if ($V and $V gt v5.6.0) {              # Thanks, perldelta.
            @border = qw[ / \\ \\ / | | ];
        } else {
            @border = qw[ / \ \ / | | ];        
        }
    }
    push(@balloon_lines, 
        " " . ("_" x $max2) . "\n" ,
        sprintf($format, $border[0], $message[0], $border[1]),
        (@message < 2 ? "" : 
            map { sprintf($format, $border[4], $_, $border[5]) } 
                @message[1 .. $#message - 1]),
        (@message < 2 ? "" : 
            sprintf($format, $border[2], $message[$#message], $border[3])),
        " " . ("-" x $max2) . "\n"
    );
}

sub construct_face {
    if ($borg)      { $eyes = "=="; }
    if ($dead)      { $eyes = "xx"; $tongue = "U "; }
    if ($greedy)    { $eyes = "\$\$"; }
    if ($paranoid)  { $eyes = "@@"; }
    if ($stoned)    { $eyes = "**"; $tongue = "U "; }
    if ($tired)     { $eyes = "--"; } 
    if ($wired)     { $eyes = "OO"; } 
    if ($young)     { $eyes = ".."; }
}

sub resolve_cow {
    my ($name) = @_;
    my $full = "";
    for my $d (@cowpath) {
        if (-f "$d/$name") {
            $full = "$d/$name";
            last;
        } elsif (-f "$d/$name.cow") {
            $full = "$d/$name.cow";
            last;
        }
    }
    if ($full eq "") {
        die "$progname: Could not find cowfile for '$name'!\n";
    }
    return $full;
}

sub pick_cow {
    my $found_path = "";
    if ($random) {
        my $defined_cows = defined_cows_structured();
        my @usable_cows;
        if ($enable_full_color) {
            @usable_cows = @{$$defined_cows{all}};
        } else {
            @usable_cows = @{$$defined_cows{basic}};
        }
        my $n_cows = scalar @usable_cows;
        my $index = int(rand($n_cows));
        my $selected_cow = $usable_cows[$index];
        $found_path = resolve_cow($selected_cow);
    } elsif (-f $specified_cow) {
        $found_path = $specified_cow;
    } else {
        $found_path = resolve_cow($specified_cow);
    }
    $cow_file_path = $found_path;
}

sub read_cow {
    if ($cow_file_path =~ /\.pm$/) {
        die "$progname: Cannot load cow from $cow_file_path: .pm (Perl module) format cows are not implemented yet. Sorry.\n";
    }
    do $cow_file_path;
    die "$progname: Error reading cow definition from $cow_file_path: $@\n" if $@;
}

sub HELP_MESSAGE {
        print <<EOF;
$progname version $VERSION

Usage:

    $progname [-bdgpstwy] [-f <cowfile>] [-r [-C]] [-e <eyes>] [-T <tongue>]
        [-W <wrapcolumn>] [-n]
        <message>

    $progname -l              # List defined cows
    $progname [-h | --help]   # Display this help screen

Options:

    -b, -d, -g, -s, -t, -w, and -y activate Borg, dead, greedy, sleepy, tired, wired, and
        young appearance modes, respectively.

    -f <cowfile> selects an alternate cow picture. <cowfile> may be either the name of a
        cow defined in a cowdir on the cowpath (without the '.cow' file extension), or the
        path to a cowfile (with the '.cow' file extension). `$progname -l` will list the
        names of available cows.

    -r selects a random cowfile from those present on the cowpath. If -C is also given,
        then full-color cows will be included.

    -e \<eyes\> defines a custom eye appearance. <eyes> should be a two-character string.
        It is up to you whether they actually look like eyes.

    -T <tongue> defines a custom tongue appearance.

    -n activates word wrapping, to support messages with arbitrary whitespace. Must be the
        last option given before \<message\> starts.

    -W <wrapcolumn> controls where line wrapping occurs. Default is 40 columns.

EOF
}
