#!/usr/local/cpanel/3rdparty/perl/536/bin/perl
# PODNAME: tts
use strict;
use warnings;
use File::Spec;
use File::Basename;
use Getopt::Long;
use Data::Dumper;
use Scalar::Util qw( blessed );
use Carp qw( croak );
our $VERSION = '0.12';
our %OPT;
local $| = 1;
BEGIN {
GetOptions( \%OPT => qw(
e=s
version
http-header
help
debug=i
debug-tokens
new-cache
new-capture-warnings
new-safe
new-stack
new-strict
new-verbose_errors
new-warn-ids
new-monolith
new-add-args=s@
new-cache-dir=s
new-delimiters=s@
new-header=s
new-include-paths=s@
new-iolayer=s
new-pre-chomp=s
new-post-chomp=s
compile-param=s@
compile-id=s
compile-map-keys
compile-chkmt
));
$OPT{file} = shift;
if ( $OPT{'debug-tokens'} ) {
*Text::Template::Simple::Tokenizer::DEBUG_TOKENS =
*Text::Template::Simple::Tokenizer::DEBUG_TOKENS = sub { 1 };
}
}
use Text::Template::Simple;
use Text::Template::Simple::Constants qw( EMPTY_STRING );
BEGIN {
Text::Template::Simple->DEBUG( $OPT{debug} ) if $OPT{debug};
}
my %CONTROLLER; # registry
run( %OPT ) if not caller;
sub run {
my %opt = @_;
if ( $opt{help} ) {
require Pod::Usage;
Pod::Usage::pod2usage(1);
};
usage() if $opt{version};
my $file = delete $opt{file};
my %p = parse_arg( %opt );
my $cp = delete($p{compile}->{param}) || [];
my $in = exists $p{e} ? ( $p{e} || croak 'No code specified for -e' )
: ( $file || croak 'No input file specified' )
;
my $TTS = {
header => {
charset => EMPTY_STRING,
type => 'text/html',
},
};
$p{new}->{add_args} ||= [];
$p{new}->{header} ||= EMPTY_STRING;
unshift @{ $p{new}->{add_args} }, $TTS;
$p{new}->{header} = q{my $}.q{TTS = shift;} . $p{new}->{header};
my $t = object($file, \%p );
my $rv;
my $ok = eval {
$rv = $t->compile(
exists $p{e} ? [ STRING => $in ] : $in,
$cp,
%{ $p{compile} }
);
};
my $error = $@;
my $head = EMPTY_STRING;
if ( $p{'http-header'} ) {
require CGI;
$head = CGI::header(
-charset => $TTS->{header}{charset},
-type => $TTS->{header}{type},
);
}
binmode STDOUT, ':utf8' if lc $TTS->{header}{charset} eq 'utf8';
$rv = "Error in template: $error" if $error;
croak $rv if $error && ! $head;
my $pok = print $head.$rv;
return 1;
}
sub object {
my($file, $p) = @_;
my $global = Text::Template::Simple->new( %{ $p->{new} } );
my $path = $global->io->file_exists( $file );
my $t;
if ( $path ) {
my $dir = dirname $path;
my $base = basename $path;
my $c = File::Spec->catfile( $dir, $base . '.pl' );
$t = exists $CONTROLLER{ $c } ? $CONTROLLER{ $c }->{handler}
: -e $c ? _object_from_file( $p, $c )
: undef;
}
return $t || $global;
}
sub _object_from_file {
my($p, $controller) = @_;
my $f = $controller;
## no critic (ProhibitEnumeratedClasses)
(my $pkg = 'TTS'.$controller) =~ s{[^a-zA-Z0-9_]}{_}xmsg;
(my $file3 = $controller ) =~ s{ " }{\\"}xmsg;
my $h = eval qq{package $pkg; require "$controller";};
croak "Error compiling controller: $@" if $@;
my $cref = $pkg->can('tts_controller')
|| croak 'Controller present but does not '
.'implement a tts_controller() function';
my $o = $cref->( %{ $p->{new} } );
croak 'Controller returned non-object'
if ! ref $o;
croak 'Controller returned a non-blessed reference'
if ! blessed $o;
croak 'Controller returned a non-Text::Template::Simple object'
if ! $o->isa('Text::Template::Simple');
$CONTROLLER{ $controller } = {
handler => $o,
package => $pkg,
date => time,
};
return $CONTROLLER{ $controller }->{handler};
}
sub parse_arg {
my %original = @_;
my %param = ( new => {}, compile => {} );
foreach my $key ( keys %original ) {
if ( $key =~ m{ \A (new|compile) \- (.*) \z }xms ) {
my $id = $1;
(my $name = $2) =~ s{\-}{_}xmsg;
$param{ $id }->{ $name } = delete $original{ $key };
}
}
$param{ $_ } = delete $original{ $_ } for keys %original;
local_conf( \%param );
return %param;
}
sub local_conf {
return if 1; # TODO: set defaults from file
my $p = shift;
require File::HomeDir;
my $CONF = File::Spec->catfile( File::HomeDir->my_home, '.tts' );
return if ! -e $CONF;
open my $FH, '<', $CONF or croak "Can not open $CONF: $!";
my $raw = do { my $rv; local $/; $rv = <$FH>; $rv };
close $FH or croak "Unable to close filehandle: $!";
return;
}
sub usage {
#require Config; $Config::Config{archname}
local $SIG{__WARN__} = sub {
my $w = shift;
return if $w =~ m{Sys/Info}xms; # noise
warn "$w\n";
};
my $info = eval { require Sys::Info; return Sys::Info->new; };
my $os = $info ? $info->os->name( edition => 1 ) : $^O;
my $perl = $info ? $info->perl_long : $];
printf <<'USAGE', basename($0), $VERSION, $os, $perl or croak $!;
Bah-weep-Graaaaagnah wheep ni ni bong!
I am %s v%s running under %s with perl %s
USAGE
exit 0;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
tts
=head1 VERSION
version 0.91
=head1 SYNOPSIS
You have to either pass a file name or pass C<-e> with a template string.
tts -e 'My perl is at <%= $^X %>'
tts /home/burak/template.tts
=head1 DESCRIPTION
This a command line front end to L<Text::Template::Simple>.
=head1 NAME
tts - Command line interface to Text::Template::Simple
=head1 OPTIONS
-e String template to execute
--http-header Print a HTTP Header?
--help Display help
--debug Integer. Sets the debuggging level
--debug-tokens Enable token debugging?
--new-cache Flag.
--new-capture-warnings Flag.
--new-safe Flag.
--new-stack Flag.
--new-strict Flag.
--new-verbose_errors Flag.
--new-warn-ids Flag.
--new-monolith Flag.
--new-add-args Add global arguments
--new-cache-dir Path to cache directory
--new-delimiters Sets the delimiters
--new-header Injects a default code onto the template
--new-include-paths List of include paths
--new-iolayer Perl I/O layer
--new-pre-chomp Global pre-chomp
--new-post-chomp Global post-chomp
--compile-param List of parameters to pass to compiler
--compile-id Set the template cache id manually
--compile-map-keys Flag. Enable map keys interface?
--compile-chkmt Flag. Check modification time of the template?
=head1 AUTHOR
C<Burak Gursoy>, E<lt>burakE<64>cpan.orgE<gt>
=head1 COPYRIGHT
Copyright 2004-2017 C<Burak Gursoy>. All rights reserved.
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.12.0 or,
at your option, any later version of Perl 5 you may have available.
=head1 AUTHOR
Burak Gursoy <burak@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Burak Gursoy.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut