#
# ARSperl - An ARS v2-v4 / Perl5 Integration Kit
#
# Copyright (C) 1995-1999 Joel Murphy, jmurphy@acsu.buffalo.edu
# Jeff Murphy, jcmurphy@acsu.buffalo.edu
#
# This program is free software; you can redistribute it and/or modify
# it under the terms as Perl itself.
#
# Refer to the file called "Artistic" that accompanies the source distribution
# of ARSperl (or the one that accompanies the source distribution of Perl
# itself) for a full description.
#
# Official Home Page:
#
# Mailing List (must be subscribed to post):
# arsperl@arsinfo.cit.buffalo.edu
#
# the following two routines
# make_attributes()
# rearrange()
# were borrowed from the CGI module. these routines implement
# named parameters.
# Copyright 1995-1997 Lincoln D. Stein. All rights reserved.
sub make_attributes {
my($attr) = @_;
return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
my(@att);
foreach (keys %{$attr}) {
#print "attr=$_\n";
my($key) = $_;
$key=~s/^\-//; # get rid of initial - if present
$key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
}
return @att;
}
# rearrange(order, params)
# order will be an array reference (might contain other array refs)
# that lists the order we want the params returned in.
#
# param is the actual params, probably as (-key, value) pairs.
sub rearrange {
my($order,@param) = @_;
return () unless @param;
my($param, @possibilities);
foreach (@$order) {
if(ref($_) && (ref($_) eq "ARRAY")) {
foreach my $P (@{$_}) {
push @possibilities, $P;
}
} else {
push @possibilities, $_;
}
}
#print "possibilities=".join(',', @possibilities)."\n";
unless (ref($param[0]) eq 'HASH') {
return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-');
$param = {@param}; # convert into associative array
} else {
$param = $param[0];
}
my($key)='';
foreach (keys %{$param}) {
my $old = $_;
s/^\-//; # get rid of initial - if present
tr/a-z/A-Z/; # parameters are upper case
next if $_ eq $old;
$param->{$_} = $param->{$old};
delete $param->{$old};
}
# scan the keys in param and make sure they are valid.
foreach my $key (keys %$param) {
#print "validating: $key\n";
my (@t) = grep(/^$key$/, @possibilities);
Carp::confess "invalid named parameter \"$key\"" if $#t == -1;
}
my(@return_array);
foreach $key (@$order) {
#print "key=$key\n";
my($value);
# this is an awful hack to fix spurious warnings when the
# -w switch is set.
if (ref($key) && ref($key) eq 'ARRAY') {
foreach (@$key) {
last if defined($value);
$value = $param->{$_};
delete $param->{$_};
}
} else {
$value = $param->{$key};
delete $param->{$key};
}
push(@return_array,$value);
}
push (@return_array,make_attributes($param)) if %{$param};
return (@return_array);
}
1;