Doc/tools/checkargs.pm

   1 #! /usr/bin/perl
   2
   3 package checkargs;
   4 require 5.004;                  # uses "for my $var"
   5 require Exporter;
   6 @ISA = qw(Exporter);
   7 @EXPORT = qw(check_args check_args_range check_args_at_least);
   8 use strict;
   9 use Carp;
  10
  11 =head1 NAME
  12
  13 checkargs -- Provide rudimentary argument checking for perl5 functions
  14
  15 =head1 SYNOPSIS
  16
  17   check_args(cArgsExpected, @_)
  18   check_args_range(cArgsMin, cArgsMax, @_)
  19   check_args_at_least(cArgsMin, @_)
  20 where "@_" should be supplied literally.
  21
  22 =head1 DESCRIPTION
  23
  24 As the first line of user-written subroutine foo, do one of the following:
  25
  26   my ($arg1, $arg2) = check_args(2, @_);
  27   my ($arg1, @rest) = check_args_range(1, 4, @_);
  28   my ($arg1, @rest) = check_args_at_least(1, @_);
  29   my @args = check_args_at_least(0, @_);
  30
  31 These functions may also be called for side effect (put a call to one
  32 of the functions near the beginning of the subroutine), but using the
  33 argument checkers to set the argument list is the recommended usage.
  34
  35 The number of arguments and their definedness are checked; if the wrong
  36 number are received, the program exits with an error message.
  37
  38 =head1 AUTHOR
  39
  40 Michael D. Ernst <F<mernst@cs.washington.edu>>
  41
  42 =cut
  43
  44 ## Need to check that use of caller(1) really gives desired results.
  45 ## Need to give input chunk information.
  46 ## Is this obviated by Perl 5.003's declarations?  Not entirely, I think.
  47
  48 sub check_args ( $@ )
  49 {
  50   my ($num_formals, @args) = @_;
  51   my ($pack, $file_arg, $line_arg, $subname, $hasargs, $wantarr) = caller(1);
  52   if (@_ < 1) { croak "check_args needs at least 7 args, got ", scalar(@_), ": @_\n "; }
  53   if ((!wantarray) && ($num_formals != 0))
  54     { croak "check_args called in scalar context"; }
  55   # Can't use croak below here: it would only go out to caller, not its caller
  56   my $num_actuals = @args;
  57   if ($num_actuals != $num_formals)
  58     { die "$file_arg:$line_arg: function $subname expected $num_formals argument",
  59       (($num_formals == 1) ? "" : "s"),
  60       ", got $num_actuals",
  61       (($num_actuals == 0) ? "" : ": @args"),
  62       "\n"; }
  63   for my $index (0..$#args)
  64     { if (!defined($args[$index]))
  65         { die "$file_arg:$line_arg: function $subname undefined argument ", $index+1, ": @args[0..$index-1]\n"; } }
  66   return @args;
  67 }
  68
  69 sub check_args_range ( $$@ )
  70 {
  71   my ($min_formals, $max_formals, @args) = @_;
  72   my ($pack, $file_arg, $line_arg, $subname, $hasargs, $wantarr) = caller(1);
  73   if (@_ < 2) { croak "check_args_range needs at least 8 args, got ", scalar(@_), ": @_"; }
  74   if ((!wantarray) && ($max_formals != 0) && ($min_formals !=0) )
  75     { croak "check_args_range called in scalar context"; }
  76   # Can't use croak below here: it would only go out to caller, not its caller
  77   my $num_actuals = @args;
  78   if (($num_actuals < $min_formals) || ($num_actuals > $max_formals))
  79     { die "$file_arg:$line_arg: function $subname expected $min_formals-$max_formals arguments, got $num_actuals",
  80       ($num_actuals == 0) ? "" : ": @args", "\n"; }
  81   for my $index (0..$#args)
  82     { if (!defined($args[$index]))
  83         { die "$file_arg:$line_arg: function $subname undefined argument ", $index+1, ": @args[0..$index-1]\n"; } }
  84   return @args;
  85 }
  86
  87 sub check_args_at_least ( $@ )
  88 {
  89   my ($min_formals, @args) = @_;
  90   my ($pack, $file_arg, $line_arg, $subname, $hasargs, $wantarr) = caller(1);
  91   # Don't do this, because we want every sub to start with a call to check_args*
  92   # if ($min_formals == 0)
  93   #   { die "Isn't it pointless to check for at least zero args to $subname?\n"; }
  94   if (scalar(@_) < 1)
  95     { croak "check_args_at_least needs at least 1 arg, got ", scalar(@_), ": @_"; }
  96   if ((!wantarray) && ($min_formals != 0))
  97     { croak "check_args_at_least called in scalar context"; }
  98   # Can't use croak below here: it would only go out to caller, not its caller
  99   my $num_actuals = @args;
 100   if ($num_actuals < $min_formals)
 101     { die "$file_arg:$line_arg: function $subname expected at least $min_formals argument",
 102       ($min_formals == 1) ? "" : "s",
 103       ", got $num_actuals",
 104       ($num_actuals == 0) ? "" : ": @args", "\n"; }
 105   for my $index (0..$#args)
 106     { if (!defined($args[$index]))
 107         { warn "$file_arg:$line_arg: function $subname undefined argument ", $index+1, ": @args[0..$index-1]\n"; last; } }
 108   return @args;
 109 }
 110
 111 1;                              # successful import
 112 __END__