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>
![[BACK]](/cvs/cvsweb/icons/back.gif){kind=icon}
Return to MPIWGStor.pm CVS log ![[TXT]](/cvs/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvs/cvsweb/icons/dir.gif){kind=icon}
Up to [Repository] / foxridge-archiver