Annotation of foxridge-archiver/MPIWGStor.pm, revision 1.7

1.1       casties     1: 
                      2: #
                      3: # Library with definitions and common routines for MPIWG storage system
                      4: # scripts
                      5: #
                      6: 
                      7: package MPIWGStor;
                      8: 
                      9: use strict;
                     10: use vars qw(@ISA @EXPORT $VERSION
                     11:        $debug %junk_files %index_files $index_file_perm $archived_index_file_perm 
                     12:        $file_perm);
                     13: use Exporter;
                     14: 
1.6       casties    15: $VERSION = 0.6.2; #  ROC 10.2.2006
1.1       casties    16: 
                     17: @ISA = qw(Exporter);
                     18: 
                     19: @EXPORT = qw($debug %junk_files %index_files $index_file_perm $archived_index_file_perm 
                     20:         $file_perm
                     21:         &parseargs &logger &stime  &s2stime &ymd_date &split_file_path &sstrip 
1.3       casties    22:         &valid_file_name &valid_dir_name &park_file &unpark_file
                     23:              &read_xml &write_xml &add_text_element &create_element_path &create_text_path);
1.1       casties    24: 
                     25: # debug level
                     26: $debug = 0;
                     27: 
                     28: # junk files
                     29: %junk_files = (
                     30:          '.HSResource' => '.HSResource',
                     31:          '.HSancillary' => '.HSancillary',
                     32:          '.HSicon' => '.HSicon',
                     33:          'Network Trash Folder' => 'Network Trash Folder',
                     34:          'TheVolumeSettingsFolder' => 'TheVolumeSettingsFolder',
                     35:          '.DS_Store' => '.DS_Store'
                     36:          );
                     37: 
                     38: # filenames to not delete (but archive)
                     39: %index_files = ( 
                     40:             'index.meta' => 'index.meta',
                     41:             'index.meta.old' => 'index.meta.old'
                     42:             );
                     43: 
                     44: # default permissions for normal index files (rw-rw-r--)
                     45: $index_file_perm = 0664;
                     46: # default permissions for archived index files (rw-r--r--)
                     47: $archived_index_file_perm = 0644;
                     48: # default permissions for other files (rw-rw-r--)
                     49: $file_perm = 0664;
                     50: 
                     51: 
                     52: #
                     53: # $param_hash = parseargs;
                     54: #
                     55: # reads @ARGV and returns a hash with all options like "-option=value"
                     56: # and the last part of the string as "path"
                     57: #
                     58: sub parseargs {
                     59:     my %opts;
                     60:     foreach my $s (@ARGV) {
                     61:    if ($s =~ /^-([^=]+)=*(.*)$/) {
                     62:        $opts{$1} = ($2) ? $2 : $1;
                     63:    } else {
                     64:        $opts{'path'} = $s;
                     65:    }
                     66:     }
                     67:     return \%opts;
                     68: }
                     69: 
                     70: 
                     71: #
                     72: # logger($level, $message)
                     73: #
                     74: # logs the $message (mostly to stdout)
                     75: #
                     76: sub logger {
                     77:     my ($level, $message) = @_;
                     78:     if ($debug || ($level ne "DEBUG")) {
                     79:    print "$level: $message\n";
                     80:     }
                     81: }
                     82: 
                     83: #
                     84: # $stime = stime($utime)
                     85: #
                     86: # format utime (seconds since epoch) into string 
                     87: # representation: "YYYY/MM/DD HH:MM:SS"
                     88: #
                     89: sub stime {
                     90:     my ($utime) = @_;
                     91:     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
                     92:    localtime($utime);
                     93:     my $yy = $year + 1900;
                     94:     my $mm = $mon + 1;
                     95:     my $stime = sprintf("%d/%02d/%02d %02d:%02d:%02d", 
                     96:            $yy, $mm, $mday, $hour, $min, $sec);
                     97:     return $stime;
                     98: }
                     99: 
                    100: #
                    101: # $stime = s2stime($stime2)
                    102: #
                    103: # format db-like time (2003-09-19 12:43:32+02) into string 
                    104: # representation: "YYYY/MM/DD HH:MM:SS"
                    105: #
                    106: sub s2stime {
                    107:     my ($s2time) = @_;
                    108:     my $stime = "";
                    109:     if ($s2time =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/) {
                    110:    my ($year,$mon,$mday,$hour,$min,$sec) = ($1, $2, $3, $4, $5, $6);
                    111:    $stime = sprintf("%d/%02d/%02d %02d:%02d:%02d", 
                    112:            $year, $mon, $mday, $hour, $min, $sec);
                    113:     }
                    114:     return $stime;
                    115: }
                    116: 
                    117: #
                    118: # $date = ymd_date($olddate)
                    119: #
                    120: # converts a date string in mm/dd/yy format to yyyy/mm/dd format
                    121: #
                    122: sub ymd_date {
                    123:     my ($mdy) = @_;
                    124:     my $ydm;
                    125:     if ($mdy =~ /(\d+)\/(\d+)\/(\d+)/) {
                    126:    my $m = $1;
                    127:    my $d = $2;
                    128:    my $y = $3;
                    129:    # extend yy to yyyy
                    130:    $y = ($y < 70) ? (2000 + $y) : (($y < 100) ? ($y + 1900) : $y);
                    131:    $ydm = sprintf "%d/%02d/%02d", $y, $m, $d;
                    132:     }
                    133:     return $ydm;
                    134: }
                    135: 
                    136: #
                    137: # ($name, $path) = split_file_path($fn)
                    138: #
                    139: # splits the file path $fn into
                    140: # file name (the last path element) and path
                    141: #
                    142: sub split_file_path {
1.5       casties   143:     my ($fn, $nodot) = @_;
1.1       casties   144: 
                    145:     if ($fn =~ /^(.*)\/([^\/]+)$/) {
                    146:         return ($2, $1);
1.5       casties   147:     } 
                    148:     # only file name
                    149:     if ($nodot) {
                    150:    return ($fn, '');
                    151:     } else {
                    152:    return ($fn, '.');
1.1       casties   153:     }
                    154: }
                    155: 
                    156: 
                    157: #
