Mini Shell

#!/usr/bin/perl
# encoding: utf-8
# author: Kyle Yetter <kyle@ohboyohboyohboy.org>
# created on: May 27, 2011


use strict;
use IO::Handle;
use Scalar::Util 'openhandle';
use Carp;
use File::Basename;
use Getopt::Long;

our $VERSION     = '1.0.0';
our $add_newline = 1;
our $do_help     = 0;
our $do_version  = 0;

our %option_spec = (
  'n|no-newline' => sub { $add_newline = 0; },
  'h|help' => sub {  help();  exit 0; },
  'v|version' => sub {  print "$VERSION\n";  exit 0; }
);

our %ESCAPE_MAP = (
  'n'   => "\n",  't'   => "\t",  'r'   => "\r",  'e'   => "\e",
  '\\'  => "\\",  'a'   => "\a",  "s"   => " ",   'b'   => "\b",
  '%'   => '%%'
);
our $BACKGROUND_CODE = "\e[4%im";
our $FOREGROUND_CODE = "\e[3%im";

our %COLOR_VALUES = (
  "white" => 7,     "black" => 0,  "cyan" => 6,      "blue" => 4,
  "green" => 2,     "red" => 1,  "magenta" => 5,   "yellow" => 3
);

our %DISPLAY_MAP = ();
while ( my ( $k, $v ) = each %COLOR_VALUES ) {
  $DISPLAY_MAP{ $v } = $k;
}

our %COLOR_NAMES = (
  "bla" => "black",    "gree" => "green",       "w" => "white",
  "blac" => "black",   "green" => "green",      "wh" => "white",
  "black" => "black",  "m" => "magenta",        "whi" => "white",
  "blu" => "blue",     "ma" => "magenta",       "whit" => "white",
  "blue" => "blue",    "mag" => "magenta",      "white" => "white",
  "c" => "cyan",       "mage" => "magenta",     "y" => "yellow",
  "cy" => "cyan",      "magen" => "magenta",    "ye" => "yellow",
  "cya" => "cyan",     "magent" => "magenta",   "yel" => "yellow",
  "cyan" => "cyan",    "magenta" => "magenta",  "yell" => "yellow",
  "g" => "green",      "r" => "red",            "yello" => "yellow",
  "gr" => "green",     "re" => "red",           "yellow" => "yellow",
  "gre" => "green",    "red" => "red"
);

our %STYLE_CODES = (
  '*' => "\e[1m",  '_' => "\e[4m", '~' => "\e[7m",  '!' => "\e[5m"
);

our $RX_TAGS = qr`
  ( [\*~!_]* )
| (   [a-z]+ (?: @ [a-z]+ )?
  | @ [a-z]+
  )
`xi;

our $RX_COLOR_ARG = qr`
  % \( ( $RX_TAGS ) \)
  ( [\-\+0\s\#]? \d* (?:\.\d+)? [hlI]? [bcdEefGgiopsuXx] )
`x;

our $RX_ESCAPE    = qr(^\\(.));
our $RX_CLOSE_TAG = qr(^</$RX_TAGS>);
our $RX_OPEN_TAG  = qr(^<$RX_TAGS>);
our $RX_TEXT      = qr(^(.+?)(?=(?:\\.|</?$RX_TAGS>|\Z)))s;

