#
# Library with definitions and common routines for MPIWG storage system
# scripts
#
package MPIWGStor;
use strict;
use vars qw(@ISA @EXPORT $VERSION
$debug %junk_files %index_files $index_file_perm $archived_index_file_perm
$file_perm);
use Exporter;
$VERSION = 0.6.3; # ROC 6.3.2007
@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 &park_file &unpark_file
&read_xml &write_xml &add_text_element &create_element_path &create_text_path);
# debug level
$debug = 0;
# junk files
%junk_files = (
# netatalk stuff
'.AppleDB' => '.AppleDB',
'.AppleDesktop' => '.AppleDesktop',
'.AppleDouble' => '.AppleDouble',
'.FBCIndex' => '.FBCIndex',
'.FBCLockFolder' => '.FBCLockFolder',
':2eTemporaryItems' => ':2eTemporaryItems',
':2eDS_Store' => ':2eDS_Store',
# standard appleshare stuff
'.DS_Store' => '.DS_Store',
'.TemporaryItems' => '.TemporaryItems',
'Network Trash Folder' => 'Network Trash Folder',
'TheVolumeSettingsFolder' => 'TheVolumeSettingsFolder',
# old appleshare software turds
'.HSResource' => '.HSResource',
'.HSancillary' => '.HSancillary',
'.HSicon' => '.HSicon'
);
# filenames to not delete (but archive)
%index_files = (
'index.meta' => 'index.meta',
'index.meta.old' => 'index.meta.old'
);
# default permissions for normal index files (rw-rw-r--)
$index_file_perm = 0664;
# default permissions for archived index files (rw-r--r--)
$archived_index_file_perm = 0644;
# default permissions for other files (rw-rw-r--)
$file_perm = 0664;
#
# $param_hash = parseargs;
#
# reads @ARGV and returns a hash with all options like "-option=value"
# and the last part of the string as "path"
#
sub parseargs {
my %opts;
foreach my $s (@ARGV) {
if ($s =~ /^-([^=]+)=*(.*)$/) {
$opts{$1} = ($2) ? $2 : $1;
} else {
$opts{'path'} = $s;
}
}
return \%opts;
}
#
# logger($level, $message)
#
# logs the $message (mostly to stdout)
#
sub logger {
my ($level, $message) = @_;
if ($debug || ($level ne "DEBUG")) {
print "$level: $message\n";
}
}
#
# $stime = stime($utime)
#
# format utime (seconds since epoch) into string
# representation: "YYYY/MM/DD HH:MM:SS"
#
sub stime {
my ($utime) = @_;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime($utime);
my $yy = $year + 1900;
my $mm = $mon + 1;
my $stime = sprintf("%d/%02d/%02d %02d:%02d:%02d",
$yy, $mm, $mday, $hour, $min, $sec);
return $stime;
}
#
# $stime = s2stime($stime2)
#
# format db-like time (2003-09-19 12:43:32+02) into string
# representation: "YYYY/MM/DD HH:MM:SS"
#
sub s2stime {
my ($s2time) = @_;
my $stime = "";
if ($s2time =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/) {
my ($year,$mon,$mday,$hour,$min,$sec) = ($1, $2, $3, $4, $5, $6);
$stime = sprintf("%d/%02d/%02d %02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
}
return $stime;
}
#
# $date = ymd_date($olddate)
#
# converts a date string in mm/dd/yy format to yyyy/mm/dd format
#
sub ymd_date {
my ($mdy) = @_;
my $ydm;
if ($mdy =~ /(\d+)\/(\d+)\/(\d+)/) {
my $m = $1;
my $d = $2;
my $y = $3;
# extend yy to yyyy
$y = ($y < 70) ? (2000 + $y) : (($y < 100) ? ($y + 1900) : $y);
$ydm = sprintf "%d/%02d/%02d", $y, $m, $d;
}
return $ydm;
}
#
# ($name, $path) = split_file_path($fn)
#
# splits the file path $fn into
# file name (the last path element) and path
#
sub split_file_path {
my ($fn, $nodot) = @_;
if ($fn =~ /^(.*)\/([^\/]+)$/) {
return ($2, $1);
}
# only file name
if ($nodot) {
return ($fn, '');
} else {
return ($fn, '.');
}
}
#
# $name = sstrip($name, $slash)
#
# strips leading and trailing whitespace from $name
# replaces double slashes with single ones with $slash.
#
sub sstrip {
my ($name, $slash) = @_;
if ($name =~ /^\s*(.*?)\s*$/) {
$name = $1;
}
if ($slash) {
# trim multiple slashes
$name =~ s/\/+/\//g;
}
return $name;
}
#
# $valid = valid_file_name($name)
#
# checks if $name is a valid file name
#
sub valid_file_name {
return valid_name($_[0], 0);
}
#
# $valid = valid_dir_name($name)
#
# checks if $name is a valid directory name
#
sub valid_dir_name {
return valid_name($_[0], 1);
}
#
# $valid = valid_name($name, $mode)
#
# checks if $name is a valid file ($mode=0) or directory name (mode=1)
#
sub valid_name {
my ($name, $mode) = @_;
# whitespace?
if ($name =~ /\s+/) {
return 0;
}
# invalid characters
if ($name !~ /^[-\w.\/]+$/) {
return 0;
}
# files have extension
if ($mode == 0) {
if ($name !~ /\.[-\w]+$/) {
return 0;
}
}
return 1;
}
#
# $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
# returns root node element
#
sub read_xml {
my ($file) = @_;
my $document;
my $parser = XML::LibXML->new();
if (! $parser) {
logger("ABORT", "unable to create parser for metadata index file!!");
exit 1;
}
logger("DEBUG", "index file: $file");
eval { $document = $parser->parse_file($file) };
# catch parsing errors
if ($@) {
logger("ABORT", "XML syntax error in file $file!!");
exit 1;
}
my $rootnode = $document->documentElement;
logger("DEBUG", "root element: \'" . $rootnode->nodeName . "\'");
return ($document, $rootnode);
}
#
# write_xml($document, $file)
#
# saves the XML tree of $document to the file $file
#
sub write_xml {
my ($document, $filename) = @_;
# keep backup copy
if (-f $filename) {
if (! rename $filename, "$filename.old") {
logger("ABORT", "unable to change file $filename!");
exit 1;
}
}
# write new file
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 {
logger("ABORT", "unable to write file $filename!");
exit 1;
}
}
#
# $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;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>