Paranoid-0.36/0000755000175000001440000000000012030165460012732 5ustar acorlissusersParanoid-0.36/lib/0000755000175000001440000000000012030165457013506 5ustar acorlissusersParanoid-0.36/lib/Paranoid/0000755000175000001440000000000012030165460015235 5ustar acorlissusersParanoid-0.36/lib/Paranoid/Data.pm0000644000175000001440000001344311361717760016465 0ustar acorlissusers# Paranoid::Data -- Misc. Data Manipulation Functions # # (c) 2007, Arthur Corliss # # $Id: Data.pm,v 0.02 2010/04/15 23:23:28 acorliss Exp $ # # This software is licensed under the same terms as Perl, itself. # Please see http://dev.perl.org/licenses/ for more information. # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::Data; use 5.006; use strict; use warnings; use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); use base qw(Exporter); use Paranoid::Debug qw(:all); use Carp; ($VERSION) = ( q$Revision: 0.02 $ =~ /(\d+(?:\.(\d+))+)/sm ); @EXPORT = qw(deepCopy); @EXPORT_OK = qw(deepCopy); %EXPORT_TAGS = ( all => [qw(deepCopy)], ); ##################################################################### # # Module code follows # ##################################################################### sub deepCopy ($$) { # Purpose: Attempts to safely copy an arbitrarily deep data # structure from the source to the target # Returns: True or False # Usage: $rv = deepCopy($sourceRef, $targetRef); my $source = shift; my $target = shift; my $rv = 1; my $counter = 0; my $sref = defined $source ? ref $source : 'undef'; my $tref = defined $target ? ref $target : 'undef'; my ( @refs, $recurseSub ); croak 'Mandatory first argument must be a scalar, array, or hash ' . 'reference' unless defined $source and ( $sref eq 'SCALAR' or $sref eq 'ARRAY' or $sref eq 'HASH' ); croak 'Mandatory second argument must be a scalar, array, or hash ' . 'reference' unless defined $target and ( $tref eq 'SCALAR' or $tref eq 'ARRAY' or $tref eq 'HASH' ); croak 'First and second arguments must be identical types of ' . 'references' unless $sref eq $tref; pdebug( "entering w/($sref)($tref)", PDLEVEL1 ); pIn(); $recurseSub = sub { my $s = shift; my $t = shift; my $type = ref $s; my $irv = 1; my ( $key, $value ); # We'll grep the @refs list to make sure there's no # circular references going on if ( grep { $_ eq $s } @refs ) { Paranoid::ERROR = pdebug( 'Found a circular reference in data structure: ' . "@refs ($s)", PDLEVEL1 ); return 0; } # Push the reference onto the list push @refs, $s; # Copy data over if ( $type eq 'ARRAY' ) { # Copy over array elements foreach my $element (@$s) { $type = ref $element; $counter++; if ( $type eq 'ARRAY' or $type eq 'HASH' ) { # Copy over sub arrays or hashes push @$t, $type eq 'ARRAY' ? [] : {}; return 0 unless &$recurseSub( $element, $$t[-1] ); } else { # Copy over everything else as-is push @$t, $element; } } } elsif ( $type eq 'HASH' ) { while ( ( $key, $value ) = each %$s ) { $type = ref $value; $counter++; if ( $type eq 'ARRAY' or $type eq 'HASH' ) { # Copy over sub arrays or hashes $$t{$key} = $type eq 'ARRAY' ? [] : {}; return 0 unless &$recurseSub( $value, $$t{$key} ); } else { # Copy over everything else as-is $$t{$key} = $value; } } } # We're done, so let's remove the reference we were working on pop @refs; return 1; }; # Start the copy if ( $sref eq 'ARRAY' or $sref eq 'HASH' ) { # Copy over arrays & hashes if ( $sref eq 'ARRAY' ) { @$target = (); } else { %$target = (); } $rv = &$recurseSub( $source, $target ); } else { # Copy over everything else directly $$target = $$source; $counter++; } $rv = $counter if $rv; pOut(); pdebug( "leaving w/rv: $rv", PDLEVEL1 ); return $rv; } 1; __END__ =head1 NAME Paranoid::Data - Misc. Data Manipulation Functions =head1 VERSION $Id: Data.pm,v 0.02 2010/04/15 23:23:28 acorliss Exp $ =head1 SYNOPSIS $rv = deepCopy($sourceRef, $targetRef); =head1 DESCRIPTION This module provides data manipulation functions, which at this time only consists of B. =head1 SUBROUTINES/METHODS =head2 deepCopy $rv = deepCopy($sourceRef, $targetRef); This function performs a deep and safe copy of arbitrary data structures, checking for circular references along the way. Hashes and lists are safely duplicated while all other data types are just copied. This means that any embedded object references, etc., are identical in both the source and the target, which is probably not what you want. In short, this should only be used on pure hash/list/scalar value data structures. Both the source and the target reference must be of an identical type. This function returns the number of elements copied unless it runs into a problem (such as a circular reference), in which case it returns a zero. =head1 DEPENDENCIES =over =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is licensed under the same terms as Perl, itself. Please see http://dev.perl.org/licenses/ for more information. (c) 2009, Arthur Corliss (corliss@digitalmages.com) Paranoid-0.36/lib/Paranoid/Log/0000755000175000001440000000000012030165460015756 5ustar acorlissusersParanoid-0.36/lib/Paranoid/Log/Email.pm0000644000175000001440000001603111361717760017360 0ustar acorlissusers# Paranoid::Log::Email -- Log Facility Email for paranoid programs # # (c) 2005, Arthur Corliss # # $Id: Email.pm,v 0.82 2010/04/15 23:23:28 acorliss Exp $ # # This software is licensed under the same terms as Perl, itself. # Please see http://dev.perl.org/licenses/ for more information. # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::Log::Email; use strict; use warnings; use vars qw($VERSION); use Paranoid::Debug qw(:all); use Carp; use Net::SMTP; use Net::Domain qw(hostfqdn); ($VERSION) = ( q$Revision: 0.82 $ =~ /(\d+(?:\.(\d+))+)/sm ); ##################################################################### # # Module code follows # ##################################################################### sub init () { # Purpose: Exists purely for compliance. # Returns: True (1) # Usage: init(); return 1; } sub remove ($) { # Purpose: Exists purely for compliance. # Returns: True (1) # Usage: init(); return 1; } sub log ($$$$$$$$$;$$) { # Purpose: Mails the passed message to the named recipient # Returns: True (1) if successful, False (0) if not # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope); # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope, $mailhost); # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope, $mailhost, $recipient); # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope, $mailhost, $recipient, $sender); # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope, $mailhost, $recipient, $sender, $subject); my $msgtime = shift; my $severity = shift; my $message = shift; my $name = shift; my $facility = shift; my $level = shift; my $scope = shift; my $mailhost = shift; my $recipient = shift; my $sender = shift; my $subject = shift; my $m = defined $mailhost ? $mailhost : 'undef'; my $r = defined $recipient ? $recipient : 'undef'; my $s1 = defined $sender ? $sender : 'undef'; my $s2 = defined $subject ? $subject : 'undef'; my $rv = 0; my ( $smtp, $hostname, $data ); # Validate arguments croak 'Mandatory third argument must be a valid message' unless defined $message; pdebug( "entering w/($msgtime)($severity)($message)($name)" . "($facility)($level)($scope)($m)($r)($s1)($s2)", PDLEVEL1 ); pIn(); # We need a mailhost and recipient at a minimum if ( defined $mailhost && defined $recipient ) { # Get the system hostname $hostname = hostfqdn(); # Make sure something is set for the sender $sender = "$ENV{USER}\@$hostname" unless defined $sender; # Make sure something is set for the subject $subject = "ALERT from $ENV{USER}\@$hostname" unless defined $subject; # Compose the data block $data = << "__EOF__"; To: @{[ ref($recipient) eq 'ARRAY' ? join(', ', @$recipient) : $recipient ]} From: $sender Subject: $subject This alert was sent out from $hostname by $ENV{USER} because of a log event which met or exceeded the $level level. The message of this event is as follows: $message __EOF__ pdebug( "sending to $recipient to $mailhost", PDLEVEL2 ); # Try to open an SMTP connection if ( $smtp = Net::SMTP->new( $mailhost, Timeout => 30 ) ) { # Start the transaction if ( $smtp->mail($sender) ) { # Send to all recipients if ( ref $recipient eq 'ARRAY' ) { foreach (@$recipient) { Paranoid::ERROR = pdebug( "server rejected recipient: $_", PDLEVEL1 ) unless $smtp->to($_); } } else { Paranoid::ERROR = pdebug( "server rejected recipient: $recipient", PDLEVEL1 ) unless $smtp->to($recipient); } # Send the message $rv = $smtp->data($data); # Log the error } else { Paranoid::ERROR = pdebug( "server rejected sender: $sender", PDLEVEL1 ); $rv = 0; } # Close the connection $smtp->quit; } else { # Failed to connect to the server! Paranoid::ERROR = pdebug( "couldn't connect to server: $mailhost", PDLEVEL1 ); $rv = 0; } } else { # Who the hell activated this facility without at least that?! Paranoid::ERROR = pdebug( 'Message logged with e-mail facility, but we have ' . 'neither a mailhost or a recipient to send to -- ignoring', PDLEVEL1 ); $rv = 0; } pOut(); pdebug( "leaving w/rv: $rv", PDLEVEL1 ); return $rv; } sub dump ($) { # Purpose: Exists purely for compliance. # Returns: True (1) # Usage: init(); return (); } 1; __END__ =head1 NAME Paranoid::Log::Email - Log Facility Email =head1 VERSION $Id: Email.pm,v 0.82 2010/04/15 23:23:28 acorliss Exp $ =head1 SYNOPSIS use Paranoid::Log; enableFacility('crit-alert', 'email', 'debug', '+', $mailhost, $recipient); enableFacility('crit-alert', 'email', 'debug', '+', $mailhost, [ @recipients ]); enableFacility('crit-alert', 'email', 'debug', '+', $mailhost, $recipient, $sender, $subject); =head1 DESCRIPTION This module implements an e-mail transport for messages sent to the logger. It supports one or more recipients as well as overriding the sender address and subject line. It also supports connecting to a remote mail server. =head1 DEPENDENCIES =over =item o L =item o L =item o L =back =head1 SUBROUTINES/METHODS B: Given that this module is not intended to be used directly nothing is exported. =head2 init =head2 log =head2 remove =head2 dump =head1 SEE ALSO =over =item o L =back =head1 BUGS AND LIMITATIONS No validation of any information, be it the mail server, recipient, or anything else is done until a message actually needs to be sent. Because of this you may have no warning of any misconfigurations just by enabling the facility. =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is licensed under the same terms as Perl, itself. Please see http://dev.perl.org/licenses/ for more information. (c) 2005, Arthur Corliss (corliss@digitalmages.com) Paranoid-0.36/lib/Paranoid/Log/File.pm0000644000175000001440000001565111361717760017217 0ustar acorlissusers# Paranoid::Log::File -- File Log support for paranoid programs # # (c) 2005, Arthur Corliss # # $Id: File.pm,v 0.83 2010/04/15 23:23:28 acorliss Exp $ # # This software is licensed under the same terms as Perl, itself. # Please see http://dev.perl.org/licenses/ for more information. # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::Log::File; use 5.006; use strict; use warnings; use vars qw($VERSION); use Paranoid::Debug qw(:all); use Paranoid::Filesystem; use Paranoid::Input; use Carp; use Fcntl qw(:flock :seek O_WRONLY O_CREAT O_APPEND); ($VERSION) = ( q$Revision: 0.83 $ =~ /(\d+(?:\.(\d+))+)/sm ); ##################################################################### # # Module code follows # ##################################################################### { my %fhandles; my %fpids; sub _delHandle { # Purpose: closes any opened filehandles and cleans up the internal # data structures # Returns: Result of close(), or True (1) if no such file opened # Usage: $rv = _delHandle($filename); my $filename = shift; my $rv = 1; if ( exists $fhandles{$filename} && $fpids{$filename} == $$ ) { $rv = close $fhandles{$filename}; delete $fhandles{$filename}; delete $fpids{$filename}; } return $rv; } sub _getHandle { # Purpose: Retrieves a filehandle to the requested file. It will # automatically create the file if necessary. It also # tracks what process opened the filehandle so a new one is # opened after a fork call. # Returns: Filehandle # Usage: $fh = _getHandle($filename); my $filename = shift; my ( $f, $fd, $rv ); # Is there a filehandle cached? if ( exists $fhandles{$filename} ) { # Yes, so was it opened by us? if ( $fpids{$filename} == $$ ) { # Yup, return the filehandle $rv = $fhandles{$filename}; } else { # Nope, let's delete it and reopen it delete $fhandles{$filename}; $rv = _getHandle($filename); } } else { # Nope, let's open it up if we can detaint the filename if ( detaint( $filename, 'filename', \$f ) ) { # Try to open the file if ( sysopen $fd, $f, O_WRONLY | O_APPEND | O_CREAT ) { # Done, now cache and return the filehandle $fhandles{$f} = $fd; $fpids{$f} = $$; $rv = $fd; } else { # Failed to do so, log the error Paranoid::ERROR = pdebug( "failed to open the file ($filename): $!", PDLEVEL1 ); $rv = undef; } } else { Paranoid::ERROR = pdebug( "failed to detaint filename: $filename", PDLEVEL1 ); } } return $rv; } sub init () { # Purpose: Closes all opened filehandles by this process # Returns: True (1) # Usage: init(); foreach ( keys %fhandles ) { _delHandle($_) } return 1; } } sub remove ($) { # Purpose: Closes the requested file # Returns: Return value of _delHandle(); # Usage: $rv = remove($filename); my $filename = shift; return _delHandle($filename); } sub log ($$$$$$$$) { # Purpose: Logs the passed message to the named file # Returns: Return value of print() # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope, $filename); my $msgtime = shift; my $severity = shift; my $message = shift; my $name = shift; my $facility = shift; my $level = shift; my $scope = shift; my $filename = shift; my $rv = 0; my $fh; # Validate arguments croak 'Mandatory third argument must be a valid message' unless defined $message; croak 'Mandatory eighth argument must be a valid filename' unless defined $filename; pdebug( "entering w/($msgtime)($severity)($message)($name)" . "($facility)($level)($scope)($filename)", PDLEVEL1 ); pIn(); # Message time defaults to current time $msgtime = time unless defined $msgtime; # Get the filehandle if ( defined( $fh = _getHandle($filename) ) ) { # Lock the filehandle flock $fh, LOCK_EX; # Move to the end of the file and print the message seek $fh, 0, SEEK_CUR; seek $fh, 0, SEEK_END; $rv = print $fh "$message\n"; Paranoid::ERROR = pdebug( "failed to write to $filename: $!", PDLEVEL1 ) unless $rv; # Unlock & close the file flock $fh, LOCK_UN; } pOut(); pdebug( "leaving w/rv: $rv", PDLEVEL1 ); return $rv; } sub dump ($) { # Purpose: Exists purely for compliance. # Returns: True (1) # Usage: init(); return (); } 1; __END__ =head1 NAME Paranoid::Log::File - File Logging Functions =head1 VERSION $Id: File.pm,v 0.83 2010/04/15 23:23:28 acorliss Exp $ =head1 SYNOPSIS use Paranoid::Log; enableFacility('events', 'file', 'debug', '+', $filename); =head1 DESCRIPTION This module logs messages to the log files, and is safe for use with forked children logging to the same files. Each child will open their own filehandles and use advisory locking for writes. This module should not be used directly, B should be your exclusive interface for logging. =head1 SUBROUTINES/METHODS B: Given that this module is not intended to be used directly nothing is exported. =head2 init =head2 log =head2 remove =head2 dump =head1 DEPENDENCIES =over =item o L =item o L =item o L =item o L =back =head1 SEE ALSO =over =item o L =back =head1 BUGS AND LIMITATIONS This isn't a high performance module when dealing with a high logging rate with high concurrency. This is due to the advisory locking requirement and the seeks to the end of the file with every message. This facility is intended as a kind of lowest-common demoninator for programs that need some kind of logging capability. =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is licensed under the same terms as Perl, itself. Please see http://dev.perl.org/licenses/ for more information. (c) 2005, Arthur Corliss (corliss@digitalmages.com) Paranoid-0.36/lib/Paranoid/Log/Syslog.pm0000644000175000001440000001721211401776247017613 0ustar acorlissusers# Paranoid::Log::Syslog -- Log Facility Syslog for paranoid programs # # (c) 2005, Arthur Corliss # # $Id: Syslog.pm,v 0.83 2010/06/03 19:04:07 acorliss Exp $ # # This software is licensed under the same terms as Perl, itself. # Please see http://dev.perl.org/licenses/ for more information. # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::Log::Syslog; use 5.006; use strict; use warnings; use vars qw($VERSION); use Paranoid::Debug qw(:all); use Unix::Syslog qw(:macros :subs); use Carp; ($VERSION) = ( q$Revision: 0.83 $ =~ /(\d+(?:\.(\d+))+)/sm ); ##################################################################### # # Module code follows # ##################################################################### sub _setIdent (;$) { # Purpose: Returns a name for use as the ident field. If you don't want # the process command as that you can pass an optional name to # use instead. # Returns: String # Usage: $ident = _setIdent(); # Usage: $ident = _setIdent($name); my $name = shift; # Use $0 by default $name = $0 unless defined $name; # Strip path $name =~ s#^.*/##sm; return $name; } sub init (;@) { # Purpose: Exists purely for compliance. # Returns: True (1) # Usage: init(); return 1; } sub _transFacility ($) { # Purpose: Translates the string log facilities into the syslog constants # Returns: Constant scalar value # Usage: $facility = _transFacility($facilityName); my $f = lc shift; my %trans = ( authpriv => LOG_AUTHPRIV, auth => LOG_AUTHPRIV, cron => LOG_CRON, daemon => LOG_DAEMON, ftp => LOG_FTP, kern => LOG_KERN, local0 => LOG_LOCAL0, local1 => LOG_LOCAL1, local2 => LOG_LOCAL2, local3 => LOG_LOCAL3, local4 => LOG_LOCAL4, local5 => LOG_LOCAL5, local6 => LOG_LOCAL6, local7 => LOG_LOCAL7, lpr => LOG_LPR, mail => LOG_MAIL, news => LOG_NEWS, syslog => LOG_SYSLOG, user => LOG_USER, uucp => LOG_UUCP, ); return exists $trans{$f} ? $trans{$f} : undef; } sub _transLevel ($) { # Purpose: Translates the passed log level string into the syslog # constant # Returns: Constant scalar value # Usage: $level = _transLevel($levelName); my $l = lc shift; my %trans = ( 'debug' => LOG_DEBUG, 'info' => LOG_INFO, 'notice' => LOG_NOTICE, 'warn' => LOG_WARNING, 'warning' => LOG_WARNING, 'err' => LOG_ERR, 'error' => LOG_ERR, 'crit' => LOG_CRIT, 'critical' => LOG_CRIT, 'alert' => LOG_ALERT, 'emerg' => LOG_EMERG, 'emergency' => LOG_EMERG, 'panic' => LOG_EMERG, ); return exists $trans{$l} ? $trans{$l} : undef; } { my $sysopened = 0; sub _openSyslog (;$$) { # Purpose: If the syslogger hasn't been opened yet it opens it, # otherwise exits cleanly. # Returns: True (1) if successful, # False (0) if there are any errors # Usage: $rv = _openSyslog(); # Usage: $rv = _openSyslog($ident); # Usage: $rv = _openSyslog($ident, $facility); my $ident = shift; my $facility = shift; my $i = defined $ident ? $ident : 'undef'; my $f = defined $facility ? $facility : 'undef'; pdebug( "entering w/($i)($f)", PDLEVEL2 ); pIn(); # Open a handle to the syslog daemon unless ($sysopened) { # Make sure both values are set $ident = _setIdent($ident); $facility = 'user' unless defined $facility; # Validate the facility croak 'Can\'t open handle to syslogger with an invalid facility: ' . "$facility\n" unless defined( $facility = _transFacility($facility) ); # Open the logger openlog $ident, LOG_CONS | LOG_NDELAY | LOG_PID, $facility; $sysopened = 1; # TODO: trap return value of openlog? } pOut(); pdebug( "leaving w/rv: $sysopened", PDLEVEL2 ); return $sysopened; } sub remove (;$) { # Purpose: Closes the syslogger # Returns: True (1) # Usage: remove(); pdebug( 'entering', PDLEVEL2 ); closelog(); $sysopened = 0; pdebug( 'leaving w/rv: 1', PDLEVEL2 ); return 1; } } sub log ($$$$$$$) { # Purpose: Logs the passed message to the named file # Returns: Return value of print() # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope); # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope, $progName); my $msgtime = shift; my $severity = shift; my $message = shift; my $name = shift; my $facility = shift; my $level = shift; my $scope = shift; my $rv = 0; # Set defaults on optional args $name = 'user' unless defined $name; $severity = 'notice' unless defined $severity; # Validate arguments croak 'Mandatory second argument must be a valid severity' unless defined _transLevel($severity); croak 'Mandatory third argument must be a valid message' unless defined $message; croak 'Mandatory fourth argument must be a valid syslog facility' unless defined _transFacility($name); pdebug( "entering w/($msgtime)($severity)($message)($name)" . "($facility)($level)($scope)", PDLEVEL1 ); pIn(); # TODO: Make sure prog name works? # Make sure the logger is ready and log the message if ( _openSyslog( undef, $name ) ) { syslog _transLevel($severity), '%s', $message; $rv = 1; } pOut(); pdebug( "leaving w/rv: $rv", PDLEVEL1 ); return $rv; } sub dump() { # Purpose: Exists purely for compliance. # Returns: True (1) # Usage: init(); return (); } 1; __END__ =head1 NAME Paranoid::Log::Syslog - Log Facility Syslog =head1 VERSION $Id: Syslog.pm,v 0.83 2010/06/03 19:04:07 acorliss Exp $ =head1 SYNOPSIS use Paranoid::Log; enableFacility('local3', 'syslog', 'debug', '+'); enableFacility('local3', 'syslog', 'debug', '+', 'my-daemon'); =head1 DESCRIPTION This module implements UNIX syslog support for logging purposes. Which should seem natural given that the entire B API is modeled closely after it. =head1 SUBROUTINES/METHODS B: Given that this module is not intended to be used directly nothing is exported. =head2 init =head2 log =head2 remove =head2 dump =head1 DEPENDENCIES =over =item o L =item o L =back =head1 BUGS AND LIMITATIONS Because we're keeping a connection to the syslogger open we don't support enabling multiple facilities that log as different idents, etc. The first syslog facility that gets activated will set those parameters. =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is licensed under the same terms as Perl, itself. Please see http://dev.perl.org/licenses/ for more information. (c) 2005, Arthur Corliss (corliss@digitalmages.com) Paranoid-0.36/lib/Paranoid/Log/Buffer.pm0000644000175000001440000001350611401776222017537 0ustar acorlissusers# Paranoid::Log::Buffer -- Log buffer support for paranoid programs # # (c) 2005, Arthur Corliss # # $Id: Buffer.pm,v 0.83 2010/06/03 19:03:46 acorliss Exp $ # # This software is licensed under the same terms as Perl, itself. # Please see http://dev.perl.org/licenses/ for more information. # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::Log::Buffer; use 5.006; use strict; use warnings; use vars qw($VERSION); use Paranoid::Debug qw(:all); use Carp; ($VERSION) = ( q$Revision: 0.83 $ =~ /(\d+(?:\.(\d+))+)/sm ); ##################################################################### # # Module code follows # ##################################################################### { # Buffers my %buffers = (); sub _getBuffer ($) { # Purpose: Retrieves the named buffer (which is an array ref). # Creates the array on the fly if it doesn't exist. # Returns: Array ref # False (0) if there are any errors # Usage: $ref = _getBuffer($name); my $name = shift; $buffers{$name} = [] unless exists $buffers{$name}; return $buffers{$name}; } sub _delBuffer ($) { # Purpose: Deletes the named buffer from the hash. # Returns: True (1) # Usage: _delBuffer($name); my $name = shift; delete $buffers{$name} if exists $buffers{$name}; return 1; } sub init () { # Purpose: Empties the named buffer hash # Returns: True (1) # Usage: init(); %buffers = (); return 1; } } sub remove ($) { # Purpose: Removes the requested buffer # Returns: Return value of _delBuffer() # Usage: $rv = remove($name); my $name = shift; return _delBuffer($name); } sub log ($$$$$$$$) { # Purpose: Logs the passed message to the named buffer, trimming excess # messages as needed # Returns: True (1) # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope); # Usage: log($msgtime, $severity, $message, $name, $facility, $level, # $scope, $buffSize); my $msgtime = shift; my $severity = shift; my $message = shift; my $name = shift; my $facility = shift; my $level = shift; my $scope = shift; my $buffSize = shift; my $barg = defined $buffSize ? $buffSize : 'undef'; my $buffer = _getBuffer($name); # Validate arguments croak 'Mandatory third argument must be a valid message' unless defined $message; croak 'Mandatory fourth argument must be a defined buffer name' unless defined $name; pdebug( "entering w/($msgtime)($severity)($message)($name)($facility)" . "($level)($scope)($barg)", PDLEVEL1 ); pIn(); # Buffer size defaults to twenty entries $buffSize = 20 unless defined $buffSize and $buffSize > 0; # Message time defaults to current time $msgtime = time unless defined $msgtime; # Trim the buffer if needed splice( @$buffer, 0, $buffSize - 1 ) if scalar @$buffer > $buffSize; # Add the message push @$buffer, [ $msgtime, $message ]; pOut(); pdebug( 'leaving w/rv: 1', PDLEVEL1 ); return 1; } sub dump ($) { # Purpose: Returns the contents of the named buffer # Returns: Array # Usage: @events = dump($name); my $name = shift; my $buffer = _getBuffer($name); return @$buffer; } 1; __END__ =head1 NAME Paranoid::Log::Buffer - Log Buffer Functions =head1 VERSION $Id: Buffer.pm,v 0.83 2010/06/03 19:03:46 acorliss Exp $ =head1 SYNOPSIS use Paranoid::Log; enableFacility('events', 'buffer', 'debug', '+'); enableFacility('more-events', 'buffer', 'debug', '+', 100); @messages = Paranoid::Log::Buffer::dump($name); =head1 DESCRIPTION This module implements named buffers to be used for logging purposes. Each buffer is of a concrete size (definable by the developer) with a max message length of 2KB. Each message is stored with a timestamp. Once the buffer hits the maximun number of entries it begins deleting the oldest messages as the new messages come in. Buffers are created automatically on the fly, and messages trimmed before being stored. With the exception of the B function this module is not meant to be used directly. B should be your exclusive interface for logging. When enabling a buffer facility with B you can add one integral argument to the call. That number defines the size of the log buffer in terms of number of entries allowed. B Buffers are maintained within process memory. If you fork a process from a parent with a log buffer each copy will maintain its own entries. =head1 SUBROUTINES/METHODS B: Given that this module is not intended to be used directly nothing is exported. =head2 init =head2 log =head2 remove =head2 Paranoid::Log::Buffer::dump @entries = Paranoid::Log::Buffer::dump($name); This dumps all current entries in the named buffer. Each entry is an array reference to a two-element array. The first element is the timestamp of the message (in UNIX epoch seconds), the second the actual message itself. =head1 DEPENDENCIES =over =item o Paranoid::Debug =back =head1 SEE ALSO =over =item o L =back =head1 BUGS AND LIMITATIONS =head1 AUTHOR Arthur Corliss (corliss@digitalmages.com) =head1 LICENSE AND COPYRIGHT This software is licensed under the same terms as Perl, itself. Please see http://dev.perl.org/licenses/ for more information. (c) 2005, Arthur Corliss (corliss@digitalmages.com) Paranoid-0.36/lib/Paranoid/Args.pm0000644000175000001440000012077012030161000016460 0ustar acorlissusers# Paranoid::Args -- Command-line argument parsing functions # # (c) 2005, Arthur Corliss # # $Id: Args.pm,v 0.23 2012/09/24 22:43:12 acorliss Exp $ # # This software is licensed under the same terms as Perl, itself. # Please see http://dev.perl.org/licenses/ for more information. # ##################################################################### ##################################################################### # # Environment definitions # ##################################################################### package Paranoid::Args; use 5.006; use strict; use warnings; use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); use base qw(Exporter); use Carp; use Paranoid; use Paranoid::Debug qw(:all); ($VERSION) = ( q$Revision: 0.23 $ =~ /(\d+(?:\.(\d+))+)/sm ); @EXPORT = qw(parseArgs); @EXPORT_OK = qw(parseArgs); %EXPORT_TAGS = ( all => [qw(parseArgs)], ); ##################################################################### # # Module code follows # ##################################################################### { # Internal boolean flag for noOptions my $noOptions = 0; sub _NOOPTIONS : lvalue { # Purpose: Gets/sets value of boolean flag $noOptions # Returns: Value of $noOptions # Usage: $flag = _NOOPTIONS; # Usage: _NOOPTIONS = 1; $noOptions; } # Internal errors array my @errors; sub _resetErrors () { # Purpose: Empties @errors # Returns: True (1) # Usage: resetErrors(); @errors = (); return 1; } sub _pushErrors ($) { # Purpose: Pushes a new string onto the @errors array # Returns: Same argument as called with # Usage: _pushErrors($message); my $message = shift; push @errors, $message; return $message; } sub listErrors () { # Purpose: Gets the contents of @errors # Returns: Contents of @errors # Usage: @errors = listErrors(); return @errors; } # Internal options hash my %options; sub _getOption ($) { # Purpose: Gets the template associated with passed option # Returns: Reference to template hash or undef should the # requested option not be defined # Usage: $tref = _getOption($option); my $option = shift; return exists $options{$option} ? $options{$option} : undef; } sub _setOption ($$) { # Purpose: Associates the passed option to the passed template in # %options # Returns: True (1) # Usage: _setOption($option, $tref); my $option = shift; my $tref = shift; $options{$option} = $tref; return 1; } sub _optionsKeys () { # Purpose: Returns a list of keys from %options # Returns: keys %options # Usage: @keys = _optionsKeys(); return keys %options; } sub _resetOptions () { # Purpose: Empties the %options # Returns: True (1) # Usage: _resetOptions(); %options = (); return 1; } # Internal arguments list my @arguments; sub _getArgRef () { # Purpose: Gets a reference the argument array # Returns: Array reference # Usage: $argRef = _getArgRef(); return \@arguments; } sub clearMemory () { # Purpose: Empties all internal data structures # Returns: True (1) # Usage: clearMemory(); _NOOPTIONS = 0; _resetErrors(); _resetOptions(); @{ _getArgRef() } = (); return 1; } } sub _tLint ($) { # Purpose: Performs basic checks on a given option template for # correctness # Returns: True (1) if all checks pass, False (0) otherwise # Usage: $rv = _tLint($templateRef); my $tref = shift; # Reference to option template hash my $rv = 1; my ( $oname, @at ); pdebug( "entering w/($tref)", PDLEVEL2 ); pIn(); # Get the option name for reporting purposes (should have been populated # within parseArgs below) $oname = $$tref{Name}; # Make sure a short or long option is declared if ( $oname eq 'undef/undef' ) { _pushErrors('No short or long option name declared'); $rv = 0; } # Make sure the argument template is defined if ($rv) { unless ( defined $$tref{Template} ) { _pushErrors("$oname option declared without a template"); $rv = 0; } } # Make sure the template contains only supported characters if ($rv) { unless ( defined $$tref{Template} && $$tref{Template} =~ /^[\$\@]*$/sm ) { _pushErrors( "$oname option declared with an invalid template" . "($$tref{Template})" ); $rv = 0; } } # Make sure option names are sane if ($rv) { if ( defined $$tref{Short} ) { unless ( $$tref{Short} =~ /^[a-zA-Z0-9]$/sm ) { _pushErrors( "Invalid name for the short option ($$tref{Short})"); $rv = 0; } } if ( defined $$tref{Long} ) { unless ( $$tref{Long} =~ /^[a-zA-Z0-9-]{2,}$/sm ) { _pushErrors( "Invalid name for the long option ($$tref{Long})"); $rv = 0; } } } # Make sure '@' is only used once, if at all, and the option isn't # set to allow bundling if ($rv) { if ( $$tref{Template} =~ /\@/sm ) { @at = ( $$tref{Template} =~ m#(\@)#smg ); if ( @at > 1 ) { _pushErrors( 'The \'@\' symbol can only be used once in the ' . "template for $oname: $_" ); $rv = 0; } if ( $$tref{CanBundle} and defined $$tref{Short} ) { _pushErrors( "Option $$tref{Short} must have CanBundle set to false " . 'if the template contains \'@\'' ); $rv = 0; } } } # Make sure all values in our lists are defined if ($rv) { unless ( ref( $$tref{ExclusiveOf} ) eq 'ARRAY' ) { _pushErrors( "Option ${oname}'s parameter ExclusiveOf must be an " . 'array reference' ); $rv = 0; } unless ( ref( $$tref{AccompaniedBy} ) eq 'ARRAY' ) { _pushErrors( "Option ${oname}'s parameter AccompaniedBy must be an " . 'array reference' ); $rv = 0; } if ($rv) { if ( grep { !defined } @{ $$tref{ExclusiveOf} } ) { _pushErrors( "Option $oname has undefined values in ExclusiveOf"); $rv = 0; } if ( grep { !defined } @{ $$tref{AccompaniedBy} } ) { _pushErrors( "Option $oname has undefined values in ExclusiveOf"); $rv = 0; } } } # Make sure CountShort is enabled only for those with a template of '' # or '$' if ($rv) { if ( $$tref{CountShort} ) { unless ( $$tref{Template} =~ /^\$?$/sm ) { _pushErrors( "Option $oname has CountShort set but with an " . 'incompatible template' ); $rv = 0; } } } pOut(); pdebug( "leaving w/rv: $rv", PDLEVEL2 ); return $rv; } sub _getArgs ($$$) { # Purpose: Takes passed argument template and extracts the requisite # arguments to satisfy it from the argument list. The # results are stored in the passed option list. # Results: True (1) if successful, False (0) if not # Usage: $rv = _getArgs($option, $argTemplate, \@optionArgs); my $option = shift; # Option name my $argTemplate = shift; # Option argument template my $lref = shift; # Array reference for retrieved arguments my $rv = 1; my $argRef = _getArgRef(); my @tmp; pdebug( "entering w/($option)($argTemplate)($lref)", PDLEVEL2 ); pIn(); # Empty the array @$lref = (); pdebug( "contents of args: @$argRef", PDLEVEL4 ); # Start checking the contents of $argTemplate if ( $argTemplate eq '' ) { # Template is '' (boolean option) @$lref = (1); } elsif ( $argTemplate =~ /\@/sm ) { # Template has a '@' in it -- we'll need to # grab as many of the next arguments as possible. # Check the noOptions flags if (_NOOPTIONS) { # True: gobble up everything left push @$lref, @$argRef; @$argRef = (); } else { # False: gobble up to the next option-looking thing while ( @$argRef and $$argRef[0] !~ /^--?(?:\w+.*)?$/sm ) { push @$lref, shift @$argRef; } # Now, we check to see if the first remaining argument is '--'. # If it is then we must set noOptions to true and gobble the # rest. if ( @$argRef and $$argRef[0] eq '--' ) { _NOOPTIONS = 1; shift @$argRef; push @$lref, @$argRef; @$argRef = (); } } } else { # The template is not empty and has no '@', so we'll just grab the next # n arguments, n being the length of the template # Check the noOptions flag if (_NOOPTIONS) { # True: grab everything we need while ( @$argRef and @$lref < length $argTemplate ) { push @$lref, shift @$argRef; } } else { # False: grab as many non-option-looking things as we can while ( @$argRef and $$argRef[0] !~ /^--?(?:\w+.*)$/sm and @$lref < length $argTemplate ) { push @$lref, shift @$argRef; } # Now, we check to see if we still need more arguments and if # the first remaining argument is '--'. If it is then we must # set noOptions to true and gobble what we need. if ( @$lref < length $argTemplate and @$argRef and $$argRef[0] eq '--' ) { _NOOPTIONS = 1; shift @$argRef; while ( @$argRef and @$lref < length $argTemplate ) { push @$lref, shift @$argRef; } } } } # Final check: did we get minimum requisite number of arguments? if ( @$lref < length $argTemplate ) { pdebug( _pushErrors( "Missing the minimum number of arguments for $option"), PDLEVEL1 ); $rv = 0; } else { pdebug( "extracted the following arguments: @$lref", PDLEVEL3 ); } # sublist '@' portions of multicharacter templates if ( $rv and $argTemplate =~ /\@/sm and length $argTemplate > 1 ) { @tmp = ( [], [], [] ); # First, shift off all preceding '$'s if ( $argTemplate =~ /^(\$+)/sm ) { @{ $tmp[0] } = splice @$lref, 0, length $1; } # Next, pop off all trailing '$' if ( $argTemplate =~ /(\$+)\$/sm ) { @{ $tmp[2] } = splice @$lref, -1 * length $1; } # Everything left belongs to the '@' @{ $tmp[1] } = @$lref; # Let's put it all together... @$lref = (); push @$lref, @{ $tmp[0] } if @{ $tmp[0] }; push @$lref, $tmp[1]; push @$lref, @{ $tmp[2] } if @{ $tmp[2] }; pdebug( "sublisted arguments into: @$lref", PDLEVEL3 ); } pOut(); pdebug( "leaving w/rv: $rv", PDLEVEL2 ); return $rv; } sub _storeArgs ($$$) { # Purpose: Stores the passed option arguments in the passed option # template's Value, but in accordance with parameters in the # template # Returns: True (1) # Usage: _storeArgs($optionTemplate, $argTemplate, \@optionArgs); my $tref = shift; my $argTemplate = shift; my $lref = shift; pdebug( "entering w/($tref)($argTemplate)($lref)", PDLEVEL2 ); pIn(); pdebug( "adding values to $$tref{Name}", PDLEVEL3 ); # Increment our usage counter $$tref{Count}++; # Store arguments according to the template if ( $argTemplate eq '' ) { # Template is '' $$tref{Value} = 0 unless defined $$tref{Value}; $$tref{Value}++; pdebug( "Value is now $$tref{Value}", PDLEVEL3 ); } elsif ( $argTemplate eq '$' ) { # Template is '$' if ( not $$tref{Multiple} or $$tref{CountShort} ) { # Store the value directly since we # can only be used once $$tref{Value} = $$lref[0]; pdebug( "Value is now $$tref{Value}", PDLEVEL3 ); } else { # Store the value as part of a list since # we can be used multiple times $$tref{Value} = [] unless defined $$tref{Value} and ref $$tref{Value} eq 'ARRAY'; push @{ $$tref{Value} }, $$lref[0]; pdebug( 'Value is now ' . join( ', ', @{ $$tref{Value} } ), PDLEVEL3 ); } } else { # Template is anything else if ( not $$tref{Multiple} ) { # Store the values directly in a an array # since we can only be used once $$tref{Value} = [@$lref]; pdebug( 'Value is now ' . join( ', ', @{ $$tref{Value} } ), PDLEVEL3 ); } else { # Store the values as an element of an # array since we can be used multiple times $$tref{Value} = [] unless defined $$tref{Value} and ref $$tref{Value} eq 'ARRAY'; push @{ $$tref{Value} }, [@$lref]; pdebug( "Value now has @{[ scalar @{ $$tref{Value} } ]} sets", PDLEVEL3 ); } } pOut(); pdebug( 'leaving w/rv: 1', PDLEVEL2 ); return 1; } sub parseArgs ($$;$) { # Purpose: Extracts and validates all command-line arguments and options, # storing them in an organized hash for easy retrieval # Returns: True (1) if successful, False (0) if not # Usage: $rv = parseArgs(\@templates, \%options); # Usage: $rv = parseArgs(\@templates, \%options, \@args); my $tlref = shift; # Templates list ref my $oref = shift; # Options hash ref my $paref = shift; # Program argument list ref my $rv = 1; my ( $aopt, $tref, $oname, $argRef, $arg, $argTemplate ); my ( @tmp, @oargs, $regex ); # Validate arguments croak 'Mandatory first argument must be a list reference' unless defined $tlref and ref $tlref eq 'ARRAY'; croak 'Mandatory second argument must be a hash reference' unless defined $oref and ref $oref eq 'HASH'; if ( defined $paref ) { croak 'Optional third argument must be a list reference' unless defined $paref and ref $paref eq 'ARRAY'; $aopt = $paref; } else { $paref = \@ARGV; $aopt = 'undef'; } pdebug( "entering w/($tlref)($oref)($aopt)", PDLEVEL1 ); pIn(); # Clear all internal data structures and reset flag clearMemory(); # Empty the passed options hash %$oref = (); # Make a copy of the argument list $argRef = _getArgRef(); @$argRef = (@$paref); # Assemble %options and lint-check the templates foreach (@$tlref) { # Make sure the element is a hash reference unless ( ref $_ eq 'HASH' ) { _pushErrors('Illegal non-hash reference in templates array'); $rv = 0; next; } # Establish a base template and copy the contents of the passed hash $tref = { Short => undef, Long => undef, Template => '', Multiple => 0, ExclusiveOf => [], AccompaniedBy => [], CanBundle => 0, CountShort => 0, Value => undef, %$_, }; # Create the short/long option for error-reporting purposes $oname = ( defined $$tref{Short} ? $$tref{Short} : 'undef' ) . '/' . ( defined $$tref{Long} ? $$tref{Long} : 'undef' ); $$tref{Name} = $oname; # Initialize our usage counter $$tref{Count} = 0; # We'll associate both the long and short options to the same hash # to make sure that we count/collect everything appropriately. # # Store the short option if ( defined $$tref{Short} and length $$tref{Short} ) { # See if a template is already defined if ( defined _getOption( $$tref{Short} ) ) { # It is -- report the error Paranoid::ERROR = pdebug( _pushErrors( "the $$tref{Short} option has more than one template" ), PDLEVEL1 ); $rv = 0; } else { # It's not -- go ahead and store it _setOption( $$tref{Short}, $tref ); } } # Store the long option if ( defined $$tref{Long} and length $$tref{Long} ) { # See if a template is already defined if ( defined _getOption( $$tref{Long} ) ) { # It is -- report the error Paranoid::ERROR = pdebug( _pushErrors( "the $$tref{Long} option has more than one template" ), PDLEVEL1 ); $rv = 0; } else { # It's not -- go ahead and store it _setOption( $$tref{Long}, $tref ); } } # Do a basic lint-check on the template $rv = 0 unless _tLint($tref); } if ($rv) { while (@$argRef) { $arg = shift @$argRef; next unless defined $arg; # Start testing $arg if ( $arg eq '--' and not _NOOPTIONS ) { # $arg is '--', so set the no options flag _NOOPTIONS = 1; } elsif ( not _NOOPTIONS and $arg =~ /^--?/sm ) { # '--' hasn't been passed yet and this looks # like an option... # Test types of options if ( $arg =~ /^-(\w.*)$/sm ) { # With a single '-' it should be a short option. However, # we'll split the option portion, in case there's more # than one character @tmp = split //sm, $1; # If there's more than one character for the option name # it must be either a bunch of bundled options or an # option with a concatenated argument. In case of the # latter (assuming that CanBundle is set to false (a # prerequisite of argument concatenation) and it has a # template of '$' (another prerequisite)) we'll unshift # the rest of the characters back onto the argument list. # # Oh, but first we'll need to get the applicable # option template and then start testing... $tref = _getOption( $tmp[0] ); if ( $#tmp and defined $tref and $$tref{Template} eq '$' and not $$tref{CanBundle} ) { unshift @$argRef, join '', @tmp[ 1 .. $#tmp ]; splice @tmp, 1, 1; } # Start processing all remaining short options in @tmp foreach (@tmp) { # Get the template $tref = _getOption($_); # Make sure the option is supported if ( defined $tref ) { # Make sure option allows bundling if bundled if ($#tmp) { unless ( $$tref{CanBundle} ) { _pushErrors( "Option $_ used bundled with " . 'other options' ); $rv = 0; next; } } # Get the argument template $argTemplate = $$tref{Template}; # Override the template if CountShort is true $argTemplate = '' if $argTemplate eq '$' and $$tref{CountShort}; # Get any accompanying arguments unless ( _getArgs( "-$_", $argTemplate, \@oargs ) ) { $rv = 0; next; } # Check if we've call this more than once if ( not $$tref{Multiple} and $$tref{Count} > 0 ) { _pushErrors( "Option -$_ is only allowed " . 'to be used once' ); $rv = 0; next; } # Store the values _storeArgs( $tref, $argTemplate, \@oargs ); } else { # Warn that this is an unknown option _pushErrors("Unknown short option used: $_"); $rv = 0; } } } elsif ( $arg =~ /^--([\w-]+)(?:=(.+))?$/sm ) { # Starts with '--', so must be a long option # Save the extracted option/argument portion @tmp = ($1); push @tmp, $2 if defined $2 and length $2; # If this option had an argument portion we need to # unshift it back onto the argument list *provided* it was # a legal argument, i.e., this option had a template of # '$'. $tref = _getOption( $tmp[0] ); if ( $#tmp and defined $tref ) { # Test for various templates if ( $$tref{Template} eq '$' ) { # Legal invocation -- unshift away unshift @$argRef, $tmp[1]; } elsif ( $$tref{Template} eq '' ) { # Illegal, no arguments expected _pushErrors( "--$tmp[0] does not require any " . 'arguments' ); $rv = 0; next; } else { # Illegal, can't use concatenated arguments in # more complex templates _pushErrors( "--$tmp[0] cannot be called like " . 'this when multiple arguments are ' . 'required.' ); } } # Handle known options if ( defined $tref ) { # Get the argument template $argTemplate = $$tref{Template}; # Snarf extra arguments unless ( _getArgs( "--$tmp[0]", $argTemplate, \@oargs ) ) { $rv = 0; next; } # Check if we've call this more than once if ( not $$tref{Multiple} and $$tref{Count} > 0 ) { _pushErrors( "Option --$_ is only allowed to be used once" ); $rv = 0; next; } # Store the values _storeArgs( $tref, $argTemplate, \@oargs ); } else { # Unknown long option _pushErrors("Unknown option: --$tmp[0]"); $rv = 0; } } else { # Unknown option-looking thingy _pushErrors("Unknown option thingy: $arg"); $rv = 0; } } else { # Everything else is payload $$oref{PAYLOAD} = [] unless exists $$oref{PAYLOAD}; push @{ $$oref{PAYLOAD} }, $arg; } } } # Make a list of all the arguments that was used @tmp = (); foreach ( _optionsKeys() ) { push @tmp, $_ if ${ _getOption($_) }{Count}; } # Final sanity check foreach ( sort @tmp ) { $tref = _getOption($_); # Make sure nothing was called that is exclusive of # other called options if ( @{ $$tref{ExclusiveOf} } ) { $regex = '(?:' . join( '|', @{ $$tref{ExclusiveOf} } ) . ')'; if ( grep /^$regex$/sm, @tmp ) { _pushErrors( "$_ cannot be called with the following options: " . join ', ', @{ $$tref{ExclusiveOf} } ); $rv = 0; } } # Make sure the option was called in conjunction with others foreach $regex ( @{ $$tref{AccompaniedBy} } ) { unless ( grep /^\Q$regex\E$/sm, @tmp ) { _pushErrors( "$_ must be called with the following options: " . join ', ', @{ $$tref{AccompaniedBy} } ); $rv = 0; } } # Copy the values into %$oref $$oref{$_} = $$tref{Value}; # TODO: pdebug output } pOut(); pdebug( "leaving w/rv: $rv", PDLEVEL1 ); return $rv; } 1; __END__ =head1 NAME Paranoid::Args - Command-line argument parsing functions =head1 VERSION $Id: Args.pm,v 0.23 2012/09/24 22:43:12 acorliss Exp $ =head1 SYNOPSIS use Paranoid::Args; $rv = parseArgs(\@templates, \%opts); $rv = parseArgs(\@templates, \%opts, \@args); @errors = Paranoid::Args::listErrors(); Paranoid::Args::clearMemory(); =head1 DESCRIPTION The purpose of this module is to provide simplified but validated parsing and extraction of command-line arguments (otherwise known as the contents of @ARGV). It is meant to be used in lieu of modules like B and B, but that does not mean that this module is functionally equivalent -- it isn't. There are things that those modules do that this doesn't, but that's primarily by design. My priorities are a bit different when it comes to this particular task. The primary focus of this module is validation, with the secondary focus being preservation of context. =head2 VALIDATION When validating the use of options and arguments we concern ourselves primarily the following things: =over =item 1) Is the option accompanied by the requisite arguments? =item 2) Was the option called with the other requisite options? =item 3) Was the option called without options meant only for mutually exclusive use? =item 4) Were any unrecognized options used? =back This module also does basic sanity validation of all option templates to ensure correct usage of this module. =head2 PRESERVATION OF CONTEXT Simply put, preservation of context means remembering the order and grouping of associated arguments. A demonstrative example would perhaps serve better than one of my poor explanations. Take the hypothetical case of "tagging" files. The traditional approach is to define an option that takes a single string argument and apply them to the remaining contents of @ARGV: ./foo.pl -t "tag1" file1 file2 This module supports that model, with the option argument template being '$' for that single string. But what if you wanted to apply different tags to different files with one command execution? ./foo.pl -t "tag1" file1 file2 -t "tag2" file3 In this case it is important to keep each group of payloads that you want to operate on separate. With this module you could instead use an argument template of '$@', which would return each set independently: %opt = ( 't' => [ [ "tag1", [ "file1", "file2" ] ], [ "tag2", [ "file3" ] ], ], ); Notice that we also preserve the context between the '$' and the '@' by putting the '@' arguments in a sublist. With this example that could possible be considered pointless, but we also support templates like '$$@$' which makes this very useful. Now, instead of having to shift or pop off the encapsulating arguments they now have one permanent ordinal index. You also can now just grab the array reference for the '@' portion and iterate over a complete and separate list rather than having to take a splice of the complete argument array. It's probably just me, but I find that a little easier to track. =head2 SUPPORTED COMMAND-LINE SYNTAX In keeping with my established tradition of discarding everything I have no use for this module does not support the same range of expressiveness that the B modules do. Nor do we support "flexible" modes of differing modes of expressiveness. What we do support we support unconditionally. The following list of syntactical options are supported: =over =item o Short option bundling (i.e., "rm -rf") =item o Short option counting (i.e., "ssh -vvv") =item o Short option argument concatenation (i.e., "cut -d' '") =item o Long option "equals" argument concatenation (i.e., "./configure --prefix=/usr") =item o The use of '--' to designate all following arguments are strictly that, even if they look like options. =back We don't support the hash key/value pairs (i.e., -s foo=one bar=two) or argument type validation (B can validate string, integer, and floating point argument types). And while we support a short & long option we don't support innumerable aliases in addition. In short, if it isn't explicitly documented it isn't supported, though it probably is in B. There are a few restrictions meant to eliminate confusion: =over =item 1) Long and short argument concatenation is only allowed if the argument template is '$' (expecting a single argument, only). =item 2) Short argument concatenation is furthermore only allowed on arguments that aren't allowed to be bundled with other short options. =item 3) Short options supporting bundling can require associate arguments as long as '@' is not part of the argument template. =back =head1 SUBROUTINES/METHODS =head2 parseArgs $rv = parseArgs(\@templates, \%opts); $rv = parseArgs(\@templates, \%opts, \@args); Using the option templates passed as the first reference this function populates the options hash with all of the parsed options found in the passed arguments. The args list reference can be omitted if you wish the function to work off of B<@ARGV>. Please note that this function makes a working copy of the array, so no alterations will be made to it. If any options and/or arguments fail to match the option template, or if an option is found with no template, a text message is pushed into an errors array and the function will return a boolean false. When the options hash is populated extracted arguments to the options are stored in both long and short form as the keys, assuming they were defined in the template. Otherwise it will use whatever form of option was defined. Any arguments not associated with an option are stored in the options hash in a list associated with the key B. =head2 Paranoid::Args::listErrors @errors = Paranoid::Args::listErrors(); If you need a list of everything that was found wrong during a B run, from template errors to command-line argument validation failures, you can get all of the messages form B. Please note that we show it fully qualified about because it is B exported under any circumstances. If you need these extended diagnostics, you'll need to call it as shown. Each time B is invoked this array is reset. =head2 Paranoid::Args::clearMemory Paranoid::Args::clearMemory(); If the existance of a (most likely) lightly populated array bothers you, you may use this function to empty all internal data structures of their contents. Like B this function is not exported under any circumstances. =head1 OPTION TEMPLATES The function provided by this module depends on templates to extract and validate the options and arguments. Each option template looks similar to the following: { Short => 'v', Long => 'verbose', Template => '$', CountShort => 1, Multiple => 1, CanBundle => 1, ExclusiveOf => [], AccompaniedBy => [], } This template provides extraction of verbose options in the following (and similar) forms: -vvvvv --verbose 5 --verbose=5 If B was instead false you'd have to say '-v5' or '-v 5' instead of '-vvvvv'. When the B function is called the options hash passed to it would be populated with: %opts = ( 'v' => 5, 'verbose' => 5, ); The redundancy is intentional. Regardless of whether you look up the short or the long name you will be able to retrieve the cummulative value. The particulars of all key/value pairs in a template are documented below. =head2 Short B refers to the form of the short option style (minus the normal preceding '-'). If this is left undefined then no short option is supported. This parameter is set to undef by default. B All short option names must be only one character in length and consisting only of alphanumeric characters. =head2 Long B refers to the from of the long option style (minus the normal preceding '--'). If this is left undefined then no long option is supported. This parameter is set to undef by default. B All long option names must be more than one character in length and consisting only of alphanumeric characters and hyphens. =head2 Template B