our $BAD_CLOSE = q(bad format close tag: expected `%(g)s', but got `%(y)s');

sub color_value($) {
  my ( $name ) = @_;
  if ( $name ) {
    my $full_name = $COLOR_NAMES{ lc( $name ) } or
      damn( "`%(y)s' is not a valid color name", $name );
    return $COLOR_VALUES{ $full_name };
  }
}

sub color_scan($) {
  my ( $text ) = @_;
  my ( @foreground, @background, @styles );
  my $out = '';
  open( my $str, '>', \$out );

  $text =~ s($RX_COLOR_ARG)(<$1>%$4</$1>)g;
  $_ = $text;

  while ( $_ ) {
    my $print_escape = 0;

    if ( /$RX_ESCAPE/ ) {
      $_ = $';
      my $c = $ESCAPE_MAP{ $1 } || $1;
      print $str $c;
    } elsif ( /$RX_CLOSE_TAG/ ) {
      $_ = $';

      if ( my $style_char = $1 ) {
        for my $c ( split //, $style_char ) {
          my $v = $STYLE_CODES{ $c };
          @styles = grep { $_ ne $v } @styles;
        }
      } elsif ( my $colors = $2 ) {
        my ( $fg, $bg ) = split( /@/, $colors, 2 );

        if ( my $value = color_value( $fg ) ) {
          my $current = $foreground[ -1 ];
          if ( $current and $current ne $value ) {
            my $expected = $DISPLAY_MAP{ $current };
            my $got      = $DISPLAY_MAP{ $value };
            damn( $BAD_CLOSE, $expected, $got );
          }
          pop @foreground;
        }

        if ( my $value = color_value( $bg ) ) {
          my $current = $background[ -1 ];
          if ( $current and $current ne $value ) {
            my $expected = $DISPLAY_MAP{ $current };
            my $got      = $DISPLAY_MAP{ $value };
            damn( $BAD_CLOSE, $expected, $got );
          }
          pop @background;
        }
      }

      $print_escape = 1;

    } elsif ( /$RX_OPEN_TAG/ ) {
      $_ = $';

      if ( my $style_char = $1 ) {
        for my $c ( split //, $style_char ) {
          push @styles, $STYLE_CODES{ $c };
        }
      } elsif ( my $colors = $2 ) {
        my ( $fg, $bg ) = split( /@/, $colors, 2 );
        if ( my $value = color_value( $fg ) ) { push @foreground, $value; }
        if ( my $value = color_value( $bg ) ) { push @background, $value; }
      }

      $print_escape = 1;
    } elsif ( /$RX_TEXT/ ) {
      $_ = $';
      print $str $1;
    } else {
      damn( "this shouldn't happen: (%s@%i)", __FILE__, __LINE__ );
    }

    if ( $print_escape ) {
      print $str "\e[0m";
      if ( my $value = $foreground[ -1 ] ) { printf $str $FOREGROUND_CODE, $value; }
      if ( my $value = $background[ -1 ] ) { printf $str $BACKGROUND_CODE, $value; }
      print $str join( '', @styles );
    }
  }

  if ( @foreground + @background + @styles > 0 ) {
    print $str "\e[0m";
  }

  close( $str );
  return $out;
}

sub say {
  my $currfh = select();
  my $handle;
  {
      no strict 'refs';
      $handle = openhandle( $_[0] ) ? shift : \*$currfh;
      use strict 'refs';
  }

  my ( $format, @args ) = @_;
  $format ||= $_;
  $format ||= '';

  my $warning;
  local $SIG{__WARN__} = sub { $warning = join q{}, @_ };

  if ( $add_newline and $format !~ m($/\z)s ) { $format .= $/; }

  $format = color_scan( $format );

  my $res = printf {$handle} $format, @args;
  return $res if $res;

  $warning =~ s/[ ]at[ ].*//xms;
  croak $warning;
}

*IO::Handle::say = \&say if ! defined &IO::Handle::say;

sub damn {
  my ( $message, @args ) = @_;
  say( \*STDERR, "<red>ERROR:</red> $message", @args );
  exit( 1 );
}

sub help {
  my $name = basename( $0 );
  my @help_lines = <DATA>;
  my $help = join( '', @help_lines );
  $help =~ s(\b__name__\b)($name)g;
  print $help, "\n";
}





GetOptions( %option_spec );

say @ARGV;

__END__
__name__: print a printf-style formatted string with ansi color code markup
USAGE: __name__ [opts] format_string [args ...]

OPTIONS:
  -n, --no-newline     Do not append a trailing newline
  -v, --version        Print program version and exit
  -h, --help           Print program summary and exit

ANSI MARK UP EXAMPLES:
  styles: <_>underline</_> <~>invert</~> <!>blink</!> <*>bold</*>
  colors: <fg_color></fg_color> <@bg_color></@bg_color> <fg@bg></fg@bg>