# 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.
#
# this package contains various utilities used by the RIB
# $Id: Util.pm.DIST,v 1.5 1998/05/13 02:19:40 rib Exp $
#
# $Log: Util.pm.DIST,v $
# Revision 1.5 1998/05/13 02:19:40 rib
# reverted version number back to 1.2 since the changes were only bug fixes
#
# Revision 1.4 1998/05/13 01:26:14 rib
# changed version number to 1.3
#
# Revision 1.3 1998/01/22 03:17:13 rib
# updated version number in Util.pm.DIST
#
# Revision 1.2 1997/12/18 18:54:34 rib
# *** empty log message ***
#
# Revision 1.1.1.1 1997/12/10 15:59:29 jhorner
# RIB pre 1.0
#
# Revision 1.3 1997/05/26 15:09:03 jhorner
# Changed BackToTop to use RIBDIR/cgi-bin/admin
#
# Revision 1.2 1997/05/26 14:59:01 jhorner
# Changed GetRepoName to now look in RIBDIR/cgi-bin/admin
#
# Revision 1.1 1997/05/06 19:03:11 jhorner
# Initial revision
#
package RIB::Util;
use strict;
use Cwd;
use Fcntl;
use Data::Dumper ();
use LWP::UserAgent ();
use HTTP::Request ();
use RIB::BIDMParser ();
use RIB::ConfigParser ();
use MD5;
use vars qw($VERSION);
$VERSION = "1.2";
sub new {
my $self = shift;
my $obj = {};
$obj->{'ribdir'} = $self->GetRibDir();
return bless $obj, $self;
}
# this string is printed at the bottom of most of the web pages
# that are created by the RIB cgi-scripts
sub BackToTop {
my ($class, $repository) = @_;
if ($repository) {
return "
"
. "Back to $repository administration page
\n";
} else {
return "
Back to top RIB "
. "administration page
\n";
}
}
# print out an html error message and exit
sub ErrorMessage {
my $self = shift;
my ($message) = @_;
print "
Error\n";
print "\n";
print "\n";
print "Error
\n";
print "
\n";
print "
\n";
print "Error Message:\n";
print "$message\n";
print $self->BackToTop;
print "\n";
exit(1);
}
# print out an html error message without head and body tags and exit
sub HtmlEmbeddedCroak {
my $self = shift;
my ($message) = @_;
print "
Error
\n";
print "\n";
print "Error Message:
\n";
print "$message
\n";
exit(1);
}
# print out an html error message without head and body tags and exit
sub HtmlCroak {
my $self = shift;
my ($message) = @_;
print "Error
\n";
print "
\n";
print "Error Message:
\n";
print "$message\n";
print $self->BackToTop;
exit(1);
}
# convert special html characters into their encoded form
sub HtmlFix {
my $class = shift;
my $string = shift;
$string =~ s/&/&/g; # gotta do this first!!
$string =~ s/"/"/g;
$string =~ s//>/g;
$string =~ s/\n/ /mg;
$string =~ s/\s+/ /mg;
$string =~ s/^\s*//;
$string =~ s/\s*$//m;
return $string;
}
# get the input to a cgi-script from the http server.
# values are hashed in %in
sub ReadParse {
my ($i, $loc, $key, $val,$in,@in,%in);
if ($ENV{'REQUEST_METHOD'} eq "GET") {
$in = $ENV{'QUERY_STRING'};
} elsif ($ENV{'REQUEST_METHOD'} eq "POST") {
$in = '';
for ($i = 0; $i < $ENV{'CONTENT_LENGTH'}; $i++) {
$in .= getc;
}
}
@in = split(/&/,$in);
foreach $i (0 .. $#in) {
# Convert plus's to spaces
$in[$i] =~ s/\+/ /g;
# Convert %XX from hex numbers to alphanumeric
$in[$i] =~ s/%(..)/pack("c",hex($1))/ge;
# Split into key and value.
$loc = index($in[$i],"=");
$key = substr($in[$i],0,$loc);
$val = substr($in[$i],$loc+1);
#$in{$key} .= "\0" if (defined($in{$key})); # \0 is the multiple separator
#$in{$key} .= $val;
$in{$key} = $val;
}
return %in;
}
sub PrintHeader {
print "Content-type: text/html\n";
if ( defined $_[1]){
print "Pragma: no-cache\n";
}
print "\n";
}
sub GetRibDir { '/usr/local/rib/rib-1.0'; }
sub GetRibUrl { 'http://www.nhse.org/rib'; }
sub GetRibIindexPath { '/usr/local/rib/rib-1.0/bin'; }
sub GetRibIsearchCgiPath { '/usr/local/rib/rib-1.0/bin'; }
# extract the repository name from the current working directory.
# this method assumes that the current working directory is
# beneath &GetRibDir()."/cgi-bin/repositories/", which of
# course it should be if this method is expected to be useful.
sub GetRepoName {
my $dir = Cwd::cwd();
my $path_to = "/cgi-bin/admin/repositories/";
$dir =~ m|$path_to([^/]+)/?$|;
return $1;
# my $dir = Cwd::cwd();
# print "
Cwd $dir
" if $DEBUG;
# print " \$0 $0
" if $DEBUG;
# my $path_to = &GetRibDir() . "/cgi-bin/repositories/";
# #$dir =~ /^\Q$path_to\E(.+)/;
# $0 =~ /^\Q$path_to\E(.+)\/.+/;
# return $1;
}
#
# The policy for the file locking methods is simply this:
#
# if LockFile($file) returns true, then you have locked the file
#
# if LockFile($file) returns false, then you haven't locked the file
#
# UnlockFile($file) returns nothing, so you don't know if the
# unlock succeeded or not, but for simplicity you will assume it has.
#
# a file is locked if there is a filename called 'filename.lock'
#
# If available, the file is opened and created atomically. otherwise
# the file is opened and created in two steps.
#
# This policy is NOT 100% effective. The authors understand that
# a race condition can still arise in the presence of networked
# file systems. The authors also agreed NOT to use the flock()
# function (operator) since it is not implemented on ALL platforms.
#
#
# For both methods, $file is the absolute path to the file. '.lock'
# will be appended for the locking mechanism.
#
sub LockFile {
my ($self,$file,$time) = @_;
my $lock = "$file.lock";
my $times = (defined $time)? $time : 3 ;
my $flag = 0;
foreach ( 0..$times){
eval { $flag = sysopen(LOCK,$lock, O_WRONLY|O_EXCL|O_CREAT,0644); };
if ($@ or !$flag){
# Failed because either the system messed up, the system
# doesn't support sysopen with the Fcntl flags, or the lock
# file exists. To somewhat recover from the 'system messed
# up, or unsupported Fcntl flags', try to open the regular
# (but insecure) two-step way...
unless(-e $lock){
if (open(LOCK,"+>$lock")){
close LOCK; return 1;
}
}
} else {
close LOCK; return 1;
}
}
return 0;
}
sub UnlockFile {
my ($self,$file) = @_;
# We don't care if the next statement works or not. We'll
# let the RIB maintainer worry about removing flagrant lock
# files.
eval { unlink $file.'.lock' };
}
# InitNonLocal
#
# Locks the .nonlocal file for repository and initializes
# the nonlocal data structure.
#
# Will not call unlockfile, because that's a job for CommitNonLocal
#
# Any code between InitNonLocal and CommitNonLocal should be thought
# of as a critical section, so make computing short and sweet. Only
# do stuff like monkey with .nonlocal.
#
# If it succeeds
#
# $repo is the name of the repository, and $buf if defined is a reference
# to a scalar that will include the error message explaining why
# InitNonLocal failed.
sub InitNonLocal {
my ($self,$repo,$buf) = @_;
my $nonlocal = $self->GetRibDir ."/repositories/$repo/catalog/.nonlocal";
# return if we can't lock file
unless($self->LockFile($nonlocal)){ return 0; }
# If it already exists and has nonzero size, then there's
# already links in it. Open it, and initialize $self->{'nonlocal'}.
if(-e $nonlocal and -s $nonlocal){
# open read/write
unless(open(N,"+<$nonlocal")){
# open failed for some reason so give up the lock and return.
$self->UnlockFile($nonlocal);
return 0;
}
# Begin Block
{ local($/) = undef;
my $tmp = ;
no strict 'vars';
$self->{'nonlocal'} = eval "my $tmp";
if ($@){
close(N); # we haven't written to it yet, so it
# should be in tact.
$self->UnlockFile($nonlocal);
$self->ErrorMessage("An error occured while trying to eval"
." $nonlocal: $@. Please contact your RIB administrator!");
}
} # End Block
# Store file descriptor for later use.
$self->{'fd'} = \*N;
} else {
# NonLocal doesn't exist or is zero length. Create it and
# store descriptor
# for later use.
unless(open(N,"+>$nonlocal")){
$self->UnlockFile($nonlocal);
return 0;
}
$self->{'nonlocal'} = [];
$self->{'fd'} = \*N;
}
# Initialize other usefile stuff
$self->{'file'} = $nonlocal;
$self->{'repo'} = $repo;
$self->{'touched'} = 0; # flag to see if changed
return 1;
}
#
# NonLocalLink provides two tasks
#
# If called with no args it returns the array
# of hashes for each link, where the keys of
# the hashs are URL FILE and LM.
#
# If called with a url arg, then it returns 1
# if the url is in the list, and 0 if not.
#
sub NonLocalLink {
my ($self,$url) = @_;
if (defined $url and $url ne ''){
foreach ( @{$self->{'nonlocal'}} ){
return $_ if ($url eq ${_}->{URL});
#return 1 if ($url eq ${_}->{URL});
}
return 0;
} else {
return @{$self->{'nonlocal'}};
}
}
# Adds a link to the file nonlocal and creates
# a catalog entry for it.
#
# ARGS are $url
#
# this function also initializes a class variable
# cp.
#
# Nonlocal is actually a list of hashes
# and each hash has keys URL, LM, and FILE
# AddNonLocalLink only initializes URL and
# LM if available. Creating a filename will
# probably be left up to generate_catalog.pl
sub AddNonLocalLink {
my ($self,$url) = @_;
my $filepath = $self->GetRibDir . '/repositories/'
. $self->GetRepoName . '/catalog/Asset/';
return 0 unless ($url =~ m|^http:\/\/|);
my $ua = LWP::UserAgent->new("RIB/0.9.2");
my $req = HTTP::Request->new('GET',$url);
my $res = $ua->request($req);
if ($res->is_success){
# Create the catalog entry
my $bp = RIB::BIDMParser->new();
my $file;
if ($bp->parse($res->content)){
# Initialize ConfigParser for self
unless(exists $self->{'cp'}) {$self->InitCP;}
my $ce = $self->{'cp'}->InstanceOf($url,'Asset',$bp);
my $context = MD5->new ; $context->add($res->content);
$file = $context->hexdigest() . '.html';
if(open(F,">$filepath/$file")){
my $buf;
unless($ce->AsHtml(\$buf,$self->GetRepoName,$url,$self->{'cp'})){
$self->ErrorMessage("There was a problem loading $file.
"
. "Reason: ".$ce->ErrorMsg."
Please Contact your"
. " RIB administrator!");
}
print F $self->ClassHeader('Asset');
print F $buf;
print F $self->ClassFooter('Asset');
close(F);
} else {
$self->ErrorMessage("Could not open $file: Reason: $!
"
. "Please contact your RIB administrator!");
}
} else {
$self->ErrorMessage("There was a problem parsing the content"
. " of $url: Reason: ".$bp->ErrorMsg."
Pease contact your"
. " RIB administrator.\n");
}
my $lm = $res->header('Last-Modified');
push @{$self->{'nonlocal'}}, {
URL => $url,
LM => $lm,
FILE => $file };
$self->{'touched'} = 1;
} else {
return 0;
}
}
#
# UpdateNonLocal
#
# this method will update a catalog
# entry specified by a link in the nonlocal
# file. Since the filename of the catalog entry
# is the md5 digest of the meta data, it will have
# to be deleted and a new filename created. Of course
# the last modified date will be updated as well.
#
#
sub UpdateNonLocal {
my ($self,$link,$content,$lm,$a,$cp,$err) = @_;
my $filepath =
$self->GetRibDir.'/repositories/'.$self->GetRepoName.'/catalog/Asset';
my $file;
my $context = MD5->new ; $context->add($content);
$file = $context->hexdigest() . '.html';
if (open(NEW,">$filepath/$file")){
my $buf;
unless($a->AsHtml(\$buf,$self->GetRepoName,$link->{URL},$cp)){
$$err = 'Reason: '. $a->ErrorMsg;
return 0;
}
print NEW $self->ClassHeader('Asset');
print NEW $buf;
print NEW $self->ClassFooter('Asset');
close(NEW);
} else {
$$err = "Could not open $filepath/$file: Reason: $!";
return 0;
}
if ($link->{FILE} ne $file ){
my $tmp = $link->{FILE};
$link->{FILE} = $file;
if ($tmp ne "" && -e $tmp){
unless( unlink "$filepath/".$link->{FILE} ){
print 'Could not delete '. $link->{FILE}.": Reason: $!\n" .
'Please contact your RIB administrator!';
}
}
}
$link->{LM} = $lm;
$self->{'touched'} = 1;
return 1;
}
#This function was added to allow AddNonLocalLink
#to use it's own configparser
sub InitCP {
my $self = shift;
my $repo = $self->GetRepoName;
my $ribdir = $self->GetRibDir;
$self->{'cp'} = RIB::ConfigParser->new();
unless($self->{'cp'}->load_config("$ribdir/repositories/$repo/conf/BIDM.conf")){
$self->ErrorMessage("There is a problem with $repo\'s ".
"configuration file. Problem: " . $self->{'cp'}->ErrorMsg() . ". Please ".
"contact your RIB administrator");
}
}
sub RemoveNonLocalLink {
my ($self,$url) = @_;
my $offset = 0;
# go through the list of foreign urls to find $url
foreach ( $self->NonLocalLink ){
if ($url eq ${_}->{URL}){
# delete the catalog entry if file is present
if (defined ${_}->{FILE} and ${_}->{FILE} ne ''){
my $filepath = $self->GetRibDir
. "/repositories/" . $self->{'repo'};
unlink "$filepath/catalog/Asset/".${_}->{FILE};
unlink "$filepath/objects/Asset/".${_}->{FILE};
}
# now delete the array entry
splice(@{$self->{'nonlocal'}},$offset,1);
$self->{'touched'} = 1;
last;
}
$offset++;
}
}
# Print to $nonlocal,close it,unlock it, and return
sub CommitNonLocal {
my $self = shift;
if ($self->{'touched'}){
# Does the nonlocal file still have links in it
# index will be greater than -1
if ($#{$self->{'nonlocal'}} > -1 ){
$Data::Dumper::Indent = 0;
seek $self->{'fd'}, 0, 0;
truncate $self->{'fd'}, 0; # funny, we don't need the curlies here.
# Note the curlys. they are needed to return the right value
print {$self->{'fd'}} Data::Dumper::Dumper($self->{'nonlocal'});
} else {
# No more links, so unlink nonlocal
unless(unlink $self->{'file'}){
$self->ErrorMessage("Could not unlink ". $self->{'file'}
. " Reason: $!
.Please contact your RIB administrator.");
}
}
}
close($self->{'fd'}); # funny, we don't need the curlies here.
$self->UnlockFile($self->{'file'});
undef $self->{'nonlocal'};
undef $self->{'fd'};
undef $self->{'file'};
undef $self->{'repo'};
undef $self->{'touched'};
undef $self->{'cp'};
}
sub ClassHeader {
my ($self,$class,$repo) = @_;
my $assetheader;
unless (defined $repo){
$repo = &GetRepoName;
}
my $file = &GetRibDir . "/repositories/$repo/conf/$class.header";
if (-f $file and -s $file and open (H, "<$file")){
{ local($/) = undef; $assetheader = ; close(H); }
} else {
close(H);
$assetheader = "$class Located in "
. &GetRepoName ." Software Repository\n";
unless(open(H, "+>$file")){
$self->ErrorMessage("Couldn't open the file ""
. "$file". "
. "Reason: $!
Please contact your RIB "
. "administrator!");
}
print H $assetheader; close(H);
}
return $assetheader;
}
sub ClassFooter {
my ($self,$class,$repo) = @_;
my $assetfooter;
unless (defined $repo){
$repo = &GetRepoName;
}
my $file = &GetRibDir . "/repositories/$repo/conf/$class.footer";
if (-f $file and -s $file and open (H, "<$file")){
{ local($/) = undef; $assetfooter = ; close(H); }
} else {
close(H);
$assetfooter = "";
unless(open(H, "+>$file")){
$self->ErrorMessage("Couldn't open the file ""
. "$file". "
. "Reason: $!
Please contact your RIB "
. "administrator!");
}
print H $assetfooter; close(H);
}
return $assetfooter;
}
sub Date {
my $class = shift;
my $time = shift;
$time ||= time;
my ($sec,$min,$hour,$mday,$mon,$year,$wday) =
localtime($time);
my @num2mon = ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul",
"Aug", "Sep", "Oct", "Nov", "Dec");
my @num2wday = ("Sun", "Mon", "Tue", "Wed", "Thr", "Fri", "Sat");
# this will break after 100 years.
if ($year < 97) { $year = "20$year"; }
else {$year = "19$year";}
foreach (\$hour,\$min,\$sec) { $$_ = "0". $$_ if length $$_ == 1; }
return "$num2wday[$wday] $num2mon[$mon] $mday $hour:$min:$sec $year";
}
sub GetUserName {
my $class = shift;
return (getpwuid($<))[0];
}
sub InsertNewlines {
my $class = shift;
my $string = shift;
my $count = 0;
my @chars = split(//,$string);
my $newstring = '';
my $char;
foreach $char (@chars) {
if ((++$count > 50 and $char =~ /\s/) or ($char eq "\n")) {
$newstring .= "\n";
$count=0;
}
else {
$newstring .= $char;
}
}
return $newstring;
}
1;