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

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

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