externals/cowsay/cowsay

   1 #%BANGPERL%
   2
   3 ##
   4 ## Cowsay 3.03
   5 ##
   6 ## This file is part of cowsay.  (c) 1999-2000 Tony Monroe.
   7 ##
   8
   9 use Text::Tabs qw(expand);
  10 use Text::Wrap qw(wrap fill $columns);
  11 use File::Basename;
  12 use Getopt::Std;
  13 use Cwd;
  14
  15 $version = "3.03";
  16 $progname = basename($0);
  17 $eyes = "oo";
  18 $tongue = "  ";
  19 $cowpath = $ENV{'COWPATH'} || '%PREFIX%/share/cows';
  20 @message = ();
  21 $thoughts = "";
  22
  23 ## Yeah, this is rude, I know.  But hopefully it gets around a nasty
  24 ## little version dependency.
  25
  26 $Text::Wrap::initial_tab = 8;
  27 $Text::Wrap::subsequent_tab = 8;
  28 $Text::Wrap::tabstop = 8;
  29
  30 ## One of these days, we'll get it ported to Windows.  Yeah, right.
  31
  32 if (($^O eq "MSWin32") or ($^O eq "Windows_NT")) {      ## Many perls, eek!
  33     $pathsep = ';';
  34 } else {
  35     $pathsep = ':';
  36 }
  37
  38 %opts = (
  39     'e'         =>      'oo',
  40     'f'         =>      'default.cow',
  41     'n'         =>      0,
  42     'T'         =>      '  ',
  43     'W'         =>      40,
  44 );
  45
  46 getopts('bde:f:ghlLnNpstT:wW:y', \%opts);
  47
  48 &display_usage if $opts{'h'};
  49 &list_cowfiles if $opts{'l'};
  50
  51 $borg = $opts{'b'};
  52 $dead = $opts{'d'};
  53 $greedy = $opts{'g'};
  54 $paranoid = $opts{'p'};
  55 $stoned = $opts{'s'};
  56 $tired = $opts{'t'};
  57 $wired = $opts{'w'};
  58 $young = $opts{'y'};
  59 $eyes = substr($opts{'e'}, 0, 2);
  60 $tongue = substr($opts{'T'}, 0, 2);
  61 $the_cow = "";
  62
  63 &slurp_input;
  64 $Text::Wrap::columns = $opts{'W'};
  65 @message = ($opts{'n'} ? expand(@message) :
  66             split("\n", fill("", "", @message)));
  67 &construct_balloon;
  68 &construct_face;
  69 &get_cow;
  70 print @balloon_lines;
  71 print $the_cow;
  72
  73 sub list_cowfiles {
  74     my $basedir;
  75     my @dirfiles;
  76     chop($basedir = cwd);
  77     for my $d (split(/$pathsep/, $cowpath)) {
  78         print "Cow files in $d:\n";
  79         opendir(COWDIR, $d) || die "$0: Cannot open $d\n";
  80         for my $file (readdir COWDIR) {
  81             if ($file =~ s/\.cow$//) {
  82                 push(@dirfiles, $file);
  83             }
  84         }
  85         closedir(COWDIR);
  86         print wrap("", "", sort @dirfiles), "\n";
  87         @dirfiles = ();
  88         chdir($basedir);
  89     }
  90     exit(0);
  91 }
  92
  93 sub slurp_input {
  94     unless ($ARGV[0]) {
  95         chomp(@message = <STDIN>);
  96     } else {
  97         &display_usage if $opts{'n'};
  98         @message = join(' ', @ARGV);
  99     }
 100 }
 101
 102 sub maxlength {
 103     my ($l, $m);
 104     $m = -1;
 105     for my $i (@_) {
 106         $l = length $i;
 107         $m = $l if ($l > $m);
 108     }
 109     return $m;
 110 }
 111
 112 sub construct_balloon {
 113     my $max = &maxlength(@message);
 114     my $max2 = $max + 2;        ## border space fudge.
 115     my $format = "%s %-${max}s %s\n";
 116     my @border; ## up-left, up-right, down-left, down-right, left, right
 117     if ($0 =~ /think/i) {
 118         $thoughts = 'o';
 119         @border = qw[ ( ) ( ) ( ) ];
 120     } elsif (@message < 2) {
 121         $thoughts = '\\';
 122         @border = qw[ < > ];
 123     } else {
 124         $thoughts = '\\';
 125         if ($V and $V gt v5.6.0) {              # Thanks, perldelta.
 126             @border = qw[ / \\ \\ / | | ];
 127         } else {
 128             @border = qw[ / \ \ / | | ];
 129         }
 130     }
 131     push(@balloon_lines,
 132         " " . ("_" x $max2) . " \n" ,
 133         sprintf($format, $border[0], $message[0], $border[1]),
 134         (@message < 2 ? "" :
 135             map { sprintf($format, $border[4], $_, $border[5]) }
 136                 @message[1 .. $#message - 1]),
 137         (@message < 2 ? "" :
 138             sprintf($format, $border[2], $message[$#message], $border[3])),
 139         " " . ("-" x $max2) . " \n"
 140     );
 141 }
 142
 143 sub construct_face {
 144     if ($borg) { $eyes = "=="; }
 145     if ($dead) { $eyes = "xx"; $tongue = "U "; }
 146     if ($greedy) { $eyes = "\$\$"; }
 147     if ($paranoid) { $eyes = "@@"; }
 148     if ($stoned) { $eyes = "**"; $tongue = "U "; }
 149     if ($tired) { $eyes = "--"; }
 150     if ($wired) { $eyes = "OO"; }
 151     if ($young) { $eyes = ".."; }
 152 }
 153
 154 sub get_cow {
 155 ##
 156 ## Get a cow from the specified cowfile; otherwise use the default cow
 157 ## which was defined above in $the_cow.
 158 ##
 159     my $f = $opts{'f'};
 160     my $full = "";
 161     if ($opts{'f'} =~ m,/,) {
 162         $full = $opts{'f'};
 163     } else {
 164         for my $d (split(/:/, $cowpath)) {
 165             if (-f "$d/$f") {
 166                 $full = "$d/$f";
 167                 last;
 168             } elsif (-f "$d/$f.cow") {
 169                 $full = "$d/$f.cow";
 170                 last;
 171             }
 172         }
 173         if ($full eq "") {
 174             die "$progname: Could not find $f cowfile!\n";
 175         }
 176     }
 177     do $full;
 178     die "$progname: $@\n" if $@;
 179 }
 180
 181 sub display_usage {
 182         die <<EOF;
 183 cow{say,think} version $version, (c) 1999 Tony Monroe
 184 Usage: $progname [-bdgpstwy] [-h] [-e eyes] [-f cowfile]
 185           [-l] [-n] [-T tongue] [-W wrapcolumn] [message]
 186 EOF
 187 }