#!/usr/local/rib/rib-1.0/bin/perl use lib '/usr/local/rib/rib-1.0/lib'; # NHSE Repository in a Box (RIB) # # The authors of this software are Paul McMahan and Jeff Horner. # Copyright (c) 1997 by the University of Tennessee. # Permission to use, copy, modify, and distribute this software for any # purpose without fee is hereby granted, provided that this entire notice # is included in all copies of any software which is or includes a copy # or modification of this software and in all copies of the supporting # documentation for such software. # THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED # WARRANTY. IN PARTICULAR, NEITHER THE AUTHORS NOR UNIVERSITY OF TENNESSEE # MAKE ANY REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE # MERCHANTABILITY OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE. # # $Id: create_object.pl,v 1.3 1998/02/24 22:56:57 rib Exp $ # # $Log: create_object.pl,v $ # Revision 1.3 1998/02/24 22:56:57 rib # changed the button which updates the form (after clicking "add a field # or "delete a field") to say "Update form" instead of just "Update". # A button which just said "Update" was misleading, especially when used # in edit_object.pl # # Revision 1.2 1998/01/22 02:50:07 rib # added the upload and mirroring feature to RIB. This required # the addition of several new scripts and the modification of # admin_repository. # # also, removed any use of # from the RIB scripts because this was working out very # well. # # Revision 1.1.1.1 1997/12/10 15:59:31 jhorner # RIB pre 1.0 # # Revision 1.1 1997/05/06 18:15:49 jhorner # Initial revision # use RIB::Util (); use RIB::ConfigParser (); use RIB::DomainParser (); use HTML::Entities (); my $util = RIB::Util->new(); $util->PrintHeader(); my %in = $util->ReadParse(); $repository = $util->GetRepoName(); if (!$repository) { $util->ErrorMessage("repository was not specifed in your input."); } elsif (!$in{class}) { $util->ErrorMessage("class was not specifed in your input."); } my $filepath = $util->GetRibDir() . "/repositories/" . $repository; my $urlpath = $util->GetRibUrl() . "/repositories/" . $repository; $back_to_top = $util->BackToTop($repository); my $cp = RIB::ConfigParser->new(); $cp->load_config($filepath."/conf/BIDM.conf"); my $object = $cp->InstanceOf('',$in{class}); # get a list of all of the fieldnames that were in # this repository's config file my @allfields = $object->Fields(); # sort inputs from the %in variable into arrays. foreach $key (keys %in) { next unless $key =~ /^\d+(\S+)/; my $field = $1; $object->AddEntry($field, $in{$key}); } ############################################################################# print ""; print "$in{class} "; print "creation for "$repository"\n"; print "\n"; print "\n"; print "\n"; print "

$in{class} creation for "; print ""$repository"

\n"; print "\n"; print "

\n"; print "["; print "help on using this form]\n

\n"; if ($in{create}) { my $filename = $in{filename}; my $overwrite = $in{overwrite}; my $errors = ''; $filename =~ s/^\s+//; $filename =~ s/\.html\s*$//ig; # check out the filename if (!$filename) { push (@errors, "Filename needs an input"); } elsif ($filename!~/^[0-9a-zA-Z_\-\.]+$/) { push (@errors,"The Filename that you entered " . "contained at least one " . "space or other illegal character."); } elsif ($filename =~ /\.\.\//) { push (@errors,"The Filename that you entered " . "contained '../' which an illegal sequence for " . "the filename"); } elsif (-e "$filepath/objects/$in{class}/$filename.html" && !$overwrite) { push (@errors,"The Filename that " . "you specified is already in use in the " . "" . "$in{class} directory.
Please " . "choose a different filename for this " . "$in{class}. If you want to replace the current file " . "then you need to " . "make sure that the " . "that the "Overwrite" checkbox is depressed " . "(next to the filename box)."); } foreach $field (sort @allfields) { if ($object->IsRequired($field) && !$object->NumRealEntries($field)) { push (@errors, "$field needs an input"); } if ($object->IsRelationship($field)) { foreach $link ($object->ListEntries($field)) { next unless $link; if ($link !~ /^(http|ftp|gopher|news):\/\//) { my ($target, $tmp); $target = $object->Destination($field); ($tmp=$link) =~ s/\.html$//; if (!(-f "$filepath/objects/$target/${tmp}.html")) { push (@errors,"The value specified for the " ."$field field " ."("$link") is neither " ."a valid url nor the name of a file that exists " ."in this repository's " ."$target " ."directory."); } else { my $oldlink = $link; $link = $link.".html" unless $link =~ /\.html$/; my $newlink = $urlpath . "/objects/$target/$link"; $object->ReplaceEntry($field, $oldlink, $newlink); } } } } } if (!@errors) { umask 002; # now write the file unless (open (NEWOBJECT, ">$filepath/objects/$in{class}/$filename.html")) { $util->ErrorMessage("Couldn't write to the file " . "$filepath/objects/$in{class}/$filename.html" . "
Reason : $!

