Beefy Boxes and Bandwidth Generously Provided by pair Networks Cowboy Neal with Hat
No such thing as a small change
 
PerlMonks  

Getting subroutine @_ w/ defaults

by Super Monkey (Beadle)
on Apr 18, 2002 at 21:13 UTC ( #160347=snippet: print w/ replies, xml ) Need Help??

Description: This subroutine allows you to pass parameters in any order and provide default values. Those of you who are familiar with something like this; my ($p0,$p1) = @{{@_}}{qw/p0 p1/}, will find this as an extention to it's functionality. You must supply a default value for each expected input parameter, even if it is null, and the order of the parameters to subParams matters.
sub subParams {
  my %parameters = @{shift(@_)};
  my @ret = ();

  while (my ($entry,$default) = splice(@_,0,2)) {
    if(length $parameters{$entry}) {
      push(@ret,$parameters{$entry});
    }
    else {
      push(@ret,$default);
    }
  }

@ret;
}

sub sample { 
  my ($p0,$p1) = subParams(\@_,p0=>'d0',p1=>'d1');
}

#With the above code, each of these calls are indentical

sample(p0=>'d0',p1=>'d1');
sample(p1=>'d1',p0=>'d0');
sample(p0=>'d0');
sample(p1=>'d1');
sample();
Comment on Getting subroutine @_ w/ defaults
Download Code
Re: Getting subroutine @_ w/ defaults
by rob_au (Abbot) on Apr 19, 2002 at 05:49 UTC
    As always, TMTOWTDI - From some of my code ...

    use Carp; sub example { my %options = ( 'DEBUG' => 0, 'TMPL_PATH' => undef ); my %args = ( %options, @_ ); foreach ( keys %args ) { croak( 'Unknown argument passed to subroutine - ', $_ ) unless exists $options{$_}; } . . }

    This code makes use of a second hash for the definition of default values for arguments and incorporates a check for unknown arguments by comparing the keys of the merged hash %args with that of the default values (%options).

     

(crazyinsomniac) Re: Getting subroutine @_ w/ defaults
by crazyinsomniac (Prior) on Apr 22, 2002 at 08:15 UTC
    Here is one of mine I was writing last month for me fancy index script -- i was turning it into a module. I added the callback option after coming accross this node (I said what the heck, couldn't hurt). It not only sets defaults, but does validity checks for values. Keep mind me module ain't finished, and this is from 3rd revision .. style could use some polishing, and a few more checks could be added ...
    #!/usr/bin/perl -w # the defaults that *MUST* be defined # the default value is element 1 # each subsequent element is an acceptable value # use quotemeta or \Q\E if you need to # all matching is done with the global flag on, # so anchor if you need to # use "" for any value (or qr{^.*$}iso) my %DEFAULTS = ( FOLDERS_FIRST => [1,0], SORT_ORDER => [qw/ A D /], SORT_BY => [qw/ N M S/], ALLOW_QUERY => [1, 0], # allows ?N=A and teh like CACHING => [0, 1], EMIT_HEADER => [1, 0, 'text/html', [ qr{ (\s? \w+ \/ \w+ \s? \;?) }iosx, sub { my ($val, $matchesref, @matches) = @_; carp("uh oh") if length($val) != length(join +'',@matches); $$matchesref = 1; # we'll warn, but we'll still accept the val +ue } ] ], ,); my %OPTIONALS = ( CACHE_WHERE => [""], # here dummy CACHE_AS => [""], # user here CACHE_SIZE => [""], # you tell me KEY_SIZE => [qr{^\d+$}], # once again, you tell me ); use Carp; use Data::Dumper; print Dumper new('satin', SORT_BY => 'N', EMIT_HEADER => 'text/plain', CACHE_WHERE => 'on the moooon', KEY_SIZE => -1,); print Dumper new('satin', SORT_BY => 'N', EMIT_HEADER => 'text/plain; charset=US-ASCII', KEY_SIZE => 10,); sub new { my ($satin, %options) = @_; my %me = map { $_ => $DEFAULTS{$_}->[0] } keys %DEFAULTS; for my $optionkey(keys %options) { my @DEFS; @DEFS = @{$DEFAULTS{$optionkey}} if exists $DEFAULTS{$optionke +y}; @DEFS = @{$OPTIONALS{$optionkey}} if exists $OPTIONALS{$option +key}; if(@DEFS) { my $optv = $options{$optionkey}; my $matches = 0; for my $pattern ( @DEFS ) { if (ref($pattern) eq 'ARRAY') { my ($pat, $sub ) = @$pattern; $sub->( $optv, \$matches, $optv =~ m{$pat}g); }elsif( $optv =~ m{$pattern}g ) { $matches++; last; } } if( $matches ) { $me{$optionkey} = $optv; } else { carp "`$optv' is not a valid value for `$optionkey' -- + please read the pod"; } } else { carp "`$optionkey' is not a valid option -- please read th +e pod."; } } return bless \%me, $satin; # i have not sinnid }

     
    ______crazyinsomniac_____________________________
    Of all the things I've lost, I miss my mind the most.
    perl -e "$q=$_;map({chr unpack qq;H*;,$_}split(q;;,q*H*));print;$q/$q;"

Back to Snippets Section

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://160347]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (13)
As of 2014-04-23 19:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (553 votes), past polls