#!/usr/bin/perl use strict; use warnings; use File::Basename; use Getopt::Long; use Math::BigInt; use Pod::Usage; our $VERSION = v0.1.10; # # KNOWN COMMANDS # our $commands = { # shellutils basename => [1, -1, \&cmd_basename ], chroot => [0, -1, \&cmd_unsafe ], date => [0, -1, \&cmd_unimp ], dirname => [1, 1, \&cmd_dirname ], echo => [0, -1, \&cmd_echo ], env => [0, -1, \&cmd_env ], expr => [1, -1, \&cmd_expr ], false => [0, 0, sub { 1 } ], factor => [0, -1, \&cmd_factor ], printenv => [0, -1, \&cmd_printenv ], true => [0, 0, sub { 0 } ], # Fallback for unknown command UNKNOWN => [0, -1, sub { die "perlbox doesn't know how to do that.\n" }], }; our $extra_opts = { echo => [qw( e n )], env => [qw( unset|u=s@ ignore-environment|i| )], }; sub cmd_basename { my $cmd = shift; my ($path, @suffix_regexen) = @{$cmd->{args}}; # We don't want basename(), which quotes away all the metacharacters $path = (fileparse($path, @suffix_regexen))[0]; print "$path\n" or die "Could not print to STDOUT: $!\n"; return 0; } sub cmd_dirname { my $cmd = shift; my ($path) = @{$cmd->{args}}; $path = dirname($path); print "$path\n" or die "Could not print to STDOUT: $!\n"; return 0; } sub cmd_echo { my $cmd = shift; my $opts = $cmd->{opts}; my $out = "@{$cmd->{args}}"; if ($opts->{e}){ $opts->{n} = 1 if $out =~ s/\\c$//; $out = eval qq{"$out"}; die $@ if $@; } $out .= "\n" unless $opts->{n}; print $out or die "Could not print to STDOUT: $!\n"; return 0; } sub cmd_env { my $cmd = shift; my $opts = $cmd->{opts}; my @unset = @{$opts->{unset} || []}; my @args = @{$cmd->{args}}; %ENV = () if $opts->{'ignore-environment'}; delete $ENV{$_} foreach @unset; while (@args) { last unless $args[0] =~ /^(\w+)=(\S+)$/; $ENV{$1} = $2; shift @args; } if (@args) { exec { $args[0] } @args or die "Could not exec '$args[0]': $!\n"; } else { $cmd->{args} = \@args; return cmd_printenv($cmd); } } sub cmd_expr { my $cmd = shift; my $expr = "@{$cmd->{args}}"; my @results = eval $expr; die $@ if $@; my $false = @results == 0 || !$results[-1]; print map "$_\n" => @results or die "Could not print to STDOUT: $!\n"; return($false); } sub cmd_factor { my $cmd = shift; my @nums = @{$cmd->{args} || []}; my $immediate = -t STDOUT; $|++ if $immediate; if (@nums) { foreach my $num (@nums) { my @factors = factor($num, $immediate); print "$num: @factors\n" unless $immediate; } } else { warn "$cmd->{cmd}: Reading from STDIN.\n" if -t STDIN; while (<>) { my @factors = factor($_, $immediate); print "$_: @factors\n" unless $immediate; } } return 0; } sub factor { my ($num, $print) = @_; print "$num:" if $print; my @factors; my $big = Math::BigInt->new($num); unless ($big) { print " 0" if $print; return 0; } if ($big == Math::BigInt->new(1)) { print " 1" if $print; return 1; } if ($big < 0) { print " -1" if $print; @factors = (-1); $big = $big->bneg(); } while ($big->bmod(2) == 0) { push @factors, 2; $big = Math::BigInt->new(scalar $big->bdiv(2)); } for (my $current = Math::BigInt->new(3); $current * $current <= $big; $current += Math::BigInt->new(2)) { my ($div, $mod) = $big->bdiv($current); if ($mod == 0) { if ($print) { my $val = " $current"; $val =~ s/\+//; print $val; } push @factors, $current; $big = Math::BigInt->new($div); redo; } } if ($big != Math::BigInt->new(1)) { if ($print) { my $val = " $big"; $val =~ s/\+//; print $val; } push @factors, $big; } return map {$_ =~ s/^\+//; $_} @factors; } sub cmd_printenv { my $cmd = shift; my @vars = @{$cmd->{args}}; my $status = 0; @vars = sort keys %ENV unless @vars; foreach my $var (@vars) { print "$var=$ENV{$var}\n" if exists $ENV{$var}; $status = 1 if not exists $ENV{$var}; } return $status; } sub cmd_unimp { my $cmd = shift; die "$cmd->{cmd}: UNIMPLEMENTED.\n"; } sub cmd_unsafe { my $cmd = shift; die "$cmd->{cmd}: UNIMPLEMENTED; requires elevated privileges.\nSee the SECURITY section of the manpage for details.\n"; } # # THE GUTS # { my $cmd = { orig_cmd => $0, cmd => basename($0), orig_args => [@ARGV], }; parse_opts($cmd); short_circuit_opts($cmd); $cmd->{cmd} = shift if $cmd->{cmd} eq 'perlbox'; $cmd->{args} = [@ARGV]; my ($min_args, $max_args, $cmd_func) = @{$commands->{$cmd->{cmd}} || $commands->{UNKNOWN}}; printf "Command: %s (%s-%s args)\n", $cmd->{cmd}, $min_args, $max_args < 0 ? 'inf' : $max_args; pod2usage(-msg => "$cmd->{cmd}: Not enough arguments given.") unless @ARGV >= $min_args; pod2usage(-msg => "$cmd->{cmd}: Too many arguments given.") unless @ARGV <= $max_args or $max_args < 0; exit($cmd_func->($cmd)); } sub parse_opts { my $cmd = shift; my @global_opts = qw( help|? man version ); my @cmd_opts = @{$extra_opts->{$cmd->{cmd}} || []}; my @opts = (@global_opts, @cmd_opts); my %opts; Getopt::Long::Configure('require_order'); GetOptions(\%opts, @opts) or pod2usage(2); $cmd->{opts} = \%opts; } sub short_circuit_opts { my $cmd = shift; my %opts = %{$cmd->{opts}}; show_version() if $opts{version}; pod2usage(1) if $opts{help}; pod2usage(-verbose => 2) if $opts{man}; exit(1) if $opts{version}; } sub show_version { printf "This is perlbox, v%vd, running on $^O.\n", $VERSION; while () { print if /^=head1 COPYRIGHT/ ... /^=/ and !/=/; } } __END__ =head1 NAME perlbox -- many standard unix tools, one Perl program =head1 SYNOPSIS perlbox [options] command [args]... basename [options] path [suffix_regexen]... dirname [options] path echo [options] [args]... env [options] [name=value]... [command [args]...] expr [options] chunks... false [options] printenv [options] [vars]... true [options] Global options: --version Version and copyright information -?|--help Usage information --man Full documentation =head1 OPTIONS =over 4 =item B<--version> Print version and copyright information (and optionally usage or even full documentation, if those options are given), then exit. =item B<-? | --help> Print usage information and exit. =item B<--man> Print full documentation and exit. =back =head1 DESCRIPTION Perlbox is a Perl pseudo-equivalent to the C program busybox. Both are designed to contain the most important features of a large number of standard unix programs, while gaining economies of scale in the code by sharing commonalities amongst many diverse commands. However, where busybox attempts to be small (both in disk footprint and memory footprint) as an overriding concern, perlbox makes use of both implementation in Perl and its economies of scale to try to bring expressive power, good unix practices and some measure of sanity to the world of common unix utilities, without having to produce tens of thousands of lines of code to do so. As a side benefit, writing perlbox gives the author a chance to grok Unix at a deeper level than he had previously -- attempting to really understand the meaning and use of every option on every command, and then step back and rationalize and generalize those options, will tend to that. Oh my, it will. Perlbox commands can be called with 'perlbox I', or through filesystem links (either hard or symbolic) from supported command names to perlbox, directly as usual. All perlbox commands support the global options B<-?>, B<--help>, B<--man>, and B<--version>. All commands will print an error and usage message on STDERR and exit with status 2 when given invalid, too many, or too few arguments. Any command that eval's Perl code will die with C<$@> when an error occurs, in the customary fashion. Commands that always only print out at most a single line of results generally include a trailing newline, unless an option is used to turn the trailing newline off. Commands that may print out many lines of results always include a newline after each line. Perlbox currently supports the following commands: =over 4 =item B Accepts one or more arguments -- either a B by itself, or a path and a list of B. The path is stripped of all leading directory information first. Then, if any suffix_regexen are given, each is matched against the end of the path in turn; any matching characters are stripped. The result is printed on STDOUT. =item B Accepts one argument, a file B. The directory portion of the path is printed on STDOUT. =item B Echoes the B to STDOUT; each is separated by a space, and a trailing newline is appended, unless the B<-n> option is given. If the B<-e> option is given, the string is eval'ed once inside a double-quoted context, and that result is then printed. As a special case, if the last two characters of the last argument are C<\c>, the B<-n> option will be implicitely set, and the C<\c> removed before performing the eval. In any other location, C<\c> will have its normal Perlish meaning of introducing a control character. =item B]... [I=I]... [command [args]...]> Alters the environment in specified ways, and then execs the B with the given B. If no B is given, the resulting environment is displayed as if the B were B (but handled internally). B<--ignore-environment> will unset all existing environment variables. B<--unset> will unset one at a time. Any leading B=I> pairs will set the environment variable I to the value I. I is allowed to be empty, and the variable will then be set but with an empty value. =item B Joins together all the B, with a space in between, eval's them as Perl code in I context, then prints the results to STDOUT, one result per line. Exits with status 0 if at least one result was returned, and the last one is true in the Perl sense. Otherwise, exits with status 1. =item B The classic do nothing and fail utility. Just exits with status 1. =item B Prints out the value of either the listed environment B, or all set environment vars sorted by name if no specific B are requested. Each variable is printed in C=I> format, one per line. Exits with status 0 if all B had been set (or none were given), and status 1 if some given B were not set. Variables with an empty value are still considered to be set. =item B The classic do nothing and do it successfully utility. Just exits with status 0. =head1 SECURITY One of the major decisions made in the design of perlbox is that the full power of Perl would be available to any command for which that made sense. For this reason, trust perlbox no more than you would a raw Perl interpreter. No attempt has been made to untaint arguments, but no attempt has been made to maintain tainting where that is desirable, so you can't trust tainting to save you, either. If you think you have a reason to call perlbox from a secure daemon, a setuid/setgid program, or some other security-sensitive situation, B. Certain commands cannot be used without elevated privileges (typically root), so where a standard package of unix commands would include one of these, perlbox recognizes the offending command and errors out if use of it is attempted. The list of such commands is currently just B (part of I). =head1 TODO =over 4 =item * Document B =item * Faster replacement for Math::BigInt? =item * Fix option handling for commands called as C> =item * Refactor handling of fallback to STDIN? =item * More commands falling back to STDIN =item * More shellutils starting with B =item * More *utils packages =back =head1 AUTHOR Written by Geoffrey Broadwell . =head1 COPYRIGHT Copyright (C) 2003-2004, Geoffrey Broadwell. All rights reserved. This program is licensed under the same terms as Perl itself. At the time of this writing, that means either the Artistic License or the GNU General Public License (GPL); copies of both are available in the Perl source kit. =cut