This $in{class} description file cannot be saved" . " until this problem is resolved."); } select NEWOBJECT; my @names = $object->ListEntries("Name"); print "$names[0]\n"; foreach $field (sort @allfields) { foreach $entry ($object->ListEntries($field)) { next unless $entry =~ /\S/m; $entry =~ s/\n+/ /sg; if ($object->IsAttribute($field)) { print "\n"; } else { print "Destination($field) . "\" "; print "href=\"" . HTML::Entities::encode($entry) . "\">\n"; } } } print ""; print "

$in{class} description file for $names[0]"; print "

\n"; print "Contents of this $in{class} file:

\n"; print "

\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; print "\n"; foreach $field (sort @allfields) { foreach $entry ($object->ListEntries($field)) { next unless $entry =~ /\S/m; print "\n"; print "\n"; print "\n"; if ($object->IsAttribute($field)) { print "\n"; } else { print "\n"; } print "\n"; } } print "

Field Name	Value	HTML Tag Type
BIDM.$in{class}.$field"; if ($object->IsRelationship($field)) { print "." , $object->Destination($field); } print "	"; $entry =~ s/\n/ /gm; my $encoded = HTML::Entities::encode($entry); if ($object->IsAttribute($field)) { if ($object->DataType($field) eq 'email') { print "$encoded"; } elsif ($object->DataType($field) eq 'url') { print "$encoded"; } else { print $encoded; } } else { print "$encoded"; } print "	META	LINK

\n"; close (NEWOBJECT); select (STDOUT); # Create the catalog description as well # my $buf; if(!$object->AsHtml(\$buf,$repository,"$filename.html",$cp)){ $util->ErrorMessage("There were problems creating the catalog" . "description file for $filename." . "
Reason : ". $object->ErrorMsg . "

This $in{class} description file cannot be saved" . " until this problem is resolved."); } else { my $pagepath = $util->GetRibDir."/repositories/$repository/catalog/$in{class}/$filename.html"; unless (open (PAGE,">$pagepath")) { $util->ErrorMessage("Couldn't write to the file " . "$filepath/objects/$in{class}/$filename.html" . "
Reason : $!

This $in{class} description file cannot " . "be saved until this problem is resolved."); } print PAGE $util->ClassHeader($in{class}); print PAGE $buf; print PAGE $util->ClassFooter($in{class}); close(PAGE); } $buf = ''; select (STDOUT); print "The $in{class} description file named $filename "; print " was successfully "; $overwrite ? print "updated.\n" : print "created.\n"; if ($in{class} eq 'Asset' && -f "$filepath/catalog/index.html") { print "

Note that this new Asset will not appear in this\n"; print "repository's GetRibUrl(), "/repositories/$repository/catalog/index.html\">", "software catalog until it has been regenerated.

\n"; print "Click here to update the software "; print "catalog for this repository.\n"; } print $back_to_top; print "\n"; print "

Create another new $in{class} for this repository\n"; print "\n"; exit; } } ############################################################################# if (@errors) { print "Please correct the following error(s) :\n"; print "

$error\n"; } print "

\n"; print "After making these changes in the form below please try your "; print "submission again.\n

\n"; } else { print "To create a new $in{class} description file please "; print "fill out this form and press the button at the bottom "; print "this page.\n"; print "

\n"; } ############################################################################# if (!$in{create}) { # if they botched a submission then don't do this # if they wanted to add or delete a field then do it here foreach $key (keys %in) { next if $key eq "filename"; next if $key eq "repository"; next if $key eq "class"; if ($in{$key} eq "delete") { $object->RemoveLastEntry($key); print "Deleted a field from $key
\n"; } elsif ($in{$key} eq "add") { $object->AddEntry($key,""); print "Added a field for $key
\n"; } } } # make a dummy entry for fields that are required # and that are currently empty foreach $field (@allfields) { #if ($object->IsRequired($field) && !$object->NumEntries($field)) { if (!$object->NumEntries($field)) { $object->AddEntry($field,""); } } print "

