Scriptalicious-1.17/0000755000175000017500000000000012317071575013145 5ustar samvsamvScriptalicious-1.17/t/0000755000175000017500000000000012317071575013410 5ustar samvsamvScriptalicious-1.17/t/missing/0000755000175000017500000000000012317071575015061 5ustar samvsamvScriptalicious-1.17/t/missing/Template.pm0000644000175000017500000000004610337206631017163 0ustar samvsamv die "dummy not installed emulation"; Scriptalicious-1.17/t/missing/YAML.pm0000644000175000017500000000004610337206631016152 0ustar samvsamv die "dummy not installed emulation"; Scriptalicious-1.17/t/missing/Pod/0000755000175000017500000000000012317071575015603 5ustar samvsamvScriptalicious-1.17/t/missing/Pod/Constants.pm0000644000175000017500000000001010337206631020075 0ustar samvsamvfailed! Scriptalicious-1.17/t/dump.pl0000644000175000017500000000007310337206631014703 0ustar samvsamv use Scriptalicious; print anydump({ Hello => "world" }); Scriptalicious-1.17/t/06-anydump.t0000644000175000017500000000106111010705500015450 0ustar samvsamv# -*- perl -*- use strict; use warnings; use Test::More tests => 2; use Scriptalicious; $ENV{PERL5LIB} = join ":", "lib", split ":", ($ENV{PERL5LIB} || ""); SKIP: { eval 'use YAML'; if ( $@ ) { skip "YAML not installed",1; } my $output = capture($^X, "t/dump.pl"); is($output, "Hello: world", "YAML anydump"); } $ENV{PERL5LIB} = join ":", "t/missing", split ":", ($ENV{PERL5LIB} || ""); delete $ENV{PERL5OPT}; my $output = capture($^X, "t/dump.pl"); is($output, q{$x = { 'Hello' => 'world' };}, "Data::Dumper anydump"); Scriptalicious-1.17/t/Util.pm0000644000175000017500000000106310337206631014654 0ustar samvsamv use Exporter; use Scriptalicious; use vars qw(@EXPORT $testfile $pid); BEGIN { @EXPORT = qw($testfile); $pid = $$; } $testfile = "/tmp/testfile.$$"; sub slurp { my $fn = shift; open X, "<$fn" or barf "failed to open $fn for slurping; $!"; my @x = ; close X; return join "", @x; } sub slop { my $fn = shift; open X, ">$fn" or barf "failed to slop to $fn; $!"; while ( @_ ) { my $l = shift; $l .= "\n" unless $l =~ /\n/; print X $l; } close X; } END { unlink($testfile) if $testfile and $$ == $pid; } Scriptalicious-1.17/t/02-script.t0000644000175000017500000000157210716740213015316 0ustar samvsamv#!/usr/bin/perl -w for (qw|readonly|) { use strict; use Test::More tests => 6; use Scriptalicious; (my $path = $INC{"Scriptalicious.pm"}) =~ s{/[^/]*$}{}; my $output = join "", capture($^X, "-Mlib=$path", "t/pu.pl"); like($output, qr/^pu: the rc.*\d+$/, "pu.pl runs"); $output = join "", capture($^X, "-Mlib=$path", "t/pu.pl", "-v"); like($output, qr/^doing something with \./m, "pu.pl runs"); like($output, qr/^pu: running `echo/m, "pu.pl runs"); my ($rc, @output) = capture_err($^X, "-Mlib=$path", "t/pu.pl", "-a"); $output = join "", @output; like($output, qr/^pu: aborting:/m, "spots invalid arguments"); like($output, qr/^Try `(pu --help|perldoc.*)'/m, "suggests where to find help"); ($rc, @output) = capture_err($^X, "-Mlib=$path", "t/pu.pl", "--version"); $output = join "", @output; like($output, qr/^This is pu, version 1.00/m, "spots invalid arguments"); } Scriptalicious-1.17/t/loopback.pl0000644000175000017500000000103712317071376015537 0ustar samvsamv use Scriptalicious; my $ifd = fileno(STDIN); my $ofd = fileno(STDOUT); getopt("ifd|i=i" => sub { close STDIN; open STDIN, "<&$_[1]" or do { moan "failed to open input fd $_[1]; $!"; sleep 60; }; }, "ofd|o=i" => sub { close STDOUT; open STDOUT, ">&$_[1]" or do { moan "failed to open output fd $_[1]; $!"; sleep 60; }; }, ); my $lines = 0; while ( ) { $lines++; chomp; say "got `$_'"; } say "saw $lines line(s) on input"; close STDIN; Scriptalicious-1.17/t/07-tsay.t0000644000175000017500000000172511010705471014772 0ustar samvsamv# -*- perl -*- use strict; use warnings; use Test::More tests => 2; use Scriptalicious; $ENV{PERL5LIB} = join ":", "lib", split ":", ($ENV{PERL5LIB} || ""); SKIP: { eval 'use Template'; if ( $@ ) { skip "Template not installed", 1; } my $output = capture($^X, "t/tsay.pl"); is($output, "Hello, Bernie tsay.pl: Yo momma's so fat your family portrait has stretchmarks.", "Template say"); } $ENV{PERL5LIB} = join ":", "t/missing", split ":", ($ENV{PERL5LIB} || ""); delete $ENV{PERL5OPT}; my $output = capture($^X, "t/tsay.pl"); my $expected = <<'EOM'; tsay.pl: warning: failed to include YAML; not able to load config tsay.pl: warning: install Template Toolkit for prettier messages tsay.pl: ----- Template `hello' ----- Hello, [% name %] [% INCLUDE yomomma -%] tsay.pl: ------ Template variables ------ $x = { 'name' => 'Bernie' }; tsay.pl: -------- end of message -------- EOM chomp($expected); is($output, $expected, "no Template say"); Scriptalicious-1.17/t/01-mmmdelicious.t0000644000175000017500000000152110716740456016503 0ustar samvsamv# -*- perl -*- use Test::More tests => 9; BEGIN { use_ok( 'Scriptalicious', -progname => "myscript" ); } start_timer; is($PROGNAME, "myscript", "got PROGNAME ok"); my $string; { local(@ARGV) = ("-v", "-s", "foo"); getopt("string|s=s" => \$string); } is($VERBOSE, 1, "Parsed built-in argument"); is($string, "foo", "Parsed custom argument"); $VERBOSE = 0; ( -e "t/testfile" ) && do { unlink("t/testfile") || die "Can't unlink t/testfile; $!" }; run("touch", "t/testfile"); ok( -f "t/testfile", "run()"); unlink("t/testfile"); my ($error, @output) = capture_err("head -5 $0"); my $output = join "", @output; is($error, 0, "capture_err() - error code"); is($output, `head -5 $0`, "capture_err() - output"); like(show_delta, qr/^\d+(\.\d+)?[mu]?s$/, "show_delta"); like(show_elapsed, qr/^\d+(\.\d+)?[mu]?s$/, "show_elapsed"); Scriptalicious-1.17/t/prompter.pl0000644000175000017500000000126010337206631015605 0ustar samvsamv#!/usr/bin/perl -w use Scriptalicious; my $what = "string"; my $prompt = "enter value:"; my $default = undef; my $for; getopt( "int|i" => sub { $what = "int" }, "string|s" => sub { $what = "string" }, "yn|y" => sub { $what = "yn" }, "yes|Y" => sub { $what = "Yn" }, "no|N" => sub { $what = "yN" }, "prompt|p=s" => \$prompt, "for|f=s" => \$for, "default|D=s" => \$default, ); my $val; if ( $for ) { mutter "prompting for $for ($what)"; $val = prompt_for ( "-$what" => $for, (defined($default) ? ($default) : ()) ); } else { mutter "prompt_$what"; $val = &{"prompt_$what"} ( $prompt, (defined($default) ? ($default) : ()) ); } say "response: `$val'"; Scriptalicious-1.17/t/08-unit.t0000644000175000017500000000065110716740443015001 0ustar samvsamv#!/usr/bin/perl -w # use Test::More no_plan; BEGIN { use_ok( "Scriptalicious" ) }; open POD, "; close POD; ok(@data, "sanity - found examples in the man page"); for (@data) { next unless /\S/; my ($input, $return) = m{\(([^)]+)\)\s*=>\s*"([^"]+)"} or die; is(time_unit(eval $input), $return, "time_unit($input)"); } Scriptalicious-1.17/t/fork.pl0000644000175000017500000000050310337206631014675 0ustar samvsamv use strict; use warnings; use Scriptalicious; sub schleep { select(undef,undef,undef,shift); } defined(my $pid = fork()) or barf "fork failed; $!"; $pid or schleep(0.5); start_timer(); schleep(0.5); say "elapsed (".($pid?"parent":"child").") = ".show_delta(); wait() if $pid; exit( ($? & 255) || ($?>>8) || 0); Scriptalicious-1.17/t/04-fork.t0000644000175000017500000000573612317071373014766 0ustar samvsamv#!/usr/bin/perl # Copyright 2005-2008, Sam Vilain. All rights reserved. This program # is free software; you can use it and/or distribute it under the same # terms as Perl itself; either the latest stable release of Perl when # the module was written, or any subsequent stable release. use warnings; use strict; use t::Util; use Scriptalicious; use Test::More tests => 17; my ($rc, @out) = capture_err($^X, "-Mlib=lib", "t/fork.pl", "-v"); is($rc, 0, "Command completed successfully"); my $out = join "", @out; like($out, qr/\(parent\)/, "Parent managed to use the timer"); like($out, qr/\(child\)/, "Child managed to use the timer"); # test that file descriptors can be fed in lots of different ways slop $testfile, "Hello, world!"; my $output = capture( -in => $testfile, $^X, "-Mlib=lib", "t/loopback.pl"); like($output, qr/:.*Hello, world!/, "run -in => 'FILENAME'"); $output = capture( -in => sub { print "Hi there\n" }, $^X, "-Mlib=lib", "t/loopback.pl"); like($output, qr/:.*Hi there/, "run -in => SUB"); open TEST, "<$testfile" or barf "damn! $!"; $output = capture( -in => \*TEST, $^X, "-Mlib=lib", "t/loopback.pl"); like($output, qr/:.*Hello, world!/, "run -in => GLOB"); close TEST; # output... $output = capture( -out => $testfile, -in => sub { print "Loop this!\n" }, $^X, "-Mlib=lib", "t/loopback.pl"); is($output, "", "run out => 'FILENAME' (no output from capture)"); $output = slurp $testfile; like($output, qr/:.*Loop this!/, "run -out => 'FILENAME'"); $output = capture( -out => sub { my $foo = ; slop $testfile, $foo; }, -in => sub { print "slopslopslop\n" }, $^X, "-Mlib=lib", "t/loopback.pl"); is($output, "", "run out => CODE (no output from capture)"); $output = slurp $testfile; like($output, qr/:.*slopslopslop/, "run -out => CODE"); open TEST, ">$testfile" or barf $!; $output = capture( -out => \*TEST, -in => sub { print "suckonthis!\n" }, $^X, "-Mlib=lib", "t/loopback.pl"); is($output, "", "run out => GLOB (no output from capture)"); close TEST; $output = slurp $testfile; like($output, qr/:.*suckonthis!/, "run -out => GLOB"); # explicit file descriptors... slop $testfile, "Burp"; $output = capture( -in4 => $testfile, $^X, "-Mlib=lib", "t/loopback.pl", qw(-i 4)); like($output, qr/Burp/, "-in4 => 'FILENAME'"); slop $testfile, "Burp"; $output = capture( -in => sub { print "It should be so easy!\n" }, -out4 => $testfile, $^X, "-Mlib=lib", "t/loopback.pl", qw(-o 4)); is($output, "", "-out4 => 'FILENAME' (no output from capture)"); $output = slurp $testfile; like($output, qr/:.*easy!/, "run -out4 => 'FILENAME'"); # last out! $output = capture( -in5 => sub { print "slurpamunchalot\n" }, -out4 => sub { my $foo = ; slop $testfile, $foo }, $^X, "-Mlib=lib", "t/loopback.pl", qw(-o 4 -i 5)); is($output, "", "run -out4 => CODE, -in4 => CODE (no output from capture)"); $output = slurp $testfile; like($output, qr/:.*slurpamunchalot/, "run -out4 => CODE, -in4 => CODE"); Scriptalicious-1.17/t/09-noyaml.t0000644000175000017500000000046710717130373015323 0ustar samvsamv# -*- perl -*- use lib "t/missing"; use Test::More tests => 2; use_ok( 'Scriptalicious', -progname => "noyaml" ); { local(*STDERR); open STDERR, ">/dev/null"; getconf_f ("t/eg.conf", ( "something|s" => \$foo, ) ); } is($foo, undef, "didn't load config without YAML (and didn't die)"); Scriptalicious-1.17/t/tsay.pl0000644000175000017500000000031410337206631014714 0ustar samvsamv use Scriptalicious; tsay hello => { name => "Bernie" }; __END__ __hello__ Hello, [% name %] [% INCLUDE yomomma -%] __yomomma__ [% PROGNAME %]: Yo momma's so fat your family portrait has stretchmarks. Scriptalicious-1.17/t/05-prompt.t0000644000175000017500000000061010337206631015326 0ustar samvsamv#!/usr/bin/perl use Scriptalicious; use Test::More tests => 2; #use t::Util; my $output = capture( -in => sub { print "Hi there\n17\n"; }, #-out2 => $testfile, $^X, "-Mlib=lib", "t/prompter.pl", "--int" ); #my $err = slurp $testfile; like($output, qr/response: `17'/, "got right answer"); like($output, qr/bad.*`Hi there'/, "spotted wrong answer"); # full test Scriptalicious-1.17/t/03-yaml.t0000644000175000017500000000163210717126741014757 0ustar samvsamv# -*- perl -*- use Test::More; BEGIN { eval { require YAML; YAML->import }; if ($@) { plan skip_all => "YAML not installed"; } else { plan tests => 9; } } BEGIN { use_ok( 'Scriptalicious', -progname => "myscript" ); } getconf_f ("t/eg.conf", ( "something|s" => \$foo, "invertable1|I!" => \$invertable1, "invertable2|J!" => \$invertable2, "integer|i=i" => \$integer, "string|s=s" => \$string, "list1|1=s@" => \@list1, "list2|2=s@" => \@list2, "hash|H=s%" => \%hash, ) ); is($foo, 1, "plain string"); is($invertable1, 1, "boolean - on"); is($invertable2, 0, "boolean - off"); is($integer, 7, "integer"); is($string, "anything", "string"); is_deeply(\@list1, [qw(one two three)], "list 1 (flow)"); is_deeply(\@list2, [qw(one two three)], "list 2 (inline)"); is_deeply(\%hash, {foo=>"bar",baz=>"cheese"}, "hash"); Scriptalicious-1.17/t/pu.pl0000644000175000017500000000172210337206631014364 0ustar samvsamv use Scriptalicious -progname => "pu"; our $VERSION = "1.00"; my $url = "."; getopt("u|url" => \$url); run("echo", "doing something with $url"); my ($rv, $output) = capture_err("cat", $url); say "the rc from the `cat $url' command was $?"; __END__ =head1 NAME pu - an uncarved block of wood =head1 SYNOPSIS pu [options] arguments =head1 DESCRIPTION This script's function is to be a blank example that many great and simple scripts may be built upon. Remember, you cannot carve rotten wood. =head1 COMMAND LINE OPTIONS =over =item B<-h, --help> Display a program usage screen and exit. =item B<-V, --version> Display program version and exit. =item B<-v, --verbose> Verbose command execution, displaying things like the commands run, their output, etc. =item B<-q, --quiet> Suppress all normal program output; only display errors and warnings. =item B<-d, --debug> Display output to help someone debug this script, not the process going on. =back Scriptalicious-1.17/t/eg.conf0000644000175000017500000000032010337206631014636 0ustar samvsamv# example config file for test script 3 something: 1 invertable1: on invertable2: off integer: 7 string: anything list1: - one - two - three list2: [ one, two, three ] hash: foo: bar baz: cheese Scriptalicious-1.17/README0000644000175000017500000000343210337206631014020 0ustar samvsamvREADME for Scriptalicious ~~~~~~~~~~~~~~~~~~~~~~~~~ This is a simple little module that contains a few of the things that I just wished Perl came with for writing SysAdmin scripts. Using this module, it is very easy to write programs which more or less adhere to the GNU program conventions for well behaved programs. Things like printing the name of your program before all messages. It is suggested that you try the example in the manual page, and see how it responds to `-v', '-h', unknown switches, etc. Required Modules ^^^^^^^^^^^^^^^^ Module::Build is required to build and install the module. Test::Simple is required to run the test suite. Other than this, there should be no `hard' dependancies, other than modules that come with 5.6.1. However, scripts that use this module don't show help messages without Pod::Constants. Recommended Modules ^^^^^^^^^^^^^^^^^^^ If you want the scripts that use this module to display their help messages, you need to install Pod::Constants, which requires Pod::Parser (which should be standard with recent Perls). If you don't, you can still use `perldoc foo.pl' on the installed scripts, so it's still better than nothing. You will need the YAML module for the nifty new getopt-style YAML config file processor. Optional Modules ^^^^^^^^^^^^^^^^ If you want your help screens to look nice with all terminal sizes, you will need Term::ReadKey. If you want accurate timing information about how long programs take to execute when you use `-v', you will need Time::HiRes installed. Installation instructions ^^^^^^^^^^^^^^^^^^^^^^^^^ Once you have satisfied yourself that you have installed Module::Build and and the recommended and enough to satisfy your hunger for modules, you should To install this module. perl Build.PL ./Build test ./Build install Scriptalicious-1.17/Changes.pod0000644000175000017500000001124512317071430015212 0ustar samvsamv =head1 WHATS NEW IN SCRIPTALICIOUS =head2 VERSION 1.17 =over =item Fix deadlock with C sub { ... }> Between Perl versions 5.17.5 and 5.17.6, a change was introduced which exposed a common pipe deadlock bug in this module, if you used closures which handle filehandles. [closes: RT#85999] =back =head2 VERSION 1.16 =over =item Clear PERL5OPT before invoking $^X in tests To hopefully resolve some false failures =item Fix code for case when Time::HiRes is not available I never got a report about this, but it clearly didn't work! Guess no-one's using a Perl before 5.7.3 or without that module any more. =item put the magic AUTOLOAD back Scriptalicious will do most of its core stuff without compiling most of itself, and there is an AUTOLOAD hook which puts them into place. I decided to re-enable it. =item remove (soft) dependency on Pod::Constants Scriptalicious scripts are less delicious without a working --help, and many systems did not bother with this soft dependency, so it is of benefit to just implement what that code did instead. =item new $CONFIG variable Used for telling where config was read from (or specifying where it is to be read from) =item deal with negative values in sci_unit and time_unit These functions didn't deal with negative input; fix that. =back =head2 VERSION 1.15 =over =item Add missing copyright notices and license. Gah, sorry about this. Note that it is a retrospective license, so you don't need to 'upgrade' to this version to copy the software. =back =head2 VERSION 1.14 =over =item 5.6.x compat: fix missed instance of unquoted filehandle in test suite =back =head2 VERSION 1.13 =over =item 5.6.x compat: don't use readline FH; use instead =item Don't die if getconf is called without YAML installed; warn instead =item Make YAML config test conditional on YAML being installed =item Fix incorrectly written e-mail address in Makefile.PL =item Remove TODO file; these features have been added! =back =head2 VERSION 1.12 =over =item Add getopt_lenient() =item Add time_unit() function =item Use time_unit instead of sci_unit in show_elapsed/show_delta =item Fix test that was still testing for ยต =back =head2 VERSION 1.11 =over =item Drop C dependency Go back to C. =item Fix various problems with prompt_* =item Add C and C functions =item Make C optional for getting verbosity right =item Functions don't clobber $_ (Gerard Goosen) =back =head2 VERSION 1.10 Add prompt_file from an earlier branch. Fix F so a compatibility Makefile.PL is generated. =head2 VERSION 1.09 Another "brown paper bag release". Fixed a bug in tsay that would cause it not to work if there was a true value in $1 already. Bring on Perl 6 and lexical $/. =head2 VERSION 1.08 Added new functions 'anydump' and the awesome 'tsay' =head2 VERSION 1.07 Brown paper bag release - the prompting had some debug statements left behind. =head2 VERSION 1.06 Documentation modifications only; it was quite rightly pointed out that the documentation didn't really say what the script is useful for. =head2 VERSION 1.05 =over =item B Prompt the user for arbitrary things via prompt_for(-int => "foo"), with readline support. =item B All functions that run things (ie C, C, C and C can now have arbitrary filehandle connections to closures (via a sub-process), named files or filehandles. =back =head2 VERSION 1.04 Bug fix for scripts that fork (see F) =head2 VERSION 1.03 =over =item B Do your C and C in one pass! See C in the man page. You can even include the default YAML configuration file in your POD via Pod::Constants! Soon to be documented and tested by the test suite :). But the daring can go put some YAML in a section called "C" =item B New timer utility functions C, C, C =item bugfix C now does not make your script exit if inside C; it checks C<$^S> and re-throws the error instead. =back =head2 Historic releases Version 1.02 - Thu, 15 Apr 2004 12:24:16 +1200 * Made barf actually barf :-} * Fixed bug with capture and -v - error "Warning: unable to close filehandle CHILD properly." * output from capture_err matches documentation Version 1.01 - Tue, 13 Apr 2004 10:26:27 +1200 * Fixed version number input - now accepts $main::VERSION as per widespread convention * Added SEE ALSO section based on feedback from module- authors@perl.org =cut Scriptalicious-1.17/Makefile.PL0000644000175000017500000000120211301342141015070 0ustar samvsamv#!/usr/bin/perl # use ExtUtils::MakeMaker; # See perldoc Module::Build for details of how this works my @recommends = qw(Text::Wrap Time::HiRes YAML); for my $module ( @recommends ) { eval "use $module"; if ( $@ ) { warn "Failed to load optional dependency $module ($@)"; } } WriteMakefile ( NAME => 'Scriptalicious', VERSION_FROM => "lib/Scriptalicious.pm", ( ( $] >= 5.005 ) ? ( ABSTRACT => "Make scripts more delicious to SysAdmins", AUTHOR => "Sam Vilain ", ) : () ), PREREQ_PM => { 'Test::More' => 0, 'Term::ReadKey' => 0, }, NO_META => 0, ); Scriptalicious-1.17/MANIFEST0000644000175000017500000000073111367440121014266 0ustar samvsamvChanges.pod lib/Scriptalicious.pm lib/Scriptalicious.pod Makefile.PL MANIFEST This list of files README SIGNATURE t/01-mmmdelicious.t t/02-script.t t/03-yaml.t t/04-fork.t t/05-prompt.t t/06-anydump.t t/07-tsay.t t/08-unit.t t/09-noyaml.t t/dump.pl t/eg.conf t/fork.pl t/loopback.pl t/missing/Pod/Constants.pm t/missing/Template.pm t/missing/YAML.pm t/prompter.pl t/pu.pl t/tsay.pl t/Util.pm META.yml Module meta-data (added by MakeMaker) Scriptalicious-1.17/SIGNATURE0000644000175000017500000000512012317071550014420 0ustar samvsamvThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.73. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA512 SHA1 566c4a39f138f573e0180135ebd5ccb65c3c0c43 Changes.pod SHA1 41236ad9cb13c0abf09d7dc8d8b93b9c4e215c1c MANIFEST SHA1 a6b58872fa78436fe38ae7417e409c52f3b6d9f7 META.yml SHA1 0fa9575de5e9a121ca074b68aae2d669909f3a74 Makefile.PL SHA1 260379dc3c27fc8aa6e64273b0b94580fda0750d README SHA1 f224f94e8c664df8970684fc09837d3aa4769a3a lib/Scriptalicious.pm SHA1 bb097482d7d16feadacaa72249cce22b24901b6b lib/Scriptalicious.pod SHA1 4fa577b375f1bd148f072ecf56079c5d19b6cdd0 t/01-mmmdelicious.t SHA1 14b11bbbc6e41cf3e018a00f99f8ae63e369c028 t/02-script.t SHA1 13216c981df5928b2e72034bc6cfb17964b0483f t/03-yaml.t SHA1 91ba3e39ceda09362a5dedff0e213818537ed03d t/04-fork.t SHA1 fca1712dcc759e3eb3e1033dcb5bd71f3ec8f590 t/05-prompt.t SHA1 25a798e881538c59b3ec548c209ba5b02f1b7130 t/06-anydump.t SHA1 b9d619e9eb205cc321442e9b22462f4dc92fa915 t/07-tsay.t SHA1 be2c3bd65c45847938219492142254b6645274a3 t/08-unit.t SHA1 68aff9f78699052e3a3b3b1653d6fa8fbdb0d794 t/09-noyaml.t SHA1 8078519cfb2b235edb7c89c33b31d29af1a6dc7f t/Util.pm SHA1 faaf4c3ba63c7978ba348aebbceedfc1d8b8d639 t/dump.pl SHA1 0923940238fc4b05b2af2b029e32ac8c67ea6e6e t/eg.conf SHA1 6c70d4016856ac3941c077ed9df8d2d1e98d547a t/fork.pl SHA1 945fe09f02d32b8d75d0ae110d48d833b443d0b9 t/loopback.pl SHA1 fe7c9271665cda30ced18f74c5442d4864f04075 t/missing/Pod/Constants.pm SHA1 dacb6cd4c86d4dda967ab60037dddc36dd0e8c68 t/missing/Template.pm SHA1 dacb6cd4c86d4dda967ab60037dddc36dd0e8c68 t/missing/YAML.pm SHA1 f70a86242836ca20d5546db52c164a9ec045f508 t/prompter.pl SHA1 fc3174c15673596fb885b8843da1ad22ce531d96 t/pu.pl SHA1 a91f4452b7d540b79df8ab2be7766c7739c62804 t/tsay.pl -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.14 (GNU/Linux) iQEcBAEBCgAGBQJTPHNlAAoJEBdtaL3wGtIoiMMH+wUOWCbLeItRvkxdqa9WHOC+ VmDCeVHeV2kReJr5uXSsIpB8JVjlds8GnSThFW+hd8sF5Yz8UL+G1Z7QXjFwlGgr XFUeJkjbcIk1OFtSlJcDEXfiLZPrlxt+bho/4Z7+nDdBQpsHm+pPl1v1IByV0JiR Ag3UILl7NLDwYGc39q5KUxJyb/G3b4MlRcVoK/pVIU2V83BgtT4zYNf4lqtC+lhJ If8DFl6RhlJVUkMSJJW03tqydYFGt9VZorfW4yjFv5CsRjSTNHHVUqDolqM3MDuz B93xvRy+FbDh5xVKiWIsi2dM7CZH29Kr8Hr5Fv22ThshzTTDotIvfYZU36cx9R0= =LR+k -----END PGP SIGNATURE----- Scriptalicious-1.17/META.yml0000664000175000017500000000110712317071575014417 0ustar samvsamv--- #YAML:1.0 name: Scriptalicious version: 1.17 abstract: Make scripts more delicious to SysAdmins author: - Sam Vilain license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Term::ReadKey: 0 Test::More: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Scriptalicious-1.17/lib/0000755000175000017500000000000012317071575013713 5ustar samvsamvScriptalicious-1.17/lib/Scriptalicious.pm0000644000175000017500000006636412317071332017254 0ustar samvsamv # Copyright 2005-2008, Sam Vilain. All rights reserved. This program # is free software; you can use it and/or distribute it under the same # terms as Perl itself; either the latest stable release of Perl when # the module was written, or any subsequent stable release. # # Please note that this applies retrospectively to all Scriptalicious # releases; apologies for the lack of an explicit license. package Scriptalicious; use 5.006; use strict; use warnings; use Carp qw(croak); our $VERSION = "1.17"; use Getopt::Long; use base qw(Exporter); BEGIN { # export groups, phtoey! our @EXPORT = qw(say mutter whisper abort moan barf run run_err capture capture_err getopt $VERBOSE $PROGNAME $CONFIG start_timer show_delta show_elapsed getconf getconf_f sci_unit prompt_for prompt_passwd prompt_yn prompt_Yn prompt_yN prompt_string prompt_nY prompt_Ny prompt_ny prompt_int tsay anydump prompt_regex prompt_sub prompt_file hush_exec unhush_exec getopt_lenient time_unit ); } # define this in subclasses where appropriate sub __package__ { __PACKAGE__ } our ($VERBOSE, $closure, $SHOW_CMD_VERBOSE, $gotconf); $VERBOSE = 0; $SHOW_CMD_VERBOSE = 1; #--------------------------------------------------------------------- # parse import arguments and export symbols #--------------------------------------------------------------------- sub import { my $pkg = shift; no strict 'refs'; # look for options in the importer arguments for ( my $i = 0; $i < $#_; $i++ ) { if ( $_[$i] =~ m/^-(.*)/ ) { die "Bad option `$1' from $pkg" unless *{uc($1)}{SCALAR}; my $x = uc($1); ($x eq "VERSION") && ($x="main::$x"); ${$x} = $_[$i+1]; (@_) = (@_[0..($i-1)], @_[($i+2)..$#_]); $i--; } } unshift @_, $pkg; goto &Exporter::import; } # automatically guess the program name if called for (our $PROGNAME = $0) =~ s{.*/}{} unless $PROGNAME; our $CONFIG; BEGIN { Getopt::Long::config("bundling", "pass_through"); } END { $closure->() if $closure } sub getopt_lenient { local($closure) = \&show_usage; $gotconf = 1; Getopt::Long::GetOptions ( 'help|h' => \&show_help, 'verbose|v' => sub { $VERBOSE++ }, 'quiet|q' => sub { $VERBOSE = -1 }, 'debug|d' => sub { $VERBOSE = 2 }, 'version|V' => \&show_version, @_, ); # check for unknown arguments and print a nice error message # instead of the nasty default Getopt::Long message shift @ARGV, return if $#ARGV >= 0 and $ARGV[0] eq "--"; } sub getopt { local($closure) = \&show_usage; getopt_lenient(@_); abort("unrecognised option: $ARGV[0]") if $#ARGV >= 0 and $ARGV[0] =~ m/^-/; } sub say { _autoconf() unless $gotconf; print "$PROGNAME: @_\n" unless $VERBOSE < 0 } sub mutter { say @_ if $VERBOSE } sub whisper { say @_ if $VERBOSE > 1 } sub _err_say { _autoconf() unless $gotconf; print STDERR "$PROGNAME: @_\n" } sub abort { _err_say "aborting: @_"; &show_usage; } sub moan { _err_say "warning: @_" } sub protest { _err_say "error: @_" } sub barf { if($^S){die @_}else{ _err_say "ERROR: @_"; exit(1); } } sub _autoconf { getopt_lenient( eval{ my @x = getconf(@_); @x } ) } #--------------------------------------------------------------------- # helpers for running commands and/or capturing their output #--------------------------------------------------------------------- our (@output, $next_cmd_no_hide, $next_cmd_capture); # use Shell::QuoteEscape? nah :-) my %map = ((map { chr($_) => sprintf("\\%.3o",$_) } (0..31, 127..255)), " "=>" ","\t"=>"\\t","\r"=>"\\r","\n"=>"\\n", "\""=>"\\\""); sub shellquote { return join(" ",map { m/[\s\']/ && do { s/[\0-\031"\s\177-\377]/$map{$&}/eg; $_ = "\"$_\""; }; $_ } map { $_ } @_); } our @SHOW_CMD_VERBOSE; sub hush_exec { push @SHOW_CMD_VERBOSE, $SHOW_CMD_VERBOSE; $SHOW_CMD_VERBOSE=2; } sub unhush_exec { $SHOW_CMD_VERBOSE = pop @SHOW_CMD_VERBOSE; } our @last_cmd; sub run { &run_err(@_); @_ = @last_cmd; my $start = $#output - 10; chomp($output[$#output]) if @output; $start = 0 if $start < 0; barf( (ref $_[0] ? "Sub-process " : "Command `".shellquote(@_)."' "). (($? >> 8) ? "exited with error code ".($?>>8) : "killed by signal $?") .(($VERBOSE >= $SHOW_CMD_VERBOSE or $next_cmd_no_hide) ? "" : (($start != 0 ? "\nlast lines of output:\n" : "\nprogram output:\n") .join("", @output[$start .. $#output]) .($start != 0 ? "(use -v to show complete program output)" : ""))) ) if ($?); } sub do_fork { @output = (); if (not $next_cmd_capture and ( $VERBOSE >= $SHOW_CMD_VERBOSE or $next_cmd_no_hide )) { return fork() } else { my $pid = open CHILD, "-|"; if (defined($pid) && !$pid) { open STDERR, ">&STDOUT"; } return $pid; } } sub _waitpid { my $pid = shift; if (not $next_cmd_capture and ($VERBOSE >= $SHOW_CMD_VERBOSE or $next_cmd_no_hide)) { waitpid($pid, 0); } else { while (my $line = ) { push @output, $line; } close CHILD; } } sub _load_hires { return if defined &gettimeofday; eval "use Time::HiRes qw(gettimeofday tv_interval)"; *gettimeofday = sub { return time() } unless defined &gettimeofday; *tv_interval = sub { return ${$_[0]}[0] - ${$_[1]}[0] } unless defined &tv_interval; } sub run_err { my %fds; my $fd_desc = ""; while ( $_[0] and !ref $_[0] and $_[0]=~/^-(in|out|rw)(\d+)?$/ ) { shift; my $mode = ($1 eq "in" ? "<" : ($1 eq "out" ? ">" : "+<") ); my $fd = $2 || ($1 eq "out" ? 1 : 0); $fds{"$fd"} = [ $mode, shift ]; $fd_desc .= ($fd_desc ? ", " : "") . "fd$fd=$mode$fds{$fd}"; } @last_cmd = @_; if ( $VERBOSE >= $SHOW_CMD_VERBOSE ) { say("running `".shellquote(@last_cmd)."'" .($next_cmd_capture ? " (captured)" : "") .($fd_desc?"($fd_desc)":"") ) unless ref($_[0]); } _load_hires; my $start = start_timer(); my $output; if (my $pid = do_fork) { local $SIG{INT} = sub { kill 2, $pid }; $output = &_waitpid($pid); } else { barf "Fork failed; $!" if not defined $pid; setup_fds(\%fds) if $fd_desc; if (ref $_[0]) { my $code = shift; $code->(@_); exit(0); } else { exec(@_) || barf "exec failed; $!"; } } if ( $VERBOSE >= $SHOW_CMD_VERBOSE ) { say sprintf("command completed in ".show_elapsed($start)) } return $? } sub capture { local($next_cmd_capture) = 1; run(@_); return (wantarray ? @output : join("", @output)); } sub capture_err { local($next_cmd_capture) = 1; my $rv = run_err(@_); return ($rv, @output) } sub capture2 { die "capture2 not implemented yet" } our $DATA = join "", ; close DATA; our ($AUTOLOAD, $l);sub AUTOLOAD{croak"No such function $AUTOLOAD"if $l;(undef,my($f,$n))=ll();$n+=1;eval"package ".__PACKAGE__.";\n" ."# line $n \"$f\"\n$DATA"; $@&&die"Error in autoload: $@"; $l=1;goto &{$AUTOLOAD};}sub ll{sub{caller()}->();} "P E A C E"; __DATA__ our ($NAME, $SHORT_DESC, $SYNOPSIS, $DESCRIPTION, @options); #--------------------------------------------------------------------- # get the synopsis, etc, from the calling script. #--------------------------------------------------------------------- sub _get_pod_usage { return if $SYNOPSIS; our $level; open SCR_POD, $0 or warn "failed to open $0 for reading; $!"; my $targ; my $in_options; my $name_desc; local($_); while () { if ( !m{^=} and $targ ) { $$targ .= $_; } if ( m{^=encoding (\w+)} ) { binmode SCR_POD, ":$1"; } elsif ( m{^=head\w\s+SYNOPSIS\s*$} ) { $targ = \$Scriptalicious::SYNOPSIS; } elsif ( m{^=head\w\s+DESCRIPTION\s*$} ) { $targ = \$Scriptalicious::DESCRIPTION; } elsif ( m{^=head\w\s+NAME\s*$} ) { $targ = \$name_desc; } elsif ( m{^=head\w\s+COMMAND[\- ]LINE OPTIONS\s*$} ) { undef($targ); $in_options = 1; } elsif ( $in_options ) { if ( m{^=over} ) { $level++ } elsif ( m{^=item\s+(.*)} ) { next unless $level == 1; my $switches = $1; $switches =~ s{[BCI]<([^>]*)>}{$1}g; my (@switches, $longest); $longest = ""; for my $switch ($switches =~ m/\G ((?:-\w|--\w+)) (?:,\s*)? /gx) { push @switches, $switch; if ( length $switch > length $longest) { $longest = $switch; } } $longest =~ s/^-*//; my $opt_hash = { options => \@switches, description => "", }; $targ = \$opt_hash->{description}; push @options, $longest, $opt_hash; } elsif ( m{^=back} ) { if ( --$level == 0 ) { undef($in_options); } } } } if ( $name_desc ) { $name_desc =~ m{^(\S+)(?:\s+-\s+(.*))?$}; $PROGNAME ||= $1; $SHORT_DESC ||= $2; } foreach ( $SYNOPSIS, $SHORT_DESC, $DESCRIPTION ) { $_ ||= "(not found in POD)"; } } sub short_usage { _get_pod_usage; return ("Usage: $SYNOPSIS\n" ."Try " .($SHORT_DESC ? "`$PROGNAME --help' for a summary of options." : "`perldoc $0' for more information") ."\n"); } sub usage { _get_pod_usage; if ( !$SHORT_DESC ) { moan("failed to extract usage information from POD; calling " ."perldoc"); exec("perldoc", $0) || barf "exec failed; $!"; } eval "use Text::Wrap qw(wrap fill)"; *wrap = sub { return join "", @_ } unless defined &wrap; *fill = sub { return join "", @_ } unless defined &fill; my $TOTAL_WIDTH; eval "use Term::ReadKey;"; if ( defined &GetTerminalSize ) { $TOTAL_WIDTH = (GetTerminalSize())[0] - 10; } $TOTAL_WIDTH ||= 70; my $options_string; my $OPTIONS_INDENT = 2; my $OPTIONS_WIDTH = 20; my $OPTIONS_GAP = 2; my $DESCRIPTION_WIDTH = ($TOTAL_WIDTH - $OPTIONS_GAP - $OPTIONS_INDENT - $OPTIONS_WIDTH); # go through each option, and format it for the screen for ( my $i = 0; $i < (@options>>1); $i ++ ) { my $option = $options[$i*2 + 1]; $Text::Wrap::huge = "overflow"; $Text::Wrap::columns = $OPTIONS_WIDTH; my @lhs = map { split /\n/ } wrap("","",join ", ", sort { length $a <=> length $b } @{$option->{options}}); $Text::Wrap::huge = "wrap"; $Text::Wrap::columns = $DESCRIPTION_WIDTH; my @rhs = map { split /\n/ } fill("","",$option->{description}); while ( @lhs or @rhs ) { my $left = shift @lhs; my $right = shift @rhs; $left ||= ""; $right ||= ""; chomp($left); $options_string .= join ("", " " x $OPTIONS_INDENT, $left . (" " x ($OPTIONS_WIDTH - length $left)), " " x $OPTIONS_GAP, $right, "\n"); } } $Text::Wrap::huge = "overflow"; $Text::Wrap::columns = $TOTAL_WIDTH; $DESCRIPTION =~ s{\n\n}{\n\n<-->\n\n}gs; $DESCRIPTION = fill(" ", " ", $DESCRIPTION); $DESCRIPTION =~ s{^.*<-->.*$}{}mg; return (fill("","",$PROGNAME . " - " . $SHORT_DESC) ."\n\n" ."Usage: ".$SYNOPSIS."\n\n" .$DESCRIPTION."\n\n" .fill(""," ","Command line options:") ."\n\n" .$options_string."\n" ."See `perldoc $0' for more information.\n\n"); } sub show_usage { print STDERR &short_usage; exit(1); } sub show_version { print "This is ".$PROGNAME.", " .( defined($main::VERSION) ? "version ".$main::VERSION."\n" : "with no version, so stick it up your source repository!\n" ); exit(0); } sub show_help { print &usage; exit(0); } my ($start, $last); sub start_timer { _load_hires(); if ( !defined wantarray ) { $last = $start = [gettimeofday()]; } else { return [gettimeofday()]; } } sub show_elapsed { my $e = tv_interval($_[0]||$start, [gettimeofday()]); return time_unit($e, 3); } sub show_delta { my $now; my $e = tv_interval($_[0]||$last, $now = [gettimeofday()]); $last = $now; return time_unit($e, 3); } use POSIX qw(ceil); my @time_mul = (["w", 7*86400], ["d", 86400, " "], ["h", 3600, ":"], ["m", 60, ":" ], ["s", 1, 0], [ "ms", 0.001 ], [ "us", 1e-6 ], ["ns", 1e-9]); sub time_unit { my $scalar = shift; my $neg = $scalar < 0; if ($neg) { $scalar = -$scalar; } my $d = (shift) || 4; if ($scalar == 0) { return "0s"; } my $quanta = exp(log($scalar)-2.3025851*$d); my $rem = $scalar+0; my $rv = ""; for my $i (0..$#time_mul) { my $unit = $time_mul[$i]; if ($rv or $unit->[1] <= $rem ) { my $x = int($rem/$unit->[1]); my $new_rem = ($x ? $rem - ($x*$unit->[1]) : $rem); my $last = ($time_mul[$i+1][1]<$quanta); if ($last and $new_rem >= $unit->[1]/2) { $x++; } if (!$last and $unit->[2]) { $rv .= $x.$unit->[0].$unit->[2]; } elsif (defined $unit->[2] and !$unit->[2]) { # stop at seconds my $prec = ceil(-log($quanta)/log(10)-1.01); if ( $prec >= 1 ) { $rv .= sprintf("%.${prec}f", $rem).$unit->[0]; } else { $rv .= sprintf("%d", $rem).$unit->[0]; } last; } else { $rv .= $x.$unit->[0]; } last if $last; $rem = $new_rem; } } ($neg?"-":"").$rv; } my %prefixes=(18=>"E",15=>"P",12=>"T",9=>"G",6=>"M",3=>"k",0=>"", -3=>"m",-6=>"u",-9=>"n",-12=>"p",-15=>"f",-18=>"a"); sub sci_unit { my $scalar = shift; my $neg = $scalar < 0 ? "-" : ""; if ($neg) { $scalar = -$scalar; } my $unit = (shift) || ""; my $d = (shift) || 4; my $e = 0; #scale value while ( abs($scalar) > 1000 ) { $scalar /= 1000; $e += 3; } while ( $scalar and abs($scalar) < 1 ) {$scalar*=1000;$e-=3} # round the number to the right number of digits with sprintf if (exists $prefixes{$e}) { $d -= ceil(log($scalar)/log(10)); $d = 0 if $d < 0; my $a = sprintf("%s%.${d}f", $neg, $scalar); return $a.$prefixes{$e}.$unit; } else { return sprintf("%s%${d}e", $neg, $scalar).$unit; } } sub getconf { my $conf_obj; eval 'use YAML'; if ($@) { local($gotconf) = 1; moan "failed to include YAML; not able to load config"; return @_; } for my $loc ( $CONFIG, "$ENV{HOME}/.${PROGNAME}rc", "/etc/perl/$PROGNAME.conf", "/etc/$PROGNAME.conf", "POD" ) { next if not defined $loc; eval { $conf_obj = getconf_f($loc, @_); }; if ( $@ ) { if ( $@ =~ /^no such config/ ) { next; } else { barf "error processing config file $loc; $@"; } } else { $CONFIG = $loc; last; } } if ( wantarray ) { return @_; } else { return $conf_obj; } } sub getconf_f { my $filename = shift; eval 'use YAML'; if ($@) { local($gotconf) = 1; moan "failed to include YAML; not able to load config"; return @_; } my $conf_obj; if ( $filename eq "POD" ) { eval "use Pod::Constants"; barf "no such config file " if $@; my $conf; Pod::Constants::import_from_file ($0, "DEFAULT CONFIG FILE" => \$conf); $conf or barf "no such config section"; eval { $conf_obj = YAML::Load($conf) }; } else { barf "no such config file $filename" unless -f $filename; open CONF, "<$filename" or barf "failed to open config file $filename; $!"; whisper "about to set YAML on config file $filename"; eval { $conf_obj = YAML::Load(join "", ); }; close CONF; } barf "YAML exception parsing config file $filename: $@" if $@; whisper "YAML on config file $filename complete"; return _process_conf($filename, $conf_obj, @_); } sub _process_conf { my $filename = shift; my $conf_obj = shift; my @save__ = @_ if wantarray; while ( my ($opt, $target) = splice @_, 0, 2 ) { # wheels, reinvented daily, around the world. my ($opt_list, $type) = ($opt =~ m{^([^!+=:]*)([!+=:].*)?$}); $type ||= ""; my @names = split /\|/, $opt_list; for my $name ( @names ) { if ( exists $conf_obj->{$name} ) { whisper "found config option `$name'"; my $val = $conf_obj->{$name}; # if its a hash or a list, don't beat around the bush, # just assign it. if ( $type =~ m{\@$} ) { ref $target eq "ARRAY" or croak("$opt: list options must be assigned " ."to an array ref, not `$target'"); ref $val eq "ARRAY" or barf("list specified in config options, " ."but `$val' found in config file " ." $filename for option $name" .($name ne $names[0] ? " (synonym for $names[0])" : "")); @{$target} = @{$val}; last; } elsif ( $type =~ m{\%$} ) { ref $target eq "HASH" or croak("$opt: hash options must be assigned " ."to a hash ref, not `$target'"); ref $val eq "HASH" or barf("hash specified in config options, " ."but `$val' found in config file " ." $filename for option $name" .($name ne $names[0] ? " (synonym for $names[0])" : "")); %{$target} = %{$val}; last; } # check its type elsif ( $type =~ m{^=s} ) { # nominally a string, but actually allow anything. } elsif ( $type =~ m{^=i} ) { $val =~ m/^\d+$/ or barf ("option `$name' in config file $filename " ."must be an integer, not `$val'"); } elsif ( $type =~ m{^=f} ) { $val =~ m/^[+-]?(\d+\.?|\d*\.)(\d+)/ or barf ("option `$name' in config file $filename " ."must be a real number, not `$val'"); $val += 0; } elsif ( $type =~ m{!} ) { my ($is_true, $is_false) = ($val =~ m/^(?:(y|yes|true|on|1|yang) |(n|no|false|off|0|yin|))$/xi) or barf ("option `$name' in config file $filename " ."must be yin or yang, not a suffusion of " ."yellow"); $val = $is_true ? 1 : 0; } else { $val = 1; } # process it croak("$opt: simple options must be assigned " ."to a scalar or code ref, not `$target'") unless (ref $target and (ref $target)=~ /CODE|SCALAR|REF/); if ( ref $target eq "CODE" ) { $target->($names[0], $val); } else { $$target = $val; } last; } } } if ( wantarray ) { return @save__; } else { return $conf_obj } } our $term; our $APPEND; sub term { #print "PACKAGE is ".__PACKAGE__."\n"; $term ||= do { eval { -t STDIN or die; require Term::ReadLine; Term::ReadLine->new(__PACKAGE__) } || (bless { IN => \*STDIN, OUT => \*STDOUT }, __PACKAGE__); }; #print "TERM is $term\n"; return $term; } sub OUT { $_[0]->{OUT} } sub IN { $_[0]->{IN} } sub readline { my $self = shift; my $prompt = shift; my $OUT = $self->OUT; my $IN = $self->IN; print $OUT "$prompt? "; my $res = readline $IN; chomp($res); return $res; } sub prompt_passwd { my $prompt = shift || "Password: "; eval { require Term::ReadKey; }; barf "cannot load Term::ReadKey" if $@; Term::ReadKey::ReadMode('noecho'); my $passwd; eval { $passwd = prompt_sub($prompt, @_) }; Term::ReadKey::ReadMode('restore'); die $@ if $@; $passwd; } sub prompt_sub { my $prompt = shift; # I'm a whitespace nazi! :) $prompt =~ s{$}{ } unless $prompt =~ /\s$/; my $sub = shift; my $moan = shift; while ( defined ($_ = term->readline($prompt)) ) { if ( $sub ) { if ( defined(my $res = $sub->($_)) ) { return $res; } else { protest ($moan || "bad response `$_'"); } } else { return $_; } } barf "EOF on input"; } sub prompt_regex { my $prompt = shift; my $re = shift; prompt_sub($prompt, (ref $re eq "CODE" ? $re : sub { if ( my ($match) = m/$re/ ) { return (defined($match) ? $match : $_) } else { return undef; } }), @_); } sub prompt_for { my $type; if (@_ > 1 and $_[0]=~/^-(.*)/) { $type = $1; shift; }; $type ||= "string"; my $ref = __package__->can("prompt_$type") or croak "don't know how to prompt for $type"; my $what = shift; my $default = shift; $ref->( "Value for $what:", $default, ), } sub prompt_string { my $prompt = shift; my $default = shift; prompt_sub($prompt.(defined($default)?" [$default]":""), sub { $_ || $default || $_ }); } sub prompt_int { my $prompt = shift; my $default = shift; prompt_sub($prompt.(defined($default)?" [$default]":""), sub { my($i) = /^(\d+)$/; defined ($i) ? $i : (length($_)?undef:$default) }); } sub prompt_nY { prompt_Yn(@_) } sub prompt_Yn { prompt_sub ($_[0]." [Yn]", sub { ( /^\s*(?: (?:(y.*))? | (n.*))\s*$/ix ? ($2 ? 0 : 1) : undef )}, ); } sub prompt_ny { prompt_yn(@_) } sub prompt_yn { prompt_sub ($_[0]." [yn]", sub {( /^\s*(?: (y.*) | (n.*))\s*$/ix ? ($2 ? 0 : ($1 ? 1 : undef)) : undef )}, "please enter `yes', or `no'" ); } sub prompt_Ny { prompt_yN(@_) } sub prompt_yN { prompt_sub ($_[0]." [Ny]", sub {( /^\s*(?: (y.*)? | (?:(n.*))? )\s*$/ix ? ($1 ? 1 : 0) : undef )} ); } sub prompt_file { my $prompt = shift; my $sub = shift || sub { s{[\n/ ]$}{}; return (-e $_ ? $_ : die "File `$_' does not exist!") }; my $moan = shift || "Specified file does not exist!"; my $term = term; my $attr; if ( $term->can("Attribs") ) { $attr = $term->Attribs; $attr->{completion_function} = \&complete_file; # yes, this is an awful hack. if ( $term =~ /Stub/ ) { $APPEND = undef; } elsif ( $term =~ /HASH/ and $term->{gnu_readline_p} ) { $APPEND = "completion_append_character"; # gnu } else { $APPEND = "completer_terminator_character"; #perl } } my $file = prompt_sub($prompt, $sub, $moan, @_); if ( $attr ) { $attr->{completion_function} = undef; } return $file; } # ReadLine completion function. Don't use the built-in one because it # sucks arse. sub complete_file { my ($text, $line, $start) = @_; (my $dir = $line) =~ s{[^/]*$}{}; (my $file = $line) =~ s{.*/}{}; ($line =~ m/^(.*\s)/g); $start = (defined($1) ? length($1) : 0); if ( !defined $dir or !length $dir ) { $dir = "./"; $start += 2; } $file ||= ""; #print STDERR "Completing: DIR='$dir' FILE='$file'\n"; if ( -d $dir ) { opendir DIR, $dir or return; my @files = (map { $dir.$_ } grep { !/^\.\.?$/ && m/^\Q$file\E/ } readdir DIR); closedir DIR; if ( @files == 1 && -d $files[0] ) { term->Attribs->{$APPEND} = "/"; } else { term->Attribs->{$APPEND} = " "; } #print STDERR "Completions: ".join(":",@files)."\n"; return map { substr $_, $start } @files; } } no strict 'refs'; # sets up file descriptors for `run' et al. sub setup_fds { my $fdset = shift; my (@fds) = sort { $a <=> $b } keys %$fdset; $^F = $fds[$#fds] if $fds[$#fds] > 2; # there is a slight problem with this - for instance, if the user # supplies a closure that is reading from a file, and that file # happens to be opened on a filehandle that they want to use, then # it will be closed and the code break. Ho hum. for ( 3..$fds[$#fds] ) { open BAM, "<&=$_"; if ( fileno(BAM) ) { close BAM; } else { open BAM, ">&=$_"; if ( fileno(BAM) ) { close BAM; } } } while ( my ($fnum, $spec) = each %$fdset ) { my ($mode, $where) = @$spec; my $fd; if ( !ref $where ) { open($fd, "$mode$where") or barf "failed to re-open fd $fnum $mode$where; $!"; } elsif ( ref $where eq "GLOB" ) { open($fd, "$mode&".fileno($where)) or barf "failed to re-open fd $fnum $mode &fd(".fileno($where)."; $!"; } elsif ( ref $where eq "CODE" ) { pipe(\*{"FD${fnum}_R"}, \*{"FD${fnum}_W"}); if ( my $pid = fork ) { my $rw = ($mode eq ">" ? "W" : "R"); my $wr = ($mode eq ">" ? "R" : "W"); open($fd, "$mode&FD${fnum}_$rw") or barf "failed to re-open fd $fnum $mode CODE; $!"; close(\*{"FD${fnum}_$wr"}) } elsif ( !defined $pid ) { barf "fork failed; $!"; } else { if ( $mode eq "<" ) { close STDOUT; open STDOUT, ">&FD${fnum}_W"; select STDOUT; $| = 1; } else { close STDIN; open STDIN, "<&FD${fnum}_R"; } $where->(); exit(0); } } else { barf "bad spec for FD $fnum"; } # don't use a lex here otherwise it gets auto-closed open (\*{"FD${fnum}"}, "$mode&=$fnum"); open \*{"FD${fnum}"}, "$mode&".fileno($fd); fileno(\*{"FD${fnum}"}) == $fnum or do { barf ("tried to setup on FD $fnum, but got " .fileno(\*{"FD$fnum"})."(spec: $mode $where)"); }; } } sub tsay { my $template = shift; my $data = shift; eval { &templater->process($template, $data) or die (&templater->error || "died"); }; if ( $@ ) { moan "Error trying template response using template `$template'; $@"; say "template variables:"; print anydump($data); } } our $provider; our $templater; sub templater { $provider ||= bless { }, "Scriptalicious::DataLoad"; our $templater ||= Scriptalicious::Template->new ({ INTERPOLATE => 1, POST_CHOMP => 0, EVAL_PERL => 1, TRIM => 0, RECURSION => 1, LOAD_TEMPLATES => [ $provider ], }); } sub anydump { my $var = shift; eval { eval "use YAML"; die $@ if $@; local $YAML::UseHeader = 0 unless (!ref $var or ref $var !~ m/^(ARRAY|HASH)$/); local $YAML::UseVersion = 0; return YAML::Dump($var); } || do { eval "use Data::Dumper"; die $@ if $@; local $Data::Dumper::Purity = 1; return Data::Dumper->Dump([$var], ["x"]); } } package Scriptalicious::Template; our $template_ok; our @ISA; sub new { my $class = shift; eval "use Template"; if ( !$@ ) { @ISA = qw(Template); @Scriptalicious::DataLoad::ISA = qw(Template::Provider); $_[0]->{LOAD_TEMPLATES} = Scriptalicious::DataLoad->new(); $template_ok = 1; return $class->SUPER::new(@_); } else { Scriptalicious::moan "install Template Toolkit for prettier messages"; return bless shift, $class; } } sub process { my $self = shift; if ($template_ok) { no strict 'refs'; Scriptalicious::_get_pod_usage(); my $template = shift; my $vars = shift; $vars||={}; $vars->{$_} = ${"Scriptalicious::$_"} foreach qw(PROGNAME VERSION VERBOSE NAME SYNOPSIS DESCRIPTION); return $self->SUPER::process($template, $vars, @_); }; my $template = shift; my $vars = shift; my $provider = eval { $self->{LOAD_TEMPLATES}[0] } || bless { }, "Scriptalicious::DataLoad"; my ($data, $rc) = $provider->fetch($template); if ( !$rc ) { Scriptalicious::say "----- Template `$template' -----"; print $data; } Scriptalicious::say "------ Template variables ------"; print Scriptalicious::anydump $vars; Scriptalicious::say "-------- end of message --------"; } package Scriptalicious::DataLoad; our @ISA; sub fetch { my ($self, $name, $alias) = @_; # get the source file/template my $section = shift; my $found = 0; my @data; if ( open(my $script, $0) ) { "" =~ m{()}; # clear $1 local(*_); while ( <$script> ) { if ( m{^__\Q$name\E__$} .. (m{^__(?!\Q$name\E)(\w+)__$}||eof $script) ) { $found++ or next; next if $1; push @data, $_; } } close $script; } if ( !$found and -e $name ) { $found = 1; if (open TEMPLATE, $name) { @data =