Commit 5756edfb authored by Russ Fish's avatar Russ Fish

Sync copies of the xmlfields code, before I forget why they're different.

parent 24ffb396
......@@ -168,7 +168,8 @@ my %errors = ();
#
# Make sure all the required arguments were provided.
#
foreach my $key (keys(%xmlfields)) {
my $key;
foreach $key (keys(%xmlfields)) {
my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided"
......@@ -184,20 +185,60 @@ UserError()
#
my %editexp_args = ();
foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -228,7 +269,7 @@ foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
next;
}
$editexp_args{$dbslot} = $value;
$editexp_args{$key} = $value;
}
UserError()
if (keys(%errors));
......@@ -238,7 +279,7 @@ UserError()
#
my $doemail = 0;
my $experiment = Experiment->Lookup($editexp_args{"eid_idx"});
my $experiment = Experiment->Lookup($editexp_args{"experiment"});
if (!defined($experiment)) {
UserError("Experiment: No such experiment");
}
......
......@@ -128,8 +128,15 @@ my $SLOT_ADMINONLY = 0x4; # Only admins can set this field.
#
my %xmlfields =
# XML Field Name DB slot name Flags Default
("group" => ["gid_idx", $SLOT_REQUIRED]);
# And also trust args, see below.
("group" => ["gid_idx", $SLOT_REQUIRED],
# Trust args, either:
# (change|add)_xxx=permit or
# Uxxx$$trust=(user|local_root|group_root)
# where xxx is the uid_idx of a user.
"change_*" => ["change", $SLOT_OPTIONAL],
"add_*" => ["add", $SLOT_OPTIONAL],
"U*\\\$\\\$trust" => ["trust", $SLOT_OPTIONAL]);
#
# Must wrap the parser in eval since it exits on error.
......@@ -168,36 +175,60 @@ UserError()
#
my %editgroup_args = ();
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
}
# XXX Special for trust args. Either:
# (change|add)_xxx=permit or
# Uxxx$$trust=(user|(local|group)_root)
# where xxx is the uid_idx of a user.
if (($key =~ /^(change|add)_[0-9]+$/ &&
$value eq "permit") ||
($key =~ /^U[0-9]+\$\$trust$/ &&
$value =~ /^(user|(local|group)_root)$/)) {
if ($debug) {
print STDERR "Trust: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
$editgroup_args{$key} = $value;
next;
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -222,12 +253,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "groups", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "groups",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
$editgroup_args{$dbslot} = $value;
$editgroup_args{$key} = $value;
}
UserError()
if (keys(%errors));
......@@ -235,7 +267,7 @@ UserError()
#
# Now do special checks.
#
my $group = Group->Lookup($editgroup_args{"gid_idx"});
my $group = Group->Lookup($editgroup_args{"group"});
if (!defined($group)) {
UserError("Group: No such group");
}
......@@ -254,7 +286,7 @@ exit(0)
# We pass the group along as an argument to EditGroup(), so remove it from
# the argument array.
#
delete($editgroup_args{"gid_idx"});
delete($editgroup_args{"group"});
my $usrerr;
my $editgroup_val = Group->EditGroup($group, $this_user,
......
......@@ -138,9 +138,9 @@ my %xmlfields =
# The rest are optional, so we can skip passing ones that are not changing.
"description" => ["description", $SLOT_OPTIONAL],
"path" => ["path", $SLOT_OPTIONAL],
"mtype_*" => ["mtype", $SLOT_OPTIONAL],
"load_address" => ["load_address", $SLOT_ADMINONLY],
"frisbee_pid" => ["frisbee_pid", $SLOT_ADMINONLY]);
# The "mtype_$type" node type booleans are handled below...
#
# Need a list of node types. We join this over the nodes table so that
# we get a list of just the nodes that are currently in the testbed, not
......@@ -199,38 +199,60 @@ UserError()
my %editimageid_args = ();
my $foo;
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
}
# XXX Special for mtype_* args, since the keys are dynamically generated.
if ($key =~ /^mtype_[\w]+$/) {
print STDERR "mtype: '$key' -> '$value'\n"
if ($debug);
my $type = $key;
$type =~ s/^mtype_//;
my $match = grep(/^${type}$/, @mtypes_array);
$errors{$key} = "Illegal node type."
if ($match == 0);
$errors{$key} = "Illegal characters in boolean value"
if ($value ne "0" && $value ne "1");
$editimageid_args{$key} = $value;
next;
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -255,12 +277,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "images", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "images",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
$editimageid_args{$dbslot} = $value;
$editimageid_args{$key} = $value;
}
UserError()
if (keys(%errors));
......@@ -320,11 +343,32 @@ if (!$isadmin && exists($editimageid_args{"path"})) {
#
# See what node types this image will work on. Must be at least one!
if ($#mtypes_array < 0) {
UserError("Node Types: Must have at least one node type");
}
#
UserError("Node Types: Must have at least one node type")
if ($#mtypes_array < 0);
my $typeclause = join(" or ", map("type='$_'", @mtypes_array));
# Check validity of mtype_* args, since the keys are dynamically generated.
my $node_types_selected = 0;
my @mtype_keys = grep(/^mtype_/, keys(%editimageid_args));
foreach $key (@mtype_keys) {
my $value = $editimageid_args{$key};
print STDERR "mtype: '$key' -> '$value'\n"
if ($debug);
my $type = $key;
$type =~ s/^mtype_//;
my $match = grep(/^${type}$/, @mtypes_array);
if ($match == 0) {
$errors{$key} = "Illegal node type."
}
elsif ($value eq "1") {
$node_types_selected++;
}
}
UserError("Node Types: Must select at least one node type")
if ($node_types_selected == 0);
#
# Only admins can edit the load_address or the frisbee pid.
#
......
......@@ -278,7 +278,8 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "node_types", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "node_types",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
......
......@@ -171,20 +171,60 @@ UserError()
#
my %editsitevars_args = ();
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -209,13 +249,13 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "sitevariables",
if (! TBcheck_dbslot($value, "sitevariables",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
$editsitevars_args{$dbslot} = $value;
$editsitevars_args{$key} = $value;
}
UserError()
if (keys(%errors));
......
......@@ -152,6 +152,7 @@ my %xmlfields =
"w_password2" => ["w_password2", $SLOT_OPTIONAL],
"user_interface" => ["user_interface", $SLOT_OPTIONAL],
"notes" => ["notes", $SLOT_OPTIONAL]);
#
# Must wrap the parser in eval since it exits on error.
#
......@@ -172,7 +173,8 @@ my %errors = ();
#
# Make sure all the required arguments were provided.
#
foreach my $key (keys(%xmlfields)) {
my $key;
foreach $key (keys(%xmlfields)) {
my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided"
......@@ -188,20 +190,60 @@ UserError()
#
my %moduserinfo_args = ();
foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -226,7 +268,8 @@ foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "users", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "users",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
......
......@@ -155,7 +155,8 @@ my %errors = ();
#
# Make sure all the required arguments were provided.
#
foreach my $key (keys(%xmlfields)) {
my $key;
foreach $key (keys(%xmlfields)) {
my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided"
......@@ -171,20 +172,60 @@ UserError()
#
my %newgroup_args = ();
foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
}
if ($debug) {
print STDERR "User attribute: '$key' -> '$value'\n";
print STDERR "User attribute: '$key' -> '$value'\n"
if ($debug);
my $field = $key;
my $wild;
if (!exists($xmlfields{$key})) {
# Not a regular key; look for a wildcard regex match.
foreach my $wildkey (@wildkeys) {
my $regex = $wildcards{$wildkey};
if ($wild = $key =~ /$regex/) {
$field = $wildkey;
print STDERR "Wildcard: '$key' matches '$wildkey'\n"
if ($debug);
last; # foreach $wildkey
}
}
if (!$wild) {
$errors{$key} = "Unknown attribute";
next; # foreach $key
}
}
$errors{$key} = "Unknown attribute"
if (!exists($xmlfields{$key}));
my ($dbslot, $required, $default) = @{$xmlfields{$key}};
my ($dbslot, $required, $default) = @{$xmlfields{$field}};
if ($required & $SLOT_REQUIRED) {
# A slot that must be provided, so do not allow a null value.
......@@ -209,7 +250,8 @@ foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "groups", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "groups",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
......
......@@ -266,7 +266,8 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "images", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "images",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
......@@ -442,7 +443,7 @@ my $typeclause = join(" or ", map("type='$_'", @mtypes_array));
# Check validity of mtype_* args, since the keys are dynamically generated.
my $node_types_selected = 0;
my @mtype_keys = grep(/^mtype_/, keys(%newimageid_args));
foreach my $key (@mtype_keys) {
foreach $key (@mtype_keys) {
my $value = $newimageid_args{$key};
print STDERR "mtype: '$key' -> '$value'\n"
if ($debug);
......
......@@ -268,7 +268,8 @@ foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
}
# Now check that the value is legal.
if (! TBcheck_dbslot($value, "images", $dbslot, TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($value, "images",
$dbslot, TBDB_CHECKDBSLOT_ERROR)) {
$errors{$key} = TBFieldErrorString();
next;
}
......@@ -449,7 +450,7 @@ my $typeclause = join(" or ", map("type='$_'", @mtypes_array));
# Check validity of mtype_* args, since the keys are dynamically generated.
my $node_types_selected = 0;
my @mtype_keys = grep(/^mtype_/, keys(%newimageid_args));
foreach my $key (@mtype_keys) {
foreach $key (@mtype_keys) {
my $value = $newimageid_args{$key};
print STDERR "mtype: '$key' -> '$value'\n"
if ($debug);
......
......@@ -158,7 +158,8 @@ my %errors = ();
#
# Make sure all the required arguments were provided.
#
foreach my $key (keys(%xmlfields)) {
my $key;
foreach $key (keys(%xmlfields)) {
my (undef, $required, undef) = @{$xmlfields{$key}};
$errors{$key} = "Required value not provided"
......@@ -174,20 +175,60 @@ UserError()
#
my %newmmlist_args = ();
foreach my $key (keys(%{ $xmlparse->{'attribute'} })) {
#
# Wildcard keys have one or more *'s in them like simple glob patterns.
# This allows multiple key instances for categories of attributes, and
# putting a "type signature" in the key for arg checking, as well.
#
# Wildcards are made into regex's by anchoring the ends and changing each * to
# a "word" (group of alphahumeric.) A tail * means "the rest", allowing
# multiple words separated by underscores or dashes.
#
my $wordpat = '[a-zA-Z0-9]+';
my $tailpat = '[-\w]+';
my %wildcards;
foreach $key (keys(%xmlfields)) {
if (index($key, "*") >= 0) {
my $regex = '^' . $key . '$';
$regex =~ s/\*\$$/$tailpat/;
$regex =~ s/\*/$wordpat/g;
$wildcards{$key} = $regex;
}
}
# Key ordering is lost in a hash.
# Put longer matching wildcard keys before their prefix.
my @wildkeys = reverse(sort(keys(%wildcards)));
foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
if (!defined($value)) { # Empty string comes from XML as an undef value.
$xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";