\n"; print "

\n"; print "\n"; foreach $field (sort @allfields) { $radio_flag = 0; print ""; print "\n"; print "\n"; print "\n"; print "\n"; if ($object->IsRelationship($field)) { my $target = $object->Destination($field); print ""; print "\n"; print "\n"; print "\n"; } print ""; print ""; print ""; ### print a radio button which can be used to deselect the ### other radio buttons. This is a hack to get around the ### the fact that with Netscape you can't deselect a clicked ### radio button print ""; ### return this button only if needed print ""; print "\n"; ### print input boxes for existing fields foreach $entry ($object->ListEntries($field)) { print "\n"; print "\n"; print "\n"; } print "

"; print ""; print ""; print "$field"; if ($object->IsRelationship($field)) { print " ", $object->Destination($field); } print ""; if ($object->IsRequired($field)) { print " (required "; } else { print " (optional "; } if ($object->IsRelationship($field)) { print "relationship)"; } else { print "attribute)"; } print "
\n"; print ""; print "Browse\n"; print "		\n"; print " "; print "Create "; print "
"; ### allow addtion of an input box when the field is multiple ### or (not xor) when field is currently empty and not required if ( $object->IsMultiple($field) \|\| (!$object->NumEntries($field) && !$object->IsRequired($field)) ) { print " Add a Field\n"; $radio_flag = 1; } print "	"; ### allow the last box on the current form to be deleted when ### the field already has more than one entry or (not xor) ### when the field is optional and cueently empty if ( ($object->NumEntries($field) > 1) \|\| (!$object->IsRequired($field) && $object->NumEntries($field) > 1) ) { print " Delete last Field\n"; $radio_flag = 1; } print "	"; if ($radio_flag) { print " Cancel\n"; } print "	"; if ($radio_flag) { print "\n"; } print "
\n"; print HtmlInputBox($repository,$object,$field,$entry); print "

\n"; print "

\n"; } print "

\n"; print "The filename for this $in{class} description file\n"; print "should contain only alphanumeric (0-9, A-Z, a-z), dash ( - ),\n"; print "underscore ( _ ), and dot ( . ) characters and should not \n"; print "contain any spaces. If the filename already exists in \n"; print ""; print "this repository's $in{class} directory then that file\n"; print "will not be overwritten unless the "Overwrite" checkbox "; print "is checked.\n

"; print "\n"; print "Filename:\n"; print ""; print "Overwrite

\n"; print "

Note: the filename that you specify will be automatically " . "appended with the extension ".html" when RIB saves " . "the file in its objects directory."; print "

\n"; # next checkbox MUST be reset between every submission. if it wasn't # then trying to update the form would cause the form to be submitted # for creation print "\n"; print " "; print ""; print "
\n"; print "

\n"; print "\n"; print $back_to_top; # return a string containing the html for an input box. # the type of box depends on the data type of the field. # if the field is a domain then present a list of choices # for that field sub HtmlInputBox { my $repository = shift; my $object = shift; my $field = shift; my $value = shift; # in order to allow fields to have more than one # entry in the html form, the name of the field must # be prepended with a sequence number. this keeps # fields with multiple entries from trying to use # the same variable name to describe all of their fields. # For example, # if there are two "Domain" fields for this object # then the html form would need to call the first # "1Domain" and the second "2Domain". # Of course this means that the config file for this # site can't attempt to start attribute or relationship # names with a digit. $fieldcount{$field}++; # if the field is 'Domain' then present a list of choices from # the repository's domains.html file, if possible if ($field eq 'Domain') { local ($options); #cache this repository's domains in @domains (must remain global) unless (@domains) { # try to use the repository's domains.html file to present # a list of choices for this field. my $file = RIB::Util::GetRibDir() . "/repositories/" . $repository . "/conf/domains.html"; my $p = RIB::DomainParser->new(); eval { $p->parse_file($file) }; @domains = $p->list() unless $@; } foreach $entry (@domains) { $options .= "\n" . $options . "
\n"; } } elsif ($field eq 'DateOfInformation' && !$value) { my $date = $util->Date(); return ""; } elsif ($object->DataType($field) eq 'string' or $object->DataType($field) eq 'url' or $object->DataType($field) eq 'email') { return ""; } elsif ($object->DataType($field) eq 'date') { return ""; } elsif ($object->IsRelationship($field)) { return ""; } else { return ""; } }