1.7     ! casties   158: # $name = sstrip($name, $slash)
1.1       casties   159: #
                    160: # strips leading and trailing whitespace from $name
1.7     ! casties   161: # replaces double slashes with single ones with $slash.
1.1       casties   162: #
                    163: sub sstrip {
1.7     ! casties   164:     my ($name, $slash) = @_;
1.1       casties   165:     
1.6       casties   166:     if ($name =~ /^\s*(.*?)\s*$/) {
1.7     ! casties   167:    $name = $1;
        !           168:     }
        !           169:     if ($slash) {
        !           170:    # trim multiple slashes
        !           171:    $name =~ s/\/+/\//g;
1.1       casties   172:     }
                    173:     return $name;
                    174: }
                    175: 
                    176: 
                    177: #
                    178: # $valid = valid_file_name($name)
                    179: #
                    180: # checks if $name is a valid file name
                    181: #
                    182: sub valid_file_name {
                    183:     return valid_name($_[0], 0);
                    184: }
                    185: 
                    186: 
                    187: #
                    188: # $valid = valid_dir_name($name)
                    189: #
                    190: # checks if $name is a valid directory name
                    191: #
                    192: sub valid_dir_name {
                    193:     return valid_name($_[0], 1);
                    194: }
                    195: 
                    196: 
                    197: #
                    198: # $valid = valid_name($name, $mode)
                    199: #
                    200: # checks if $name is a valid file ($mode=0) or directory name (mode=1)
                    201: #
                    202: sub valid_name {
                    203:     my ($name, $mode) = @_;
                    204: 
                    205:     # whitespace?
                    206:     if ($name =~ /\s+/) {
                    207:    return 0;
                    208:     }
                    209:     # invalid characters
                    210:     if ($name !~ /^[-\w.\/]+$/) {
                    211:    return 0;
                    212:     }
                    213:     # files have extension
                    214:     if ($mode == 0) {
                    215:    if ($name !~ /\.[-\w]+$/) {
                    216:        return 0;
                    217:    }
                    218:     }
                    219:     return 1;
                    220: }
1.2       casties   221: 
                    222: 
                    223: #
                    224: # $newfilename = park_file($filename)
                    225: #
                    226: # parks a file under a new name (*.bak)
                    227: #
                    228: sub park_file {
                    229:     my ($filename) = @_;
                    230:     my $newfn = "";
                    231:     if (-f $filename) {
                    232:    $newfn = "$filename.bak";
                    233:    if (! rename $filename, $newfn) {
                    234:        logger("ABORT", "unable to rename file $filename!");
                    235:        exit 1;
                    236:    }
                    237:     }
                    238:     return $newfn;
                    239: }
                    240:     
                    241: #
                    242: # $filename = unpark_file($filename)
                    243: #
                    244: # unparks a file
                    245: #
                    246: sub unpark_file {
                    247:     my ($filename) = @_;
                    248:     my $newfn = "$filename.bak";
                    249:     if (-f $newfn) {
                    250:    if (! rename $newfn, $filename) {
                    251:        logger("ABORT", "unable to rename file $newfn!");
                    252:        exit 1;
                    253:    }
                    254:    return $filename;
                    255:     }
                    256:     return "";
                    257: }
                    258:     
