view release on metacpan or  search on metacpan

lib/App/Uni.pm  view on Meta::CPAN

#pod
#pod     $ uni ☺
#pod     263A ☺ WHITE SMILING FACE
#pod
#pod     # Only on Perl 5.14+
#pod     $ uni wry
#pod     1F63C <U+1F63C> CAT FACE WITH WRY SMILE
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module installs a simple program, F<uni>, that helps grepping through
#pod the Unicode database included in the current Perl 5 installation.
#pod
#pod For information on how to use F<uni> consult the L<uni> documentation.
#pod
#pod =head1 ACKNOWLEDGEMENTS
#pod
#pod This is a re-implementation of a program written by Audrey Tang in Taiwan.  I
#pod used that program for years before deciding I wanted to add a few features,
#pod which I did by rewriting from scratch.
#pod
#pod That program, in turn, was a re-implementation of a same-named program Larry
#pod copied to me, which accompanied Audrey for years.  However, that program was
#pod lost during a hard disk failure, so she coded it up from memory.
#pod
#pod Thank-you, Larry, for everything. ♡
#pod
#pod =cut

use 5.10.0; # for \v
use warnings;

use charnames ();
use Encode qw(encode_utf8);
use Getopt::Long;
use List::Util qw(max);
use Unicode::GCString;

sub _do_help {
  my $class = shift;

  die
    join qq{\n  }, join(qq{\n}, @_, @_ ? "" : (), "usage:"),
    "uni SEARCH-TERMS...    - find codepoints with matching names or values",
    "uni [-s] ONE-CHARACTER - print the codepoint and name of one character",
    "uni -n SEARCH-TERMS... - find codepoints with matching names",
    "uni -c STRINGS...      - print out the codepoints in a string",
    "uni -u CODEPOINTS...   - look up and print hex codepoints",
    "uni -x HEX-OCTETS...   - given the sequence of octets, in hex, decode",
    "",
    "Other switches:",
    "    -8                 - also show the UTF-8 bytes to encode\n";
}

sub run {
  my ($class, @argv) = @_;

  my %opt;
  {
    my $exit;
    local @ARGV = @argv;
    GetOptions(
      "c" => \$opt{explode},
      "u" => \$opt{u_numbers},
      "n" => \$opt{names},
      "s" => \$opt{single},
      "x" => \$opt{hex_octets},
      "8" => \$opt{utf8},
      "help|?" => \$opt{help},
    );
    @argv = @ARGV;
  }

  $class->_do_help if $opt{help};

  my $n = grep { $_ } @opt{qw(explode u_numbers names single hex_octets)};

  $class->_do_help("ERROR: only one mode switch allowed!") if $n > 1;

  $class->_do_help if ! @argv;

  my $todo  = $opt{explode}                       ? \&do_explode
            : $opt{u_numbers}                     ? \&do_u_numbers
            : $opt{names}                         ? \&do_names
            : $opt{single}                        ? \&do_single
            : $opt{hex_octets}                    ? \&do_hex_octets
            : @argv == 1 && length $argv[0] == 1  ? \&do_single
            :                                       \&do_dwim;

  $todo->(\@argv, \%opt);
}

sub do_single {
  my @chars    = grep { length } @{ $_[0] };
  if (my @too_long = grep { length > 1 } @chars) {
    die "some arguments were too long for use with -s: @too_long\n";
  }
  print_chars(\@chars, $_[1]);
}

sub do_explode {
  print_chars( explode_strings($_[0]), $_[1] );
}

sub do_hex_octets {
  my $string = '';
  for my $hunk (@{ $_[0] }) {
    die "input hunk $hunk is not an even-length hex string\n"
      unless $hunk =~ /\A[0-9A-F]+\z/i && length($hunk) % 2 == 0;

    $string .= chr oct "0x$_" for $hunk =~ /(..)/g;
  }

  print_chars( explode_strings([ Encode::decode_utf8($string) ], $_[1]) );
}

sub explode_strings {
  my ($strings) = @_;

  my @chars;