Sysadm-Install-0.43/000755 040416 000024 00000000000 12121761237 015252 5ustar00mschillistaff000000 000000 Sysadm-Install-0.43/Changes000644 040416 000024 00000016573 12121267611 016556 0ustar00mschillistaff000000 000000 ######################################## Revision history for Sysadm::Install ######################################## 0.43 (2013/03/16) (ms) Using binmode() now for slurp/blurt for compatibility with Win32 systems. 0.42 (2013/01/20) (ms) No longer silently removing directories that are in the way before untar(). (ms) Better error diagnosis on failing untar() tests 0.41 (2012/12/17) (ms) Added home_dir() function returning user's home directory. (ms) tap() now supports stdout_limit and stderr_limit options to limit log verbosity 0.40 (2012/09/15) (ms) Applied pull request by ks0608 to fix Cwd problem on Win32/Mac (https://github.com/mschilli/sysadm-install-perl/pull/1) 0.39 (2012/05/17) (ms) Fixed bin_find, to omit directories (ms) Added cdback() with reset option 0.38 (2011/07/30) (ms) Fixed Win32 test in 012tap.t 0.37 (2011/06/25) (ms) [rt.cpan.org #68095] Applied fix by Kai von Thadden for tap's raise_error option and added test case. 0.36 (2011/05/01) (ms) Added owner_cp() to copy uid and gid of a file or directory. (ms) Added raise_error option for tap() (ms) snip() now returns original string (with unprintables replaced) if the data length is shorter than $maxlen. 0.35 (2010/04/13) (ms) [RT 54885] Merged with github fork by Thomas Lenz, fixing blurt_atomic on Win32. (ms) Fixed local caller_depth increments (ms) Fixed printable() bug masking '-'. 0.34 (2010/02/21) (ms) Added github repository link to Makefile.PL (ms) [RT 53324] bin_find fix for Windows using $Config::Config{path_sep} (ms) [RT 54555] Fixed test suite errors on Win32 0.33 (2009/09/12) (ms) utf8_available() now uses eval"" to check for Encode module, Sysadm::Install therefore no longer requires Encode to be installed. (ms) Got rid of LWP::Simple because of its env_proxy() call at compile time, which freaks out on env variables like "use_proxy" when set to numeric values. Using LWP::UserAgent instead. 0.32 2009/08/28 (ms) Made utf8 handling configurable instead of sneaky capability detection, after all, there's apps using different encodings. 0.31 2009/08/27 (ms) nhandler(at)ubuntu.com provided a patch to resolve pod2man errors: https://rt.cpan.org/Public/Bug/Display.html?id=47525 (ms) slurp() and blurt() now use utf8 mode by default if available (ms) added utf8_available() and is_utf8_data() 0.29 2009/06/25 (ms) Greg Olszewski added proper error handling to print and pipe statements (ms) Fixed up some "if $dir" cases to protect against a value of "0" in $dir. (ms) Fixed up logcroak calls to use the current logger instead of the root logg 0.28 2009/05/11 (ms) Skipping fs_read_open test case if there's no cpio on the target system (reported for armv5tejl-linux). (ms) Fixed download() with a better check for getstore(), suggested by Bernhard Minks. 0.27 2008/03/26 (ms) Fixes a broken CPAN upload. 0.26 2008/03/25 (ms) Added rc/stdout/stderr debug output to tap() (ms) Added perm_get/set to export list (ms) Added shell escapes for tap() 0.25 2008/02/07 (ms) Fixed directory stack bug in cdback() 0.24 2007/10/24 (ms) Added def_or() function to emulate the //= operator (ms) Added blurt_atomic() to write data to a file, guaranteeing that the operation either fully succeeds or fails. It makes sure that we're not left with a partially written file in case the operation gets interrupted. (ms) fixed password_read() documentation bug 0.23 2007/04/01 (ms) Added nice_time() and password_read(). (ms) Fixed quote($str, ":shell") to escape single quotes within single quotes in a shell-compatible way. 0.22 2006/09/19 (ms) Skipping Archive::Tar tests if A:T isn't installed 0.21 2006/02/02 (ms) Added log messages to cp, mv, download, make. (ms) untar() and untar_in() now pass the cwd value to Archive::Tar's extract function to avoid excessive and expensive cwd() calls (thanks to Greg Olszewski for finding this performance bottleneck). 0.20 2005/08/13 (ms) Requiring Log4perl-1.00 now to avoid a problem with the test suite. 0.19 2005/07/28 (ms) Greg Olszewski reported a bug in untar_in() with tarfiles on relative paths, fixed by using one-argument version of rel2abs. 0.18 2005/07/14 (ms) Requiring File::Temp 0.16 now (S:I needs OO-API). (ms) Errors are now reported via croak(), which reports the location in the calling script, not in Sysadm::Install. 0.17 2005/04/23 (ms) Added interactive mode. If you call Sysadm::Install::confirm(1) before running Sysadm::Install commands, every writing function (cp(), mv(), untar(), pie(), blurt(), ...) will ask the user for confirmation before actually performing what's been requested. Sysadm::Install::confirm(0) switches back to normal. (ms) Added patch by Jud Dagnall to allow slurp() to process @ARGV like <> does. (ms) Archive::Tar is no longer mandatory for installation, just for using untar() and untar_in(). 0.16 2005/04/10 (ms) Bumped up Log4perl reporting level. On typical S:I functions, the log message will show the *calling program*'s file name and line number. (ms) slurp() and blurp() are now displaying parts of the data read/written. (ms) Added check for IO::Zlib and better error message if it's not installed and a compressed tarball needs to be processed. (ms) Requiring L4p 0.48 and Archive::Tar 1.23 to make sure test suite succeeds. 0.15 (03/17/2005) (ms) Added eg/one-liner 0.14 (03/10/2005) (ms) Added dry-run function dry_run(1) suppressing write actions (ms) Added perm_get and perm_set to compliment perm_cp 0.13 (01/25/2005) (ms) Makefile.PL prerequisite changed from undef to '0'. 0.12 (01/15/2005) (ms) Added fs_read_open(), fs_write_open() and pipe_copy() (ms) blurt/slurp now report the # of bytes 0.11 (01/11/2005) (ms) tap() single-quotes args now by default (ms) tap() allows for optional double-quoting or no-quoting 0.10 (01/09/2005) (ms) removed Expect dependency ('require' on demand) (ms) added say() (ms) added sudo_me() and bin_find() (ms) tap() now returns the exit code as a third parameter. Improved command handling by using qquote() to separate args. 0.09 (12/04/2004) (ms) added hammer() and dependency on Expect (ms) corrected shell escapes with qquote() 0.08 (11/24/2004) (ms) added perm_cp() to copy file permissions (ms) added untar_in() to untar tarballs in specified directories (ms) added sysrun() to run shell commands plus logging (ms) added pick() and ask() to ask for interactive user input 0.07 (11/17/2004) (ms) added qquote() 0.06 (11/04/2004) (ms) added plough 0.05 (10/16/2004) (ms) added mv (ms) Functions not exported by default anymore. Use use Sysadm::Install qw(:all) to get the old behaviour. (ms) added tap 0.04 (10/08/2004) (ms) Fixed untar and test suite 0.03 (10/08/2004) (ms) Added slurp/blurt and pie() to support 'perl -pie ...'-like commands 0.02 (07/17/2004) (ms) Added untar() 0.01 (07/16/2004) (ms) Where it all began. Sysadm-Install-0.43/eg/000755 040416 000024 00000000000 12121761236 015644 5ustar00mschillistaff000000 000000 Sysadm-Install-0.43/lib/000755 040416 000024 00000000000 12121761236 016017 5ustar00mschillistaff000000 000000 Sysadm-Install-0.43/Makefile.PL000644 040416 000024 00000002752 12120677576 017245 0ustar00mschillistaff000000 000000 use 5.006; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. my $meta_merge = { META_MERGE => { resources => { repository => 'http://github.com/mschilli/sysadm-install-perl', }, } }; eval { require Expect; }; if($@) { print < 'Sysadm::Install', VERSION_FROM => 'lib/Sysadm/Install.pm', # finds $VERSION EXE_FILES => ['eg/one-liner' ], PREREQ_PM => { Log::Log4perl => 1.28, File::Copy => 0, File::Path => 0, File::Basename => 0, Term::ReadKey => 0, LWP::Simple => 0, Cwd => 0, File::Temp => 0.16, }, # e.g., Module::Name => 1.1 $ExtUtils::MakeMaker::VERSION >= 6.50 ? (%$meta_merge) : (), ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/Sysadm/Install.pm', # retrieve abstract from module AUTHOR => 'Mike Schilli ') : ()), ); Sysadm-Install-0.43/MANIFEST000644 040416 000024 00000001167 12121761237 016410 0ustar00mschillistaff000000 000000 Changes eg/ask eg/mkperl eg/one-liner eg/perm_cp eg/tap eg/untar_in lib/Sysadm/Install.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP MYMETA.json MYMETA.yml README t/001.t t/002tar.t t/003slurp.t t/004plough.t t/005qquote.t t/006perm.t t/007fs.t t/008dry.t t/009snip.t t/010carp.t t/011defor.t t/012tap.t t/013download.t t/014utf8.t t/015caller_level.t t/016printable.t t/017cdback.t t/018home.t t/canned/test.tar t/canned/testa.tar t/canned/utf8.txt META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Sysadm-Install-0.43/MANIFEST.SKIP000644 040416 000024 00000000112 12120677576 017155 0ustar00mschillistaff000000 000000 blib ^Makefile$ ^Makefile.old$ CVS .cvsignore MANIFEST.bak ^adm .git .gz$ Sysadm-Install-0.43/META.json000644 040416 000024 00000002355 12121761237 016700 0ustar00mschillistaff000000 000000 { "abstract" : "Typical installation tasks for system administrators", "author" : [ "Mike Schilli " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Sysadm-Install", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Cwd" : "0", "File::Basename" : "0", "File::Copy" : "0", "File::Path" : "0", "File::Temp" : "0.16", "LWP::Simple" : "0", "Log::Log4perl" : "1.28", "Term::ReadKey" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "http://github.com/mschilli/sysadm-install-perl" } }, "version" : "0.43" } Sysadm-Install-0.43/META.yml000644 040416 000024 00000001311 12121761236 016516 0ustar00mschillistaff000000 000000 --- abstract: 'Typical installation tasks for system administrators' author: - 'Mike Schilli ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Sysadm-Install no_index: directory: - t - inc requires: Cwd: 0 File::Basename: 0 File::Copy: 0 File::Path: 0 File::Temp: 0.16 LWP::Simple: 0 Log::Log4perl: 1.28 Term::ReadKey: 0 resources: repository: http://github.com/mschilli/sysadm-install-perl version: 0.43 Sysadm-Install-0.43/MYMETA.json000644 040416 000024 00000002355 12121761236 017145 0ustar00mschillistaff000000 000000 { "abstract" : "Typical installation tasks for system administrators", "author" : [ "Mike Schilli " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Sysadm-Install", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Cwd" : "0", "File::Basename" : "0", "File::Copy" : "0", "File::Path" : "0", "File::Temp" : "0.16", "LWP::Simple" : "0", "Log::Log4perl" : "1.28", "Term::ReadKey" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "http://github.com/mschilli/sysadm-install-perl" } }, "version" : "0.43" } Sysadm-Install-0.43/MYMETA.yml000644 040416 000024 00000001311 12121761236 016764 0ustar00mschillistaff000000 000000 --- abstract: 'Typical installation tasks for system administrators' author: - 'Mike Schilli ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Sysadm-Install no_index: directory: - t - inc requires: Cwd: 0 File::Basename: 0 File::Copy: 0 File::Path: 0 File::Temp: 0.16 LWP::Simple: 0 Log::Log4perl: 1.28 Term::ReadKey: 0 resources: repository: http://github.com/mschilli/sysadm-install-perl version: 0.43 Sysadm-Install-0.43/README000644 040416 000024 00000045630 12121761235 016140 0ustar00mschillistaff000000 000000 ###################################################################### Sysadm::Install 0.43 ###################################################################### NAME Sysadm::Install - Typical installation tasks for system administrators SYNOPSIS use Sysadm::Install qw(:all); my $INST_DIR = '/home/me/install/'; cd($INST_DIR); cp("/deliver/someproj.tgz", "."); untar("someproj.tgz"); cd("someproj"); # Write out ... blurt("Builder: Mike\nDate: Today\n", "build.dat"); # Slurp back in ... my $data = slurp("build.dat"); # or edit in place ... pie(sub { s/Today/scalar localtime()/ge; $_; }, "build.dat"); make("test install"); # run a cmd and tap into stdout and stderr my($stdout, $stderr, $exit_code) = tap("ls", "-R"); DESCRIPTION Have you ever wished for your installation shell scripts to run reproducibly, without much programming fuzz, and even with optional logging enabled? Then give up shell programming, use Perl. "Sysadm::Install" executes shell-like commands performing typical installation tasks: Copying files, extracting tarballs, calling "make". It has a "fail once and die" policy, meticulously checking the result of every operation and calling "die()" immediately if anything fails. "Sysadm::Install" also supports a *dry_run* mode, in which it logs everything, but suppresses any write actions. Dry run mode is enabled by calling Sysadm::Install::dry_run(1). To switch back to normal, call Sysadm::Install::dry_run(0). As of version 0.17, "Sysadm::Install" supports a *confirm* mode, in which it interactively asks the user before running any of its functions (just like "rm -i"). *confirm* mode is enabled by calling Sysadm::Install::confirm(1). To switch back to normal, call Sysadm::Install::confirm(0). "Sysadm::Install" is fully Log4perl-enabled. To start logging, just initialize "Log::Log4perl". "Sysadm::Install" acts as a wrapper class, meaning that file names and line numbers are reported from the calling program's point of view. FUNCTIONS "cp($source, $target)" Copy a file from $source to $target. "target" can be a directory. Note that "cp" doesn't copy file permissions. If you want the target file to reflect the source file's user rights, use "perm_cp()" shown below. "mv($source, $target)" Move a file from $source to $target. "target" can be a directory. "download($url)" Download a file specified by $url and store it under the name returned by "basename($url)". "untar($tarball)" Untar the tarball in $tarball, which typically adheres to the "someproject-X.XX.tgz" convention. But regardless of whether the archive actually contains a top directory "someproject-X.XX", this function will behave if it had one. If it doesn't have one, a new directory is created before the unpacking takes place. Unpacks the tarball into the current directory, no matter where the tarfile is located. Please note that if you're using a compressed tarball (.tar.gz or .tgz), you'll need IO::Zlib installed. "untar_in($tar_file, $dir)" Untar the tarball in $tgz_file in directory $dir. Create $dir if it doesn't exist yet. "pick($prompt, $options, $default)" Ask the user to pick an item from a displayed list. $prompt is the text displayed, $options is a referenc to an array of choices, and $default is the number (starting from 1, not 0) of the default item. For example, pick("Pick a fruit", ["apple", "pear", "pineapple"], 3); will display the following: [1] apple [2] pear [3] pineapple Pick a fruit [3]> If the user just hits *Enter*, "pineapple" (the default value) will be returned. Note that 3 marks the 3rd element of the list, and is *not* an index value into the array. If the user enters 1, 2 or 3, the corresponding text string ("apple", "pear", "pineapple" will be returned by "pick()". "ask($prompt, $default)" Ask the user to either hit *Enter* and select the displayed default or to type in another string. "mkd($dir)" Create a directory of arbitrary depth, just like "File::Path::mkpath". "rmf($dir)" Delete a directory and all of its descendents, just like "rm -rf" in the shell. "cd($dir)" chdir to the given directory. If you don't want to have cd() modify the internal directory stack (used for subsequent cdback() calls), set the stack_update parameter to a false value: cd($dir, {stack_update => 0}); "cdback()" chdir back to the last directory before a previous "cd". If the option "reset" is set, it goes all the way back to the beginning of the directory stack, i.e. no matter how many cd() calls were made in between, it'll go back to the original directory: # go all the way back cdback( { reset => 1 } ); "make()" Call "make" in the shell. "pie($coderef, $filename, ...)" Simulate "perl -pie 'do something' file". Edits files in-place. Expects a reference to a subroutine as its first argument. It will read out the file $filename line by line and calls the subroutine setting a localized $_ to the current line. The return value of the subroutine will replace the previous value of the line. Example: # Replace all 'foo's by 'bar' in test.dat pie(sub { s/foo/bar/g; $_; }, "test.dat"); Works with one or more file names. If the files are known to contain UTF-8 encoded data, and you want it to be read/written as a Unicode strings, use the "utf8" option: pie(sub { s/foo/bar/g; $_; }, "test.dat", { utf8 => 1 }); "plough($coderef, $filename, ...)" Simulate "perl -ne 'do something' file". Iterates over all lines of all input files and calls the subroutine provided as the first argument. Example: # Print all lines containing 'foobar' plough(sub { print if /foobar/ }, "test.dat"); Works with one or more file names. If the files are known to contain UTF-8 encoded data, and you want it to be read into Unicode strings, use the "utf8" option: plough(sub { print if /foobar/ }, "test.dat", { utf8 => 1 }); "my $data = slurp($file, $options)" Slurps in the file and returns a scalar with the file's content. If called without argument, data is slurped from STDIN or from any files provided on the command line (like <> operates). If the file is known to contain UTF-8 encoded data and you want to read it in as a Unicode string, use the "utf8" option: my $unicode_string = slurp( $file, {utf8 => 1} ); "blurt($data, $file, $append)" Opens a new file, prints the data in $data to it and closes the file. If $append is set to a true value, data will be appended to the file. Default is false, existing files will be overwritten. If the string is a Unicode string, use the "utf8" option: blurt( $unicode_string, $file, {utf8 => 1} ); "blurt_atomic($data, $file, $options)" Write the data in $data to a file $file, guaranteeing that the operation will either complete fully or not at all. This is accomplished by first writing to a temporary file which is then rename()ed to the target file. Unlike in "blurt", there is no $append mode in "blurt_atomic". If the string is a Unicode string, use the "utf8" option: blurt_atomic( $unicode_string, $file, {utf8 => 1} ); "($stdout, $stderr, $exit_code) = tap($cmd, @args)" Run a command $cmd in the shell, and pass it @args as args. Capture STDOUT and STDERR, and return them as strings. If $exit_code is 0, the command succeeded. If it is different, the command failed and $exit_code holds its exit code. Please note that "tap()" is limited to single shell commands, it won't work with output redirectors ("ls >/tmp/foo" 2>&1). In default mode, "tap()" will concatenate the command and args given and create a shell command line by redirecting STDERR to a temporary file. "tap("ls", "/tmp")", for example, will result in 'ls' '/tmp' 2>/tmp/sometempfile | Note that all commands are protected by single quotes to make sure arguments containing spaces are processed as singles, and no globbing happens on wildcards. Arguments containing single quotes or backslashes are escaped properly. If quoting is undesirable, "tap()" accepts an option hash as its first parameter, tap({no_quotes => 1}, "ls", "/tmp/*"); which will suppress any quoting: ls /tmp/* 2>/tmp/sometempfile | Or, if you prefer double quotes, use tap({double_quotes => 1}, "ls", "/tmp/$VAR"); wrapping all args so that shell variables are interpolated properly: "ls" "/tmp/$VAR" 2>/tmp/sometempfile | Another option is "utf8" which runs the command in a terminal set to UTF8. Error handling: By default, tap() won't raise an error if the command's return code is nonzero, indicating an error reported by the shell. If bailing out on errors is requested to avoid return code checking by the script, use the raise_error option: tap({raise_error => 1}, "ls", "doesn't exist"); In DEBUG mode, "tap" logs the entire stdout/stderr output, which can get too verbose at times. To limit the number of bytes logged, use the "stdout_limit" and "stderr_limit" options tap({stdout_limit => 10}, "echo", "123456789101112"); "$quoted_string = qquote($string, [$metachars])" Put a string in double quotes and escape all sensitive characters so there's no unwanted interpolation. E.g., if you have something like print "foo!\n"; and want to put it into a double-quoted string, it will look like "print \"foo!\\n\"" Sometimes, not only backslashes and double quotes need to be escaped, but also the target environment's meta chars. A string containing print "$<\n"; needs to have the '$' escaped like "print \"\$<\\n\";" if you want to reuse it later in a shell context: $ perl -le "print \"\$<\\n\";" 1212 "qquote()" supports escaping these extra characters with its second, optional argument, consisting of a string listing all escapable characters: my $script = 'print "$< rocks!\\n";'; my $escaped = qquote($script, '!$'); # Escape for shell use system("perl -e $escaped"); => 1212 rocks! And there's a shortcut for shells: By specifying ':shell' as the metacharacters string, qquote() will actually use '!$`'. For example, if you wanted to run the perl code print "foobar\n"; via perl -e ... on a box via ssh, you would use use Sysadm::Install qw(qquote); my $cmd = 'print "foobar!\n"'; $cmd = "perl -e " . qquote($cmd, ':shell'); $cmd = "ssh somehost " . qquote($cmd, ':shell'); print "$cmd\n"; system($cmd); and get ssh somehost "perl -e \"print \\\"foobar\\\!\\\\n\\\"\"" which runs on "somehost" without hickup and prints "foobar!". Sysadm::Install comes with a script "one-liner" (installed in bin), which takes arbitrary perl code on STDIN and transforms it into a one-liner: $ one-liner Type perl code, terminate by CTRL-D print "hello\n"; print "world\n"; ^D perl -e "print \"hello\\n\"; print \"world\\n\"; " "$quoted_string = quote($string, [$metachars])" Similar to "qquote()", just puts a string in single quotes and escapes what needs to be escaped. Note that shells typically don't support escaped single quotes within single quotes, which means that $ echo 'foo\'bar' > is invalid and the shell waits until it finds a closing quote. Instead, there is an evil trick which gives the desired result: $ echo 'foo'\''bar' # foo, single quote, \, 2 x single quote, bar foo'bar It uses the fact that shells interpret back-to-back strings as one. The construct above consists of three back-to-back strings: (1) 'foo' (2) ' (3) 'bar' which all get concatenated to a single foo'bar If you call "quote()" with $metachars set to ":shell", it will perform that magic behind the scenes: print quote("foo'bar"); # prints: 'foo'\''bar' "perm_cp($src, $dst, ...)" Read the $src file's user permissions and modify all $dst files to reflect the same permissions. "owner_cp($src, $dst, ...)" Read the $src file/directory's owner uid and group gid and apply it to $dst. For example: copy uid/gid of the containing directory to a file therein: use File::Basename; owner_cp( dirname($file), $file ); Usually requires root privileges, just like chown does. "$perms = perm_get($filename)" Read the $filename's user permissions and owner/group. Returns an array ref to be used later when calling "perm_set($filename, $perms)". "perm_set($filename, $perms)" Set file permissions and owner of $filename according to $perms, which was previously acquired by calling "perm_get($filename)". "sysrun($cmd)" Run a shell command via "system()" and die() if it fails. Also works with a list of arguments, which are then interpreted as program name plus arguments, just like "system()" does it. "hammer($cmd, $arg, ...)" Run a command in the shell and simulate a user hammering the ENTER key to accept defaults on prompts. "say($text, ...)" Alias for "print ..., "\n"", just like Perl6 is going to provide it. "sudo_me()" Check if the current script is running as root. If yes, continue. If not, restart the current script with all command line arguments is restarted under sudo: sudo scriptname args ... Make sure to call this before any @ARGV-modifying functions like "getopts()" have kicked in. "bin_find($program)" Search all directories in $PATH (the ENV variable) for an executable named $program and return the full path of the first hit. Returns "undef" if the program can't be found. "fs_read_open($dir)" Opens a file handle to read the output of the following process: cd $dir; find ./ -xdev -print0 | cpio -o0 | This can be used to capture a file system structure. "fs_write_open($dir)" Opens a file handle to write to a | (cd $dir; cpio -i0) process to restore a file system structure. To be used in conjunction with *fs_read_open*. "pipe_copy($in, $out, [$bufsize])" Reads from $in and writes to $out, using sysread and syswrite. The buffer size used defaults to 4096, but can be set explicitely. "snip($data, $maxlen)" Format the data string in $data so that it's only (roughly) $maxlen characters long and only contains printable characters. If $data is longer than $maxlen, it will be formatted like (22)[abcdef[snip=11]stuvw] indicating the length of the original string, the beginning, the end, and the number of 'snipped' characters. If $data is shorter than $maxlen, it will be returned unmodified (except for unprintable characters replaced, see below). If $data contains unprintable character's they are replaced by "." (the dot). "password_read($prompt)" Reads in a password to be typed in by the user in noecho mode. A call to password_read("password: ") results in password: ***** (stars aren't actually displayed) This function will switch the terminal back into normal mode after the user hits the 'Return' key. "nice_time($time)" Format the time in a human-readable way, less wasteful than the 'scalar localtime' formatting. print nice_time(), "\n"; # 2007/04/01 10:51:24 It uses the system time by default, but it can also accept epoch seconds: print nice_time(1170000000), "\n"; # 2007/01/28 08:00:00 It uses localtime() under the hood, so the outcome of the above will depend on your local time zone setting. "def_or($foo, $default)" Perl-5.9 added the //= construct, which helps assigning values to undefined variables. Instead of writing if(!defined $foo) { $foo = $default; } you can just write $foo //= $default; However, this is not available on older perl versions (although there's source filter solutions). Often, people use $foo ||= $default; instead which is wrong if $foo contains a value that evaluates as false. So Sysadm::Install, the everything-and-the-kitchen-sink under the CPAN modules, provides the function "def_or()" which can be used like def_or($foo, $default); to accomplish the same as $foo //= $default; How does it work, how does $foo get a different value, although it's apparently passed in by value? Modifying $_[0] within the subroutine is an old Perl trick to do exactly that. "is_utf8_data($data)" Check if the given string has the utf8 flag turned on. Works just like Encode.pm's is_utf8() function, except that it silently returns a false if Encode isn't available, for example when an ancient perl without proper utf8 support is used. "utf8_check($data)" Check if we're using a perl with proper utf8 support, by verifying the Encode.pm module is available for loading. "home_dir()" Return the path to the home directory of the current user. AUTHOR Mike Schilli, COPYRIGHT AND LICENSE Copyright (C) 2004-2007 by Mike Schilli This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.3 or, at your option, any later version of Perl 5 you may have available. Sysadm-Install-0.43/t/000755 040416 000024 00000000000 12121761236 015514 5ustar00mschillistaff000000 000000 Sysadm-Install-0.43/t/001.t000644 040416 000024 00000000101 12120677576 016205 0ustar00mschillistaff000000 000000 use Test::More tests => 1; BEGIN { use_ok('Sysadm::Install') }; Sysadm-Install-0.43/t/002tar.t000644 040416 000024 00000004015 12120677576 016725 0ustar00mschillistaff000000 000000 ##################################### # Tests for Sysadm::Install/s untar() ##################################### use Test::More; use Sysadm::Install qw(:all); use File::Spec; use File::Path; use Carp; #use Log::Log4perl qw(:easy); #Log::Log4perl->easy_init($DEBUG); BEGIN { eval { require Archive::Tar; }; if ($@) { plan skip_all => "Skipping Archive::Tar tests (not installed)"; } else { plan tests => 9; } } my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; ##################################################################### # Test unzipped tar ##################################################################### my $tarfile = File::Spec->catfile($TEST_DIR, "canned", "test.tar"); untar($tarfile); ok(-d "test", "Untarred directory 'test' exists"); is(readfile("test/a"), "file-a\n", "Testing file a in tar archive"); is(readfile("test/b"), "file-b\n", "Testing file b in tar archive"); ############## sub readfile { ############## open FILE, "<$_[0]" or croak "Cannot open $_[0] ($!)"; my $data = join '', ; close FILE; return $data; } rmtree "test"; ##################################################################### # Test zipped tar ##################################################################### $tarfile = File::Spec->catfile($TEST_DIR, "canned", "test.tar"); untar($tarfile); ok(-d "test", "Untarred directory 'test' exists"); is(readfile("test/a"), "file-a\n", "Testing file a in tar archive"); is(readfile("test/b"), "file-b\n", "Testing file b in tar archive"); rmtree "test"; ##################################################################### # Test zipped tar with different top dir ##################################################################### $tarfile = File::Spec->catfile($TEST_DIR, "canned", "testa.tar"); untar($tarfile); ok(-d "testa", "Untarred directory 'testa' exists"); is(readfile("testa/a"), "file-a\n", "Testing file a in tar archive"); is(readfile("testa/b"), "file-b\n", "Testing file b in tar archive"); rmtree "testa"; Sysadm-Install-0.43/t/003slurp.t000644 040416 000024 00000003526 12120677576 017313 0ustar00mschillistaff000000 000000 ############################################# # Tests for Sysadm::Install/s slurp/blurt/pie ############################################# use Test::More tests => 5; use strict; use warnings; use Sysadm::Install qw(:all); use File::Spec; use File::Path; my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; ##################################################################### # Create a temp file ##################################################################### my $TMP_FILE = File::Spec->catfile($TEST_DIR, "test.dat"); END { unlink $TMP_FILE } ##################################################################### # Blurt ##################################################################### blurt("one\ntwo\nthree", $TMP_FILE); ok(-f $TMP_FILE, "$TMP_FILE exists"); ##################################################################### # Blurt atomically ##################################################################### SKIP: { skip "Renaming tmp files not supported on Win32", 1 if $^O eq "MSWin32"; blurt_atomic("one\ntwo\nthree", $TMP_FILE); ok(-f $TMP_FILE, "$TMP_FILE exists"); } ##################################################################### # Slurp ##################################################################### my $data = slurp($TMP_FILE); is($data, "one\ntwo\nthree", "$TMP_FILE contains right data"); ##################################################################### # Slurp from @ARGS ##################################################################### @ARGV = ($TMP_FILE); $data = slurp(); is($data, "one\ntwo\nthree", "$TMP_FILE contains right data"); ##################################################################### # pie ##################################################################### pie( sub { s/three/four/g; $_; }, $TMP_FILE ); $data = slurp($TMP_FILE); is($data, "one\ntwo\nfour", "$TMP_FILE got pied"); Sysadm-Install-0.43/t/004plough.t000644 040416 000024 00000002004 12120677576 017433 0ustar00mschillistaff000000 000000 ############################################# # Tests for Sysadm::Install/s plough ############################################# use Test::More tests => 2; use Sysadm::Install qw(:all); use File::Spec; use File::Path; my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; ##################################################################### # Create a temp file ##################################################################### my $TMP_FILE = File::Spec->catfile($TEST_DIR, "test.dat"); END { unlink $TMP_FILE } ##################################################################### # Blurt ##################################################################### blurt("one\ntwo\nthree", $TMP_FILE); ok(-f $TMP_FILE, "$TMP_FILE exists"); ##################################################################### # Count all lines containing 'o' ##################################################################### my $count = 0; plough(sub { $count++ if /o/ }, $TMP_FILE); is($count, 2, "Counting all lines containing pattern"); Sysadm-Install-0.43/t/005qquote.t000644 040416 000024 00000001772 12120677576 017467 0ustar00mschillistaff000000 000000 ############################################# # Tests for Sysadm::Install/s plough ############################################# use Test::More tests => 5; use Sysadm::Install qw(:all); use File::Spec; use File::Path; my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; ok(1, "loading ok"); SKIP: { skip "Quoting not supported on Win32", 4 if $^O eq "MSWin32"; my $script = 'print "$< rocks!\\n";'; my $escaped = qquote($script, '!$'); # Escape for shell use my $out = `$^X -e $escaped`; is($out, "$< rocks!\n", "simple escape"); $escaped = qquote($script, '!$][)('); # Escape for shell use # shell escape $escaped = qquote('[some]$thing(weird)"`', ":shell"); is($escaped, '"[some]\\$thing(weird)\\"\\`"', ":shell"); # single quote $escaped = quote("[some]\$thing(weird)'`"); is($escaped, "'[some]\$thing(weird)\\'`'", "single quote"); # single quote containing single quote $escaped = quote("foo'bar", ":shell"); is($escaped, "'foo'\\''bar'", "foo'bar"); } Sysadm-Install-0.43/t/006perm.t000644 040416 000024 00000001344 12120677576 017110 0ustar00mschillistaff000000 000000 ############################################# # Tests for Sysadm::Install/s plough ############################################# use Test::More tests => 2; use Sysadm::Install qw(:all); use File::Spec; use File::Path; my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; ok(1, "loading ok"); my $testfile = ""; SKIP: { skip "Executable file perms not supported on Win32", 1 if $^O eq "MSWin32"; $testfile = File::Spec->catfile($TEST_DIR, "test_file"); blurt("waaaah!", $testfile); END { unlink $testfile, "${testfile}_2" }; chmod(0755, $testfile) or die "Cannot chmod"; cp($testfile, "${testfile}_2"); Sysadm::Install::perm_cp($testfile, "${testfile}_2"); ok(-x "${testfile}_2", "copied file has same permissions"); } Sysadm-Install-0.43/t/007fs.t000644 040416 000024 00000001342 12120677576 016554 0ustar00mschillistaff000000 000000 ############################################# # Tests for Sysadm::Install/s fs_read/write_open ############################################# use Test::More tests => 2; use Sysadm::Install qw(:all); use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($ERROR); use File::Spec; use File::Path; my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; ok(1, "loading ok"); SKIP: { rmf "$TEST_DIR/tmp"; if(!bin_find("cpio")) { skip "No cpio on this system", 1; } my $read = fs_read_open("$TEST_DIR"); my $cpio = join '', <$read>; close $read; my $write = fs_write_open("$TEST_DIR/tmp"); print $write $cpio; close $write; ok(-f "$TEST_DIR/007fs.t", "cpio worked"); rmf "$TEST_DIR/tmp"; } Sysadm-Install-0.43/t/008dry.t000644 040416 000024 00000001201 12120677576 016735 0ustar00mschillistaff000000 000000 ############################################# # Tests for Sysadm::Install/s fs_read/write_open ############################################# use Test::More tests => 3; use Sysadm::Install qw(:all); use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($ERROR); use File::Spec; use File::Path; my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; ok(1, "loading ok"); rmf "$TEST_DIR/tmp"; mkd "$TEST_DIR/tmp"; Sysadm::Install::dry_run(1); blurt "abc", "$TEST_DIR/tmp/abc"; ok(!-f "$TEST_DIR/tmp/abc", "dry run"); Sysadm::Install::dry_run(0); blurt "abc", "$TEST_DIR/tmp/abc"; ok(-f "$TEST_DIR/tmp/abc", "dry run"); rmf "$TEST_DIR/tmp"; Sysadm-Install-0.43/t/009snip.t000644 040416 000024 00000001272 12120677576 017121 0ustar00mschillistaff000000 000000 ############################################# # Tests for Sysadm::Install/s fs_read/write_open ############################################# use Test::More tests => 7; use Sysadm::Install qw(:all); is(snip("abc", 5), "abc", "snip full len"); is(snip("abcdefghijklmn", 11), "(14)[ab[snip=10]mn]", "snip minlen"); is(snip("abcdefghijklmn", 12), "(14)[ab[snip=10]mn]", "snip minlen"); is(snip("a\tcdefghijklm\n", 12), "(14)[a.[snip=10]m.]", "snip special char"); is(snip("a\tcdefghijklm\n", 14), "a.cdefghijklm.", "exact len match"); is(snip("abc", 5, 1), "abc", "snip full len and keep flag"); is(snip("a\tc", 5), "a.c", "snip full len with unprintable chars"); Sysadm-Install-0.43/t/010carp.t000644 040416 000024 00000002137 12120677576 017066 0ustar00mschillistaff000000 000000 ##################################### # Tests for Sysadm::Install ##################################### use Test::More tests => 3; use Sysadm::Install qw(:all); use File::Spec; use File::Path; #use Log::Log4perl qw(:easy); #Log::Log4perl->easy_init($DEBUG); my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; ################################# # cd ################################# eval { cd "/this/directory/does/not/exist"; }; if($@) { like($@, qr(010carp.t), "'cd' reports failure in calling script"); } else { ok(0, "cd succeeded, but should have failed"); } ################################# # mkd ################################# eval { mkd "///"; }; if($@) { like($@, qr(010carp.t), "'mkd' reports failure in calling script"); } else { ok(0, "mkd succeeded, but should have failed"); } ################################# # cp ################################# eval { cp "Ill/go/crazy/if/this/whacko/directory/actually/exists", "//x"; }; if($@) { like($@, qr(010carp.t), "'cp' reports failure in calling script"); } else { ok(0, "cp succeeded, but should have failed"); } Sysadm-Install-0.43/t/011defor.t000644 040416 000024 00000000751 12120677576 017241 0ustar00mschillistaff000000 000000 ##################################### # Tests for Sysadm::Install ##################################### use Test::More tests => 5; use Sysadm::Install qw(:all); my $undef; my $defined = 5; ok(!defined $undef, "undef value undefined"); ok(defined $defined, "defined value defined"); def_or($undef, 42); is($undef, 42, "new value assigned"); def_or($defined, 42); is($defined, 5, "no new value assigned"); $defined = 0; def_or($defined, 42); is($defined, 0, "no new value assigned"); Sysadm-Install-0.43/t/012tap.t000644 040416 000024 00000001341 12120677576 016723 0ustar00mschillistaff000000 000000 ##################################### # Tests for Sysadm::Install ##################################### use Test::More tests => 4; use Sysadm::Install qw(:all); SKIP: { skip "echo not supported on Win32", 2 if $^O eq "MSWin32"; my($stdout, $stderr, $rc) = tap "echo", "'"; is($stdout, "'\n", "single quoted tap"); ($stdout, $stderr, $rc) = tap { raise_error => 1 }, "echo"; is($rc, 0, "tap and raise"); ($stdout, $stderr, $rc) = tap { stdout_limit => 10 }, "echo", "12345678910111211314" ; is($stdout, "(21)[12[snip=17]4.]", "limited stdout"); # tap needs to work if PATH is not set my $ls = bin_find( "ls" ); $ENV{ PATH } = ""; ($stdout, $stderr, $rc) = tap $ls, "/"; is($rc, 0, "cmd ok"); } Sysadm-Install-0.43/t/013download.t000644 040416 000024 00000001127 12120677576 017751 0ustar00mschillistaff000000 000000 ##################################### # Tests for Sysadm::Install ##################################### use Test::More tests => 2; use Sysadm::Install qw(:all); use File::Temp qw(tempdir); eval { download "file:///very/unlikely/that/this/file/exists"; }; ok $@, "download of non-existent file"; my $var = "SI_ALL_TESTS"; SKIP: { if(! exists $ENV{ $var }) { skip "only with $var set", 1; } $ENV{use_proxy} = 1; my ($dir) = tempdir( CLEANUP => 1 ); cd $dir; download "http://perlmeister.com/index.html"; ok(-s "index.html", "download ok"); cdback; }; Sysadm-Install-0.43/t/014utf8.t000644 040416 000024 00000001471 12120677576 017033 0ustar00mschillistaff000000 000000 ##################################### # Tests for Sysadm::Install/s utf8 handling ##################################### use Test::More; use Sysadm::Install qw(:all); use File::Spec; use File::Path; #use Log::Log4perl qw(:easy); #Log::Log4perl->easy_init($DEBUG); BEGIN { eval { require 5.8.0; use Encode qw(is_utf8); use utf8; # local scope only, needs to be repeated below }; if ($@) { plan skip_all => "Skipping utf8 tests (requires perl >5.8)"; } else { plan tests => 2; } } my $TEST_DIR = "."; $TEST_DIR = "t" if -d 't'; my $utf8file = File::Spec->catfile($TEST_DIR, "canned", "utf8.txt"); my $data = slurp $utf8file, {utf8 => 1}; ok is_utf8( $data ), "slurped utf8 file data stored in utf8"; use utf8; like $data, qr/äÜß/, "slurped utf8 file data"; Sysadm-Install-0.43/t/015caller_level.t000644 040416 000024 00000001275 12120677576 020601 0ustar00mschillistaff000000 000000 use Test::More tests => 1; use Sysadm::Install qw(cd); use Log::Log4perl qw(:easy); my $conf = q( log4perl.category = DEBUG, Buffer log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout log4perl.appender.Buffer.layout.ConversionPattern = %M %F{1} %L> %m%n ); Log::Log4perl->init( \$conf ); my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); cd ".."; func1(); like $buf->buffer(), qr/main:: .*main:: .*main::func1/s, "caller_level"; sub func1 { local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; cd ".."; func2(); } sub func2 { cd ".."; } Sysadm-Install-0.43/t/016printable.t000644 040416 000024 00000000505 12120677576 020124 0ustar00mschillistaff000000 000000 ##################################### # Tests for Sysadm::Install/s utf8 handling ##################################### use Test::More; use Sysadm::Install qw(:all); use File::Spec; use File::Path; #use Log::Log4perl qw(:easy); #Log::Log4perl->easy_init($DEBUG); plan tests => 1; is(printable('-'), '-', 'printable: -'); Sysadm-Install-0.43/t/017cdback.t000644 040416 000024 00000000746 12120677576 017363 0ustar00mschillistaff000000 000000 use Test::More; use Sysadm::Install qw(:all); use Cwd qw( cwd abs_path ); use File::Temp qw( tempdir ); my $dir_a = tempdir( CLEANUP => 1 ); my $dir_b = tempdir( CLEANUP => 1 ); plan tests => 4; my $org = cwd(); cd $dir_a; cd $dir_b; is abs_path(), abs_path($dir_b), "dir b"; cdback; is abs_path(), abs_path($dir_a), "back to dir a"; cdback; is abs_path(), abs_path($org), "back to dir a"; cd $dir_a; cd $dir_b; cdback( { reset => 1 } ); is abs_path(), abs_path($org), "reset"; Sysadm-Install-0.43/t/018home.t000644 040416 000024 00000000171 12120677576 017075 0ustar00mschillistaff000000 000000 use Test::More; use Sysadm::Install qw(:all); plan tests => 1; my $home = home_dir(); ok length( $home ), "home dir"; Sysadm-Install-0.43/t/canned/000755 040416 000024 00000000000 12121761236 016744 5ustar00mschillistaff000000 000000 Sysadm-Install-0.43/t/canned/test.tar000644 040416 000024 00000024000 12120677576 020443 0ustar00mschillistaff000000 000000 a0100644004041600001440000000000710131605371010741 0ustar mschilliusersfile-a b0100644004041600001440000000000710131605375010746 0ustar mschilliusersfile-b Sysadm-Install-0.43/t/canned/testa.tar000644 040416 000024 00000024000 12120677576 020604 0ustar00mschillistaff000000 000000 testa/0040755004041600001440000000000010131607755011734 5ustar mschilliuserstesta/a0100644004041600001440000000000710131605371012061 0ustar mschilliusersfile-a testa/b0100644004041600001440000000000710131605375012066 0ustar mschilliusersfile-b Sysadm-Install-0.43/t/canned/utf8.txt000644 040416 000024 00000000007 12120677576 020404 0ustar00mschillistaff000000 000000 äÜß Sysadm-Install-0.43/lib/Sysadm/000755 040416 000024 00000000000 12121761236 017257 5ustar00mschillistaff000000 000000 Sysadm-Install-0.43/lib/Sysadm/Install.pm000644 040416 000024 00000124114 12121270011 021210 0ustar00mschillistaff000000 000000 ############################################### package Sysadm::Install; ############################################### use 5.006; use strict; use warnings; our $VERSION = '0.43'; use File::Copy; use File::Path; use Log::Log4perl qw(:easy); use Log::Log4perl::Util; use File::Basename; use File::Spec::Functions qw(rel2abs abs2rel); use Cwd; use File::Temp qw(tempfile); our $DRY_RUN; our $CONFIRM; our $DRY_RUN_MSG; our $DATA_SNIPPED_LEN = 60; dry_run(0); confirm(0); ############################################### sub dry_run { ############################################### my($on) = @_; if($on) { $DRY_RUN = 1; $DRY_RUN_MSG = "(skipped - dry run)"; } else { $DRY_RUN = 0; $DRY_RUN_MSG = ""; } } ############################################### sub confirm { ############################################### my($on) = @_; $CONFIRM = $on; } ########################################### sub _confirm { ########################################### my($msg) = @_; if($DRY_RUN) { INFO "$msg $DRY_RUN_MSG"; return 0 if $DRY_RUN; } if($CONFIRM) { my $answer = ask("$msg ([y]/n)", "y"); if($answer =~ /^\s*y\s*$/) { INFO $msg; return 1; } INFO "$msg (*CANCELLED* as requested)"; return 0; } return 1; } our @EXPORTABLE = qw( cp rmf mkd cd make cdback download untar pie slurp blurt mv tap plough qquote quote perm_cp owner_cp perm_get perm_set sysrun untar_in pick ask hammer say sudo_me bin_find fs_read_open fs_write_open pipe_copy snip password_read nice_time def_or blurt_atomic is_utf8_data utf8_available printable home_dir ); our %EXPORTABLE = map { $_ => 1 } @EXPORTABLE; our @DIR_STACK; ################################################## sub import { ################################################## my($class) = shift; no strict qw(refs); my $caller_pkg = caller(); my(%tags) = map { $_ => 1 } @_; # Export all if(exists $tags{':all'}) { %tags = map { $_ => 1 } @EXPORTABLE; } for my $func (keys %tags) { LOGDIE __PACKAGE__ . "doesn't export \"$func\"" unless exists $EXPORTABLE{$func}; *{"$caller_pkg\::$func"} = *{$func}; } } =pod =head1 NAME Sysadm::Install - Typical installation tasks for system administrators =head1 SYNOPSIS use Sysadm::Install qw(:all); my $INST_DIR = '/home/me/install/'; cd($INST_DIR); cp("/deliver/someproj.tgz", "."); untar("someproj.tgz"); cd("someproj"); # Write out ... blurt("Builder: Mike\nDate: Today\n", "build.dat"); # Slurp back in ... my $data = slurp("build.dat"); # or edit in place ... pie(sub { s/Today/scalar localtime()/ge; $_; }, "build.dat"); make("test install"); # run a cmd and tap into stdout and stderr my($stdout, $stderr, $exit_code) = tap("ls", "-R"); =head1 DESCRIPTION Have you ever wished for your installation shell scripts to run reproducibly, without much programming fuzz, and even with optional logging enabled? Then give up shell programming, use Perl. C executes shell-like commands performing typical installation tasks: Copying files, extracting tarballs, calling C. It has a C policy, meticulously checking the result of every operation and calling C immediately if anything fails. C also supports a I mode, in which it logs everything, but suppresses any write actions. Dry run mode is enabled by calling C. To switch back to normal, call C. As of version 0.17, C supports a I mode, in which it interactively asks the user before running any of its functions (just like C). I mode is enabled by calling C. To switch back to normal, call C. C is fully Log4perl-enabled. To start logging, just initialize C. C acts as a wrapper class, meaning that file names and line numbers are reported from the calling program's point of view. =head2 FUNCTIONS =over 4 =item C Copy a file from C<$source> to C<$target>. C can be a directory. Note that C doesn't copy file permissions. If you want the target file to reflect the source file's user rights, use C shown below. =cut ############################################### sub cp { ############################################### local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm("cp $_[0] $_[1]") or return 1; INFO "cp $_[0] $_[1]"; File::Copy::copy @_ or LOGCROAK("Cannot copy $_[0] to $_[1] ($!)"); } =pod =item C Move a file from C<$source> to C<$target>. C can be a directory. =cut ############################################### sub mv { ############################################### local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm("mv $_[0] $_[1]") or return 1; INFO "mv $_[0] $_[1]"; File::Copy::move @_ or LOGCROAK("Cannot move $_[0] to $_[1] ($!)"); } =pod =item C Download a file specified by C<$url> and store it under the name returned by C. =cut ############################################### sub download { ############################################### my($url) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; INFO "download $url"; _confirm("Downloading $url => ", basename($url)) or return 1; require LWP::UserAgent; require HTTP::Request; require HTTP::Status; my $ua = LWP::UserAgent->new(); my $request = HTTP::Request->new(GET => $url); my $response = $ua->request($request, basename($_[0])); my $rc = $response->code(); if($rc != HTTP::Status::RC_OK()) { LOGCROAK("Cannot download $_[0] (", $response->message(), ")"); } return 1; } =pod =item C Untar the tarball in C<$tarball>, which typically adheres to the C convention. But regardless of whether the archive actually contains a top directory C, this function will behave if it had one. If it doesn't have one, a new directory is created before the unpacking takes place. Unpacks the tarball into the current directory, no matter where the tarfile is located. Please note that if you're using a compressed tarball (.tar.gz or .tgz), you'll need IO::Zlib installed. =cut ############################################### sub untar { ############################################### local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; LOGCROAK("untar called without defined tarfile") unless @_ == 1 and defined $_[0]; _confirm "untar $_[0]" or return 1; my($nice, $topdir, $namedir) = archive_sniff($_[0]); check_zlib($_[0]); require Archive::Tar; my $arch = Archive::Tar->new($_[0]); my @extracted = (); if($nice and $topdir eq $namedir) { DEBUG "Nice archive, extracting to subdir $topdir"; @extracted = $arch->extract(); } elsif($nice) { DEBUG "Not-so-nice archive topdir=$topdir namedir=$namedir"; # extract as topdir @extracted = $arch->extract(); rename $topdir, $namedir or LOGCROAK("Can't rename $topdir, $namedir"); } else { LOGCROAK("no topdir") unless defined $topdir; DEBUG "Not-so-nice archive (no topdir), extracting to subdir $topdir"; $topdir = basename $topdir; mkd($topdir); cd($topdir); @extracted = $arch->extract(); cdback(); } if( !@extracted ) { LOGCROAK "Archive $_[0] was empty."; } return $topdir; } =pod =item C Untar the tarball in C<$tgz_file> in directory C<$dir>. Create C<$dir> if it doesn't exist yet. =cut ############################################### sub untar_in { ############################################### my($tar_file, $dir) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; LOGCROAK("not enough arguments") if ! defined $tar_file or ! defined $dir; _confirm "Untarring $tar_file in $dir" or return 1; mkd($dir) unless -d $dir; my $tar_file_abs = rel2abs($tar_file); cd($dir); check_zlib($tar_file_abs); require Archive::Tar; my $arch = Archive::Tar->new("$tar_file_abs"); $arch->extract() or LOGCROAK("Extract failed: ($!)"); cdback(); } =pod =item C Ask the user to pick an item from a displayed list. C<$prompt> is the text displayed, C<$options> is a referenc to an array of choices, and C<$default> is the number (starting from 1, not 0) of the default item. For example, pick("Pick a fruit", ["apple", "pear", "pineapple"], 3); will display the following: [1] apple [2] pear [3] pineapple Pick a fruit [3]> If the user just hits I, "pineapple" (the default value) will be returned. Note that 3 marks the 3rd element of the list, and is I an index value into the array. If the user enters C<1>, C<2> or C<3>, the corresponding text string (C<"apple">, C<"pear">, C<"pineapple"> will be returned by C. =cut ################################################## sub pick { ################################################## my ($prompt, $options, $default) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my $default_int; my %files; if(@_ != 3 or ref($options) ne "ARRAY") { LOGCROAK("pick called with wrong #/type of args"); } { my $count = 0; foreach (@$options) { print STDERR "[", ++$count, "] $_\n"; $default_int = $count if $count eq $default; $files{$count} = $_; } print STDERR "$prompt [$default_int]> " or die "Couldn't write STDERR: ($!)"; my $input = ; chomp($input) if defined $input; $input = $default_int if !defined $input or !length($input); redo if $input !~ /^\d+$/ or $input == 0 or $input > scalar @$options; return "$files{$input}"; } } =pod =item C Ask the user to either hit I and select the displayed default or to type in another string. =cut ################################################## sub ask { ################################################## my ($prompt, $default) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; if(@_ != 2) { LOGCROAK("ask() called with wrong # of args"); } print STDERR "$prompt [$default]> " or die "Couldn't write STDERR: ($!)"; my $value = ; chomp $value; $value = $default if $value eq ""; return $value; } =pod =item C Create a directory of arbitrary depth, just like C. =cut ############################################### sub mkd { ############################################### local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "mkd @_" or return 1; INFO "mkpath @_"; mkpath @_ or LOGCROAK("Cannot mkdir @_ ($!)"); } =pod =item C Delete a directory and all of its descendents, just like C in the shell. =cut ############################################### sub rmf { ############################################### local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "rmf $_[0]" or return 1; if(!-e $_[0]) { DEBUG "$_[0] doesn't exist - ignored"; return; } INFO "rmtree @_"; rmtree $_[0] or LOGCROAK("Cannot rmtree $_[0] ($!)"); } =pod =item C chdir to the given directory. If you don't want to have cd() modify the internal directory stack (used for subsequent cdback() calls), set the stack_update parameter to a false value: cd($dir, {stack_update => 0}); =cut ############################################### sub cd { ############################################### local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; INFO "cd $_[0]"; my $opts = { stack_update => 1 }; $opts = $_[1] if ref $_[1] eq "HASH"; if ($opts->{stack_update}) { my $cwd = getcwd(); if(! defined $cwd) { LOGCROAK("Cannot getcwd ($!)"); ; } push @DIR_STACK, $cwd; } chdir($_[0]) or LOGCROAK("Cannot cd $_[0] ($!)"); } =pod =item C chdir back to the last directory before a previous C. If the option C is set, it goes all the way back to the beginning of the directory stack, i.e. no matter how many cd() calls were made in between, it'll go back to the original directory: # go all the way back cdback( { reset => 1 } ); =cut ############################################### sub cdback { ############################################### my( $opts ) = @_; $opts = {} if !defined $opts; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; LOGCROAK("cd stack empty") unless @DIR_STACK; if( $opts->{ reset } ) { @DIR_STACK = ( $DIR_STACK[0] ); } my $old_dir = pop @DIR_STACK; LOGCROAK("Directory stack empty") if ! defined $old_dir; INFO "cdback to $old_dir"; cd($old_dir, {stack_update => 0}); } =pod =item C Call C in the shell. =cut ############################################### sub make { ############################################### local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "make @_" or return 1; INFO "make @_"; system("make @_") and LOGCROAK("Cannot make @_ ($!)"); } =pod =cut ############################################### sub check_zlib { ############################################### my($tar_file) = @_; if($tar_file =~ /\.tar\.gz\b|\.tgz\b/ and !Log::Log4perl::Util::module_available("IO::Zlib")) { LOGCROAK("$tar_file: Compressed tarballs can ", "only be processed with IO::Zlib installed."); } } ####################################### sub archive_sniff { ####################################### my($name) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; DEBUG "Sniffing archive '$name'"; my ($dir) = ($name =~ /(.*?)\.(tar\.gz|tgz|tar)$/); return 0 unless defined $dir; $dir = basename($dir); DEBUG "dir=$dir"; my $topdir; check_zlib($name); require Archive::Tar; my $tar = Archive::Tar->new($name); my @names = $tar->list_files(["name"]); LOGCROAK("Archive $name is empty") unless @names; (my $archdir = $names[0]) =~ s#/.*##; DEBUG "archdir=$archdir"; for my $name (@names) { next if $name eq "./"; $name =~ s#^\./##; ($topdir = $name) =~ s#/.*##; if($topdir ne $archdir) { return (0, $dir, $dir); } } DEBUG "Return $topdir $dir"; return (1, $topdir, $dir); } =pod =item C Simulate "perl -pie 'do something' file". Edits files in-place. Expects a reference to a subroutine as its first argument. It will read out the file C<$filename> line by line and calls the subroutine setting a localized C<$_> to the current line. The return value of the subroutine will replace the previous value of the line. Example: # Replace all 'foo's by 'bar' in test.dat pie(sub { s/foo/bar/g; $_; }, "test.dat"); Works with one or more file names. If the files are known to contain UTF-8 encoded data, and you want it to be read/written as a Unicode strings, use the C option: pie(sub { s/foo/bar/g; $_; }, "test.dat", { utf8 => 1 }); =cut ############################################### sub pie { ############################################### my($coderef, @files) = @_; my $options = {}; if(defined $files[-1] and ref $files[-1] eq "HASH") { $options = pop @files; } local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; for my $file (@files) { _confirm "editing $file in-place" or next; my $out = ""; open FILE, "<$file" or LOGCROAK("Cannot open $file ($!)"); if( $options->{utf8} ) { binmode FILE, ":utf8"; } while() { $out .= $coderef->($_); } close FILE; blurt($out, $file, $options); } } =pod =item C Simulate "perl -ne 'do something' file". Iterates over all lines of all input files and calls the subroutine provided as the first argument. Example: # Print all lines containing 'foobar' plough(sub { print if /foobar/ }, "test.dat"); Works with one or more file names. If the files are known to contain UTF-8 encoded data, and you want it to be read into Unicode strings, use the C option: plough(sub { print if /foobar/ }, "test.dat", { utf8 => 1 }); =cut ############################################### sub plough { ############################################### my($coderef, @files) = @_; my $options = {}; if(defined $files[-1] and ref $files[-1] eq "HASH") { $options = pop @files; } local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; for my $file (@files) { _confirm "Ploughing through $file" or next; my $out = ""; open FILE, "<$file" or LOGCROAK("Cannot open $file ($!)"); if( $options->{utf8} ) { binmode FILE, ":utf8"; } while() { $coderef->($_); } close FILE; } } =pod =item C Slurps in the file and returns a scalar with the file's content. If called without argument, data is slurped from STDIN or from any files provided on the command line (like EE operates). If the file is known to contain UTF-8 encoded data and you want to read it in as a Unicode string, use the C option: my $unicode_string = slurp( $file, {utf8 => 1} ); =cut ############################################### sub slurp { ############################################### my($file, $options) = @_; $options = {} unless defined $options; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my $from_file = defined($file); local $/ = undef; my $data; if($from_file) { INFO "Slurping data from $file"; open FILE, "<$file" or LOGCROAK("Cannot open $file ($!)"); binmode FILE; # Win32 wants that if( exists $options->{utf8} ) { binmode FILE, ":utf8"; } $data = ; close FILE; DEBUG "Read ", snip($data, $DATA_SNIPPED_LEN), " from $file"; } else { INFO "Slurping data from <>"; $data = <>; DEBUG "Read ", snip($data, $DATA_SNIPPED_LEN), " from <>"; } return $data; } =pod =item C Opens a new file, prints the data in C<$data> to it and closes the file. If C<$append> is set to a true value, data will be appended to the file. Default is false, existing files will be overwritten. If the string is a Unicode string, use the C option: blurt( $unicode_string, $file, {utf8 => 1} ); =cut ############################################### sub blurt { ############################################### my($data, $file, $options) = @_; # legacy signature if(defined $options and ref $options eq "") { $options = { append => 1 }; } $options = {} unless defined $options; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; $options->{append} = 0 unless defined $options->{append}; _confirm(($options->{append} ? "Appending" : "Writing") . " " . length($data) . " bytes to $file") or return 1; open FILE, ">" . ($options->{append} ? ">" : "") . $file or LOGCROAK("Cannot open $file for writing ($!)"); binmode FILE; # Win32 wants that if( $options->{utf8} ) { binmode FILE, ":utf8"; } print FILE $data or LOGCROAK("Cannot write to $file ($!)"); close FILE or LOGCROAK("Cannot close $file ($!)"); DEBUG "Wrote ", snip($data, $DATA_SNIPPED_LEN), " to $file"; } =pod =item C Write the data in $data to a file $file, guaranteeing that the operation will either complete fully or not at all. This is accomplished by first writing to a temporary file which is then rename()ed to the target file. Unlike in C, there is no C<$append> mode in C. If the string is a Unicode string, use the C option: blurt_atomic( $unicode_string, $file, {utf8 => 1} ); =cut ############################################### sub blurt_atomic { ############################################### my($data, $file, $options) = @_; _confirm("Writing atomically " . length($data) . " bytes to $file") or return 1; $options = {} unless defined $options; my($fh, $tmpname) = tempfile(DIR => dirname($file)); blurt($data, $tmpname, $options); close $fh; rename $tmpname, $file or LOGDIE "Can't rename $tmpname to $file"; DEBUG "Wrote ", snip($data, $DATA_SNIPPED_LEN), " atomically to $file"; } =pod =item C<($stdout, $stderr, $exit_code) = tap($cmd, @args)> Run a command $cmd in the shell, and pass it @args as args. Capture STDOUT and STDERR, and return them as strings. If C<$exit_code> is 0, the command succeeded. If it is different, the command failed and $exit_code holds its exit code. Please note that C is limited to single shell commands, it won't work with output redirectors (C/tmp/foo> 2E&1). In default mode, C will concatenate the command and args given and create a shell command line by redirecting STDERR to a temporary file. C, for example, will result in 'ls' '/tmp' 2>/tmp/sometempfile | Note that all commands are protected by single quotes to make sure arguments containing spaces are processed as singles, and no globbing happens on wildcards. Arguments containing single quotes or backslashes are escaped properly. If quoting is undesirable, C accepts an option hash as its first parameter, tap({no_quotes => 1}, "ls", "/tmp/*"); which will suppress any quoting: ls /tmp/* 2>/tmp/sometempfile | Or, if you prefer double quotes, use tap({double_quotes => 1}, "ls", "/tmp/$VAR"); wrapping all args so that shell variables are interpolated properly: "ls" "/tmp/$VAR" 2>/tmp/sometempfile | Another option is "utf8" which runs the command in a terminal set to UTF8. Error handling: By default, tap() won't raise an error if the command's return code is nonzero, indicating an error reported by the shell. If bailing out on errors is requested to avoid return code checking by the script, use the raise_error option: tap({raise_error => 1}, "ls", "doesn't exist"); In DEBUG mode, C logs the entire stdout/stderr output, which can get too verbose at times. To limit the number of bytes logged, use the C and C options tap({stdout_limit => 10}, "echo", "123456789101112"); =cut ############################################### sub tap { ############################################### my(@args) = @_; my $options = {}; if(defined $args[-1] and ref $args[-1] eq "HASH") { $options = pop @args; } local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "tapping @args" or return 1; my $opts = {}; $opts = shift @args if ref $args[0] eq "HASH"; my $tmpfh = File::Temp->new(UNLINK => 1, SUFFIX => '.dat'); my $tmpfile = $tmpfh->filename(); DEBUG "tempfile $tmpfile created"; my $cmd; if($opts->{no_quotes}) { $cmd = join ' ', @args; } elsif($opts->{double_quotes}) { $cmd = join ' ', map { qquote($_, ":shell") } @args; } else { # Default mode: Single quotes $cmd = join ' ', map { quote($_, ":shell") } @args; } $cmd = "$cmd 2>$tmpfile |"; INFO "tapping $cmd"; open PIPE, $cmd or LOGCROAK("open $cmd | failed ($!)"); if( $options->{utf8} ) { binmode PIPE, ":utf8"; } my $stdout = join '', ; close PIPE; my $exit_code = $?; if($exit_code != 0 and $opts->{raise_error}) { LOGCROAK("tap $cmd | failed ($!)"); } my $stderr = slurp($tmpfile, $options); if( $opts->{ stdout_limit } ) { $stdout = snip( $stdout, $opts->{ stdout_limit } ); } if( $opts->{ stderr_limit } ) { $stderr = snip( $stderr, $opts->{ stderr_limit } ); } DEBUG "tap $cmd results: rc=$exit_code stderr=[$stderr] stdout=[$stdout]"; return ($stdout, $stderr, $exit_code); } =pod =item C<$quoted_string = qquote($string, [$metachars])> Put a string in double quotes and escape all sensitive characters so there's no unwanted interpolation. E.g., if you have something like print "foo!\n"; and want to put it into a double-quoted string, it will look like "print \"foo!\\n\"" Sometimes, not only backslashes and double quotes need to be escaped, but also the target environment's meta chars. A string containing print "$<\n"; needs to have the '$' escaped like "print \"\$<\\n\";" if you want to reuse it later in a shell context: $ perl -le "print \"\$<\\n\";" 1212 C supports escaping these extra characters with its second, optional argument, consisting of a string listing all escapable characters: my $script = 'print "$< rocks!\\n";'; my $escaped = qquote($script, '!$'); # Escape for shell use system("perl -e $escaped"); => 1212 rocks! And there's a shortcut for shells: By specifying ':shell' as the metacharacters string, qquote() will actually use '!$`'. For example, if you wanted to run the perl code print "foobar\n"; via perl -e ... on a box via ssh, you would use use Sysadm::Install qw(qquote); my $cmd = 'print "foobar!\n"'; $cmd = "perl -e " . qquote($cmd, ':shell'); $cmd = "ssh somehost " . qquote($cmd, ':shell'); print "$cmd\n"; system($cmd); and get ssh somehost "perl -e \"print \\\"foobar\\\!\\\\n\\\"\"" which runs on C without hickup and prints C. Sysadm::Install comes with a script C (installed in bin), which takes arbitrary perl code on STDIN and transforms it into a one-liner: $ one-liner Type perl code, terminate by CTRL-D print "hello\n"; print "world\n"; ^D perl -e "print \"hello\\n\"; print \"world\\n\"; " =cut ############################################### sub qquote { ############################################### my($str, $metas) = @_; $str =~ s/([\\"])/\\$1/g; if(defined $metas) { $metas = '!$`' if $metas eq ":shell"; $metas =~ s/\]/\\]/g; $str =~ s/([$metas])/\\$1/g; } return "\"$str\""; } =pod =item C<$quoted_string = quote($string, [$metachars])> Similar to C, just puts a string in single quotes and escapes what needs to be escaped. Note that shells typically don't support escaped single quotes within single quotes, which means that $ echo 'foo\'bar' > is invalid and the shell waits until it finds a closing quote. Instead, there is an evil trick which gives the desired result: $ echo 'foo'\''bar' # foo, single quote, \, 2 x single quote, bar foo'bar It uses the fact that shells interpret back-to-back strings as one. The construct above consists of three back-to-back strings: (1) 'foo' (2) ' (3) 'bar' which all get concatenated to a single foo'bar If you call C with C<$metachars> set to ":shell", it will perform that magic behind the scenes: print quote("foo'bar"); # prints: 'foo'\''bar' =cut ############################################### sub quote { ############################################### my($str, $metas) = @_; if(defined $metas and $metas eq ":shell") { $str =~ s/([\\])/\\$1/g; $str =~ s/(['])/'\\''/g; } else { $str =~ s/([\\'])/\\$1/g; } if(defined $metas and $metas ne ":shell") { $metas =~ s/\]/\\]/g; $str =~ s/([$metas])/\\$1/g; } return "\'$str\'"; } =pod =item C Read the C<$src> file's user permissions and modify all C<$dst> files to reflect the same permissions. =cut ###################################### sub perm_cp { ###################################### # Lifted from Ben Okopnik's # http://www.linuxgazette.com/issue87/misc/tips/cpmod.pl.txt local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "perm_cp @_" or return 1; LOGCROAK("usage: perm_cp src dst ...") if @_ < 2; my $perms = perm_get($_[0]); perm_set($_[1], $perms); } =pod =item C Read the C<$src> file/directory's owner uid and group gid and apply it to $dst. For example: copy uid/gid of the containing directory to a file therein: use File::Basename; owner_cp( dirname($file), $file ); Usually requires root privileges, just like chown does. =cut ###################################### sub owner_cp { ###################################### my($src, @dst) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "owner_cp @_" or return 1; LOGCROAK("usage: owner_cp src dst ...") if @_ < 2; my($uid, $gid) = (stat($src))[4,5]; if(!defined $uid or !defined $gid ) { LOGCROAK("stat of $src failed: $!"); return undef; } if(!chown $uid, $gid, @dst ) { LOGCROAK("chown of ", join(" ", @dst), " failed: $!"); return undef; } return 1; } =pod =item C<$perms = perm_get($filename)> Read the C<$filename>'s user permissions and owner/group. Returns an array ref to be used later when calling C. =cut ###################################### sub perm_get { ###################################### my($filename) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my @stats = (stat $filename)[2,4,5] or LOGCROAK("Cannot stat $filename ($!)"); INFO "perm_get $filename (@stats)"; return \@stats; } =pod =item C Set file permissions and owner of C<$filename> according to C<$perms>, which was previously acquired by calling C. =cut ###################################### sub perm_set { ###################################### my($filename, $perms) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "perm_set $filename (@$perms)" or return 1; chown($perms->[1], $perms->[2], $filename) or LOGCROAK("Cannot chown $filename ($!)"); chmod($perms->[0] & 07777, $filename) or LOGCROAK("Cannot chmod $filename ($!)"); } =pod =item C Run a shell command via C and die() if it fails. Also works with a list of arguments, which are then interpreted as program name plus arguments, just like C does it. =cut ###################################### sub sysrun { ###################################### my(@cmds) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "sysrun: @cmds" or return 1; LOGCROAK("usage: sysrun cmd ...") if @_ < 1; system(@cmds) and LOGCROAK("@cmds failed ($!)"); } =pod =item C Run a command in the shell and simulate a user hammering the ENTER key to accept defaults on prompts. =cut ###################################### sub hammer { ###################################### my(@cmds) = @_; require Expect; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "Hammer: @cmds" or return 1; my $exp = Expect->new(); $exp->raw_pty(0); INFO "spawning: @cmds"; $exp->spawn(@cmds); $exp->send_slow(0.1, "\n") for 1..199; $exp->expect(undef); } =pod =item C Alias for C, just like Perl6 is going to provide it. =cut ###################################### sub say { ###################################### print @_, "\n"; } =pod =item C Check if the current script is running as root. If yes, continue. If not, restart the current script with all command line arguments is restarted under sudo: sudo scriptname args ... Make sure to call this before any C<@ARGV>-modifying functions like C have kicked in. =cut ###################################### sub sudo_me { ###################################### my($argv) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; _confirm "sudo_me" or return 1; $argv = \@ARGV unless $argv; # If we're not running as root, # re-invoke the script via sudo if($> != 0) { DEBUG "Not running as root, calling sudo $0 @$argv"; my $sudo = bin_find("sudo"); LOGCROAK("Can't find sudo in PATH") unless $sudo; exec($sudo, $0, @$argv) or LOGCROAK("exec failed!"); } } =pod =item C Search all directories in $PATH (the ENV variable) for an executable named $program and return the full path of the first hit. Returns C if the program can't be found. =cut ###################################### sub bin_find { ###################################### my($exe) = @_; require Config; my $path_sep = ":"; $path_sep = $Config::Config{path_sep} if defined $Config::Config{path_sep}; for my $path (split /$path_sep/, $ENV{PATH}) { my $full = File::Spec->catfile($path, $exe); return $full if -x $full and ! -d $full; } return undef; } =pod =item C Opens a file handle to read the output of the following process: cd $dir; find ./ -xdev -print0 | cpio -o0 | This can be used to capture a file system structure. =cut ###################################### sub fs_read_open { ###################################### my($dir, $options) = @_; $options = {} unless defined $options; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my $find = bin_find("find"); LOGCROAK("Cannot find 'find'") unless defined $find; my $cpio = bin_find("cpio"); LOGCROAK("Cannot find 'cpio'") unless defined $cpio; cd $dir; my $cmd = "$find . -xdev -print0 | $cpio -o0 --quiet 2>/dev/null "; DEBUG "Reading from $cmd"; open my $in, "$cmd |" or LOGCROAK("Cannot open $cmd"); binmode $in, ":utf8" if $options->{utf8}; cdback; return $in; } =pod =item C Opens a file handle to write to a | (cd $dir; cpio -i0) process to restore a file system structure. To be used in conjunction with I. =cut ###################################### sub fs_write_open { ###################################### my($dir, $options) = @_; $options = {} unless defined $options; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my $cpio = bin_find("cpio"); LOGCROAK("Cannot find 'cpio'") unless defined $cpio; mkd $dir unless -d $dir; cd $dir; my $cmd = "$cpio -i0 --quiet"; DEBUG "Writing to $cmd in dir $dir"; open my $out, "| $cmd" or LOGCROAK("Cannot open $cmd"); binmode $out, ":utf8" if $options->{utf8}; cdback; return $out; } =pod =item C Reads from $in and writes to $out, using sysread and syswrite. The buffer size used defaults to 4096, but can be set explicitely. =cut ###################################### sub pipe_copy { ###################################### my($in, $out, $bufsize) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; $bufsize ||= 4096; my $bytes = 0; INFO "Opening pipe (bufsize=$bufsize)"; my $ret; while($ret = sysread($in, my $buf, $bufsize)) { $bytes += length $buf; if (!defined syswrite $out, $buf) { LOGCROAK("Write to pipe failed: ($!)"); } } if (!defined $ret) { LOGCROAK("Read from pipe failed: ($!)"); } INFO "Closed pipe (bufsize=$bufsize, transferred=$bytes)"; } =pod =item C Format the data string in C<$data> so that it's only (roughly) $maxlen characters long and only contains printable characters. If C<$data> is longer than C<$maxlen>, it will be formatted like (22)[abcdef[snip=11]stuvw] indicating the length of the original string, the beginning, the end, and the number of 'snipped' characters. If C<$data> is shorter than $maxlen, it will be returned unmodified (except for unprintable characters replaced, see below). If C<$data> contains unprintable character's they are replaced by "." (the dot). =cut ########################################### sub snip { ########################################### my($data, $maxlen) = @_; if(length $data <= $maxlen) { return printable($data); } $maxlen = 12 if $maxlen < 12; my $sniplen = int(($maxlen - 8) / 2); my $start = substr($data, 0, $sniplen); my $end = substr($data, -$sniplen); my $snipped = length($data) - 2*$sniplen; return lenformat("$start\[snip=$snipped]$end", length $data); } ########################################### sub lenformat { ########################################### my($data, $orglen) = @_; return "(" . ($orglen || length($data)) . ")[" . printable($data) . "]"; } ########################################### sub printable { ########################################### my($data) = @_; $data =~ s/[^ \w.;!?@#$%^&*()+\\|~`',><[\]{}="-]/./g; return $data; } =pod =item C Reads in a password to be typed in by the user in noecho mode. A call to password_read("password: ") results in password: ***** (stars aren't actually displayed) This function will switch the terminal back into normal mode after the user hits the 'Return' key. =cut ########################################### sub password_read { ########################################### my($prompt) = @_; use Term::ReadKey; ReadMode 'noecho'; $| = 1; print "$prompt" or die "Couldn't write STDOUT: ($!)"; my $pw = ReadLine 0; chomp $pw; ReadMode 'restore'; print "\n" or die "Couldn't write STDOUT: ($!)"; return $pw; } =pod =item C Format the time in a human-readable way, less wasteful than the 'scalar localtime' formatting. print nice_time(), "\n"; # 2007/04/01 10:51:24 It uses the system time by default, but it can also accept epoch seconds: print nice_time(1170000000), "\n"; # 2007/01/28 08:00:00 It uses localtime() under the hood, so the outcome of the above will depend on your local time zone setting. =cut ########################################### sub nice_time { ########################################### my($time) = @_; $time = time() unless defined $time; my ($sec,$min,$hour,$mday,$mon,$year, $wday,$yday,$isdst) = localtime($time); return sprintf("%d/%02d/%02d %02d:%02d:%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec); } =item C Perl-5.9 added the //= construct, which helps assigning values to undefined variables. Instead of writing if(!defined $foo) { $foo = $default; } you can just write $foo //= $default; However, this is not available on older perl versions (although there's source filter solutions). Often, people use $foo ||= $default; instead which is wrong if $foo contains a value that evaluates as false. So Sysadm::Install, the everything-and-the-kitchen-sink under the CPAN modules, provides the function C which can be used like def_or($foo, $default); to accomplish the same as $foo //= $default; How does it work, how does $foo get a different value, although it's apparently passed in by value? Modifying $_[0] within the subroutine is an old Perl trick to do exactly that. =cut ########################################### sub def_or($$) { ########################################### if(! defined $_[0]) { $_[0] = $_[1]; } } =item C Check if the given string has the utf8 flag turned on. Works just like Encode.pm's is_utf8() function, except that it silently returns a false if Encode isn't available, for example when an ancient perl without proper utf8 support is used. =cut ############################################### sub is_utf8_data { ############################################### my($data) = @_; if( !utf8_available() ) { return 0; } return Encode::is_utf8( $data ); } =item C Check if we're using a perl with proper utf8 support, by verifying the Encode.pm module is available for loading. =cut ############################################### sub utf8_available { ############################################### eval "use Encode"; if($@) { return 0; } return 1; } =item C Return the path to the home directory of the current user. =cut ############################################### sub home_dir { ############################################### my( $home ) = glob "~"; return $home; } =pod =back =head1 AUTHOR Mike Schilli, Em@perlmeister.comE =head1 COPYRIGHT AND LICENSE Copyright (C) 2004-2007 by Mike Schilli This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.3 or, at your option, any later version of Perl 5 you may have available. =cut 1; Sysadm-Install-0.43/eg/ask000755 040416 000024 00000000611 12120677576 016362 0ustar00mschillistaff000000 000000 #!/usr/bin/perl ########################################### # xx -- # Mike Schilli, 2004 (m@perlmeister.com) ########################################### use warnings; use strict; use Sysadm::Install qw(ask pick); my $name = ask("Type in your name", "Joe"); print "Your name is $name.\n"; my $fruit = pick("Pick a fruit", ["apple", "pear", "pineapple"], 3); print "Your picked $fruit.\n"; Sysadm-Install-0.43/eg/mkperl000755 040416 000024 00000000600 12120677576 017074 0ustar00mschillistaff000000 000000 #!/usr/local/bin/perl use Log::Log4perl qw(:easy); Log::Log4perl->easy_init({level => $DEBUG, layout => '%F %L: %m%n'}); use Sysadm::Install qw(download hammer untar cd sysrun); download "http://www.perl.com/CPAN/src/stable.tar.gz"; untar "stable.tar.gz"; cd "stable"; print `pwd`, "\n"; hammer("./Configure", "-d", "-D", "prefix=/home/mschilli/PERL-test"); sysrun("make install"); Sysadm-Install-0.43/eg/one-liner000755 040416 000024 00000000274 12120677576 017501 0ustar00mschillistaff000000 000000 #!/usr/bin/perl use Sysadm::Install qw(:all); print STDERR "Type perl code, terminate by CTRL-D\n"; my $in = join "", <>; $in =~ s/\n/ /g; print "perl -e ", qquote($in, ':shell'), "\n"; Sysadm-Install-0.43/eg/perm_cp000755 040416 000024 00000000572 12120677576 017237 0ustar00mschillistaff000000 000000 #!/usr/bin/perl ########################################### # perm_cp # Mike Schilli, 2005 (m@perlmeister.com) # Copy file permissions/owner from one file # to another ########################################### use warnings; use strict; use Sysadm::Install qw(:all); use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($DEBUG); Sysadm::Install::dry_run(1); perm_cp(@ARGV); Sysadm-Install-0.43/eg/tap000755 040416 000024 00000000713 12120677576 016373 0ustar00mschillistaff000000 000000 #!/usr/bin/perl ########################################### # taptest # Mike Schilli, 2004 (m@perlmeister.com) ########################################### use warnings; use strict; use Sysadm::Install qw(:all); use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($DEBUG); my($stdout, $stderr, $exit_code) = tap(qw( rsync --verbose --archive tmp /tmp/rsync-tmp )); print "stdout=[$stdout]\n"; print "stderr=[$stderr]\n"; print "exit_code=[$exit_code]\n"; Sysadm-Install-0.43/eg/untar_in000755 040416 000024 00000000462 12120677576 017427 0ustar00mschillistaff000000 000000 #!/usr/bin/perl ########################################### # xx -- # Mike Schilli, 2004 (m@perlmeister.com) ########################################### use warnings; use strict; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($DEBUG); use Sysadm::Install qw(untar_in); untar_in("t.tgz", "tmp");