1.1       casties   259: 
                    260: 
                    261: #
                    262: # ($document, $rootnode) = read_xml($file)
                    263: #
                    264: # reads xml meta file $file
                    265: # returns root node element
                    266: #
                    267: sub read_xml {
                    268:     my ($file) = @_;
                    269:     my $document;
                    270: 
                    271:     my $parser = XML::LibXML->new();
                    272:     if (! $parser) {
                    273:    logger("ABORT", "unable to create parser for metadata index file!!");
                    274:    exit 1;
                    275:     }
                    276: 
1.3       casties   277:     logger("DEBUG", "index file: $file");
1.1       casties   278:     eval { $document = $parser->parse_file($file) };
                    279:     # catch parsing errors
                    280:     if ($@) {
1.3       casties   281:    logger("ABORT", "XML syntax error in file $file!!");
1.1       casties   282:    exit 1;
                    283:     }
                    284:     my $rootnode = $document->documentElement;
1.3       casties   285:     logger("DEBUG", "root element: \'" . $rootnode->nodeName . "\'");
1.1       casties   286: 
                    287:     return ($document, $rootnode);
                    288: }
                    289: 
                    290: 
                    291: #
                    292: # write_xml($document, $file)
                    293: #
                    294: # saves the XML tree of $document to the file $file
                    295: #
                    296: sub write_xml {
                    297:     my ($document, $filename) = @_;
                    298:     # keep backup copy
                    299:     if (-f $filename) {
                    300:    if (! rename $filename, "$filename.old") {
                    301:        logger("ABORT", "unable to change file $filename!");
                    302:        exit 1;
                    303:    }
                    304:     }
                    305:     # write new file
1.3       casties   306:     my ($fn, $dir) = split_file_path($filename);
                    307:     if (-d $dir && $document->toFile($filename)) {
1.1       casties   308:    logger("INFO", "written new file $filename");
                    309:    chmod $index_file_perm, $filename;
                    310:     } else {
                    311:    logger("ABORT", "unable to write file $filename!");
                    312:    exit 1;
                    313:     }
                    314: }
1.3       casties   315: 
                    316: #
                    317: # $elem = add_text_element($node, $name, $value, $namespace)
                    318: #
                    319: # creates an XML element with the name $name and the text content
                    320: # $value attached to the node $node and returns it.
                    321: #
                    322: sub add_text_element {
                    323:     my ($node, $name, $value, $namespace) = @_;
                    324: 
                    325:     my $doc = $node->ownerDocument;
                    326:     my $text = $doc->createTextNode($value);
                    327:     my $newnode = $node->addNewChild($namespace, $name);
                    328:     $newnode->addChild($text);
                    329: 
                    330:     return $newnode;
                    331: }
                    332: 
                    333: #
                    334: # $elem = create_element_path($path, $root, $namespace)
                    335: #
                    336: # creates and returns a DOM element at the given path from the 
                    337: # given root. path is e.g. meta/bib@type=book. elements are separated
                    338: # by /, an additional attribute can be specified after the @.
                    339: #
                    340: sub create_element_path {
                    341:     my ($path, $root, $namespace) = @_;
                    342:     my $attribute = "";
                    343:     # get attribute
                    344:     if ($path =~ /^(.+)@(.+)$/) {
                    345:    $attribute = $2;
                    346:    $path = $1;
                    347:     }
                    348:     my $point = $root;
                    349:     for my $p (split /\//, $path) {
                    350:    # check if the next path element exists
                    351:    my $n = ($point->findnodes($p))[0];
                    352:    if ($n) {
                    353:        $point = $n;
                    354:    } else {
                    355:        # create if it doesn't exist
                    356:        $point = $point->addNewChild($namespace, $p);
                    357:    }
                    358:     }
                    359:     # add the attribute
                    360:     if ($attribute) {
                    361:    my $dom = $root->getOwner();
                    362:    my ($attkey, $attval) = split /=/, $attribute; #/ silly fontlock...
                    363:    $point->addChild($dom->createAttributeNS($namespace, $attkey, $attval));
                    364:     }
                    365:     return $point;
                    366: }
                    367: 
                    368: #
                    369: # $elem = create_text_path($path, $text, $root, $namespace)
                    370: #
                    371: # creates and returns a DOM text element with the given content at the
                    372: # given path from the given root.
                    373: #
                    374: sub create_text_path {
                    375:     my ($path, $text, $root, $namespace) = @_;
                    376:     my $elem = create_element_path($path, $root, $namespace)->appendTextNode($text);
                    377:     return $elem;
                    378: }
                    379: 
1.1       casties   380: 
                    381: 
                    382: # module init
                    383: return 1;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>