view release on metacpan or  search on metacpan

scripts/ttfeval  view on Meta::CPAN

#! /usr/bin/perl

use strict;
use Font::TTF::Useall;
use IO::File;
use Pod::Usage;

# Can't use GetOpt variants because of the funky syntax of -m and -M  (see perlrun)

my (@modules, $prog, $opt_v, $output, $exe);

while(scalar (@ARGV) >= 0)
{
    my $arg = shift;
    if ($arg =~ /^-\?/o)
    {
        pod2usage( -verbose => 2, -noperldoc => 1);
        exit;
    }
    
    if ($arg =~ /^-([mM])([^-].*)$/o)
    { push @modules, [ $1, $2 ]; }  # Save -m or -M and their args for later
    elsif ($arg =~ /^-e$/o)
    { $prog .= shift() . "\n"; }    # Concatinate -e arguments -- that's the user's program.
    elsif ($arg =~ /^-o(.*)$/o)
    {
        die "Only one -o option allowed." if defined $output;
        $output = $1 || shift;      # Remember outputfile
    }
    elsif ($arg =~ m/^-v$/o)
    { $opt_v = 1; }
    else
    {
        unshift (@ARGV, $arg);
        last;
    }
}

pod2usage(-msg => "missing infont.ttf parameter\n", -verbose => 1) unless defined $ARGV[0];

# 'require' modules specified on -m or -M  -- this is intended to mimic what perl -m or perl -M does

foreach (@modules)
{
    my ($c, $m) = @{$_};    # $c is either 'm' or 'M'; $m is the module name plus any extra info user gave
    
    $m =~ s/^\s+//o;
    $m =~ s/\s+$//o;
    
    my $res;
        
    if ($m =~ /^(\S+)\s*=\s*(.*)$/o)        # 'module=something'
    {
        eval "\$res = require $1; $1->import(split(/,/,'$2'));" ;
    }
    elsif ($m =~ /^(\S+)\s+(.*)$/o)         # 'module something'
    {
        eval "\$res = require $1; $1->import($2);" ;
    }
    else                                    # 'module'  
    {
        eval "\$res = require $m; $m->import unless \$c eq 'm';"  ;
    }   
    die "Couldn't find module '$m'\n" unless $res;
}


# Open the font:
my ($f);

unless (defined $prog)
{
    # Take first next argument as a script
    $prog = shift @ARGV;
    my ($fh) = IO::File->new("< $prog") || die "Can't open '$prog': ";
    local $/;
    $prog = <$fh>;
    $fh->close;
}
{
    no strict;
    $exe = eval "sub{ $prog }" if ($prog ne "");
    die $@ if $@;
}
$output =~ s|\\|/|og;
my ($out_rep) = $output;
my ($i);
$out_rep =~ s/[?*]/'$m[' . ($i++) . ']'/oge;


foreach my $a (@ARGV)
{
    $a =~ s|\\|/|og;
    my ($sub) = $a;
    $sub =~ s/\*/([^.]*)/og;
    $sub =~ s/\?/(.?)/og;

    foreach my $infile (glob($a))
    {
        my (@m) = ($infile =~ m/$sub/g);
        my ($outfile);

        if ($output && -d $output)        # then get filename and append
        {
            if ($infile =~ m|[\\/]([^/\\]+)$|o)
            { $outfile = "$output/$1"; }
            else
            { $outfile = "$output/$infile"; }
        }
        elsif ($output)                  # replace wildcards with corresponding wildcard matches
        { $outfile = eval "\"$out_rep\""; }

        print STDERR "$infile -> $outfile\n" if ($opt_v);

        $f = Font::TTF::Font->open($infile) || die "Can't open font file '$infile': $!\n";

# Invoke user's script, if any:
        eval $exe->($infile, $outfile) if $prog;

# Write the resultant font if requested
        if ($outfile)
        {