--- foxridge-archiver/MPIWGStor.pm	2004/06/17 15:58:42	1.1
+++ foxridge-archiver/MPIWGStor.pm	2006/06/12 17:01:39	1.7
@@ -1,4 +1,3 @@
-#!/usr/local/bin/perl -w
 
 #
 # Library with definitions and common routines for MPIWG storage system
@@ -13,14 +12,15 @@ use vars qw(@ISA @EXPORT $VERSION
 	    $file_perm);
 use Exporter;
 
-$VERSION = 0.3; #  ROC 24.9.2003
+$VERSION = 0.6.2; #  ROC 10.2.2006
 
 @ISA = qw(Exporter);
 
 @EXPORT = qw($debug %junk_files %index_files $index_file_perm $archived_index_file_perm 
 	     $file_perm
 	     &parseargs &logger &stime  &s2stime &ymd_date &split_file_path &sstrip 
-	     &valid_file_name &valid_dir_name &read_xml &write_xml);
+	     &valid_file_name &valid_dir_name &park_file &unpark_file
+             &read_xml &write_xml &add_text_element &create_element_path &create_text_path);
 
 # debug level
 $debug = 0;
@@ -140,25 +140,35 @@ sub ymd_date {
 # file name (the last path element) and path
 #
 sub split_file_path {
-    my ($fn) = @_;
+    my ($fn, $nodot) = @_;
 
     if ($fn =~ /^(.*)\/([^\/]+)$/) {
         return ($2, $1);
+    } 
+    # only file name
+    if ($nodot) {
+	return ($fn, '');
+    } else {
+	return ($fn, '.');
     }
-    return $fn;
 }
 
 
 #
-# $name = sstrip($name)
+# $name = sstrip($name, $slash)
 #
 # strips leading and trailing whitespace from $name
+# replaces double slashes with single ones with $slash.
 #
 sub sstrip {
-    my ($name) = @_;
+    my ($name, $slash) = @_;
     
-    if ($name =~ /\s*(.*)\s*/) {
-	return $1;
+    if ($name =~ /^\s*(.*?)\s*$/) {
+	$name = $1;
+    }
+    if ($slash) {
+	# trim multiple slashes
+	$name =~ s/\/+/\//g;
     }
     return $name;
 }
@@ -211,6 +221,44 @@ sub valid_name {
 
 
 #
+# $newfilename = park_file($filename)
+#
+# parks a file under a new name (*.bak)
+#
+sub park_file {
+    my ($filename) = @_;
+    my $newfn = "";
+    if (-f $filename) {
+	$newfn = "$filename.bak";
+	if (! rename $filename, $newfn) {
+	    logger("ABORT", "unable to rename file $filename!");
+	    exit 1;
+	}
+    }
+    return $newfn;
+}
+    
+#
+# $filename = unpark_file($filename)
+#
+# unparks a file
+#
+sub unpark_file {
+    my ($filename) = @_;
+    my $newfn = "$filename.bak";
+    if (-f $newfn) {
+	if (! rename $newfn, $filename) {
+	    logger("ABORT", "unable to rename file $newfn!");
+	    exit 1;
+	}
+	return $filename;
+    }
+    return "";
+}
+    
+
+
+#
 # ($document, $rootnode) = read_xml($file)
 #
 # reads xml meta file $file
@@ -226,15 +274,15 @@ sub read_xml {
 	exit 1;
     }
 
-    logger("INFO", "index file: $file");
+    logger("DEBUG", "index file: $file");
     eval { $document = $parser->parse_file($file) };
     # catch parsing errors
     if ($@) {
-	logger("ABORT", "XML syntax error in index file!!");
+	logger("ABORT", "XML syntax error in file $file!!");
 	exit 1;
     }
     my $rootnode = $document->documentElement;
-    logger("INFO", "root element: \'" . $rootnode->nodeName . "\'");
+    logger("DEBUG", "root element: \'" . $rootnode->nodeName . "\'");
 
     return ($document, $rootnode);
 }
@@ -255,7 +303,8 @@ sub write_xml {
 	}
     }
     # write new file
-    if ($document->toFile($filename)) {
+    my ($fn, $dir) = split_file_path($filename);
+    if (-d $dir && $document->toFile($filename)) {
 	logger("INFO", "written new file $filename");
 	chmod $index_file_perm, $filename;
     } else {
@@ -264,6 +313,71 @@ sub write_xml {
     }
 }
 
+#
+# $elem = add_text_element($node, $name, $value, $namespace)
+#
+# creates an XML element with the name $name and the text content
+# $value attached to the node $node and returns it.
+#
+sub add_text_element {
+    my ($node, $name, $value, $namespace) = @_;
+
+    my $doc = $node->ownerDocument;
+    my $text = $doc->createTextNode($value);
+    my $newnode = $node->addNewChild($namespace, $name);
+    $newnode->addChild($text);
+
+    return $newnode;
+}
+
+#
+# $elem = create_element_path($path, $root, $namespace)
+#
+# creates and returns a DOM element at the given path from the 
+# given root. path is e.g. meta/bib@type=book. elements are separated
+# by /, an additional attribute can be specified after the @.
+#
+sub create_element_path {
+    my ($path, $root, $namespace) = @_;
+    my $attribute = "";
+    # get attribute
+    if ($path =~ /^(.+)@(.+)$/) {
+	$attribute = $2;
+	$path = $1;
+    }
+    my $point = $root;
+    for my $p (split /\//, $path) {
+	# check if the next path element exists
+	my $n = ($point->findnodes($p))[0];
+	if ($n) {
+	    $point = $n;
+	} else {
+	    # create if it doesn't exist
+	    $point = $point->addNewChild($namespace, $p);
+	}
+    }
+    # add the attribute
+    if ($attribute) {
+	my $dom = $root->getOwner();
+	my ($attkey, $attval) = split /=/, $attribute; #/ silly fontlock...
+	$point->addChild($dom->createAttributeNS($namespace, $attkey, $attval));
+    }
+    return $point;
+}
+
+#
+# $elem = create_text_path($path, $text, $root, $namespace)
+#
+# creates and returns a DOM text element with the given content at the
+# given path from the given root.
+#
+sub create_text_path {
+    my ($path, $text, $root, $namespace) = @_;
+    my $elem = create_element_path($path, $root, $namespace)->appendTextNode($text);
+    return $elem;
+}
+
+
 
 # module init
 return 1;