1 # This file was automatically generated by SWIG (http://www.swig.org).
4 # Do not make changes to this file unless you know what you are doing--modify
5 # the SWIG interface file instead.
9 use base qw(DynaLoader);
10 package Amanda::Utilc;
11 bootstrap Amanda::Util;
15 # ---------- BASE METHODS -------------
20 my ($classname,$obj) = @_;
21 return bless $obj, $classname;
31 my ($self,$field) = @_;
32 my $member_func = "swig_${field}_get";
33 $self->$member_func();
37 my ($self,$field,$newval) = @_;
38 my $member_func = "swig_${field}_set";
39 $self->$member_func($newval);
48 # ------- FUNCTION WRAPPERS --------
52 *get_original_cwd = *Amanda::Utilc::get_original_cwd;
53 *hexencode = *Amanda::Utilc::hexencode;
54 *hexdecode = *Amanda::Utilc::hexdecode;
55 *sanitise_filename = *Amanda::Utilc::sanitise_filename;
56 *quote_string = *Amanda::Utilc::quote_string;
57 *unquote_string = *Amanda::Utilc::unquote_string;
58 *expand_braced_alternates = *Amanda::Utilc::expand_braced_alternates;
59 *collapse_braced_alternates = *Amanda::Utilc::collapse_braced_alternates;
60 *split_quoted_strings = *Amanda::Utilc::split_quoted_strings;
61 *get_fs_usage = *Amanda::Utilc::get_fs_usage;
62 *fsync = *Amanda::Utilc::fsync;
63 *set_blocking = *Amanda::Utilc::set_blocking;
64 *weaken_ref = *Amanda::Utilc::weaken_ref;
65 *gettimeofday = *Amanda::Utilc::gettimeofday;
66 *openbsd_fd_inform = *Amanda::Utilc::openbsd_fd_inform;
67 *stream_server = *Amanda::Utilc::stream_server;
68 *stream_accept = *Amanda::Utilc::stream_accept;
69 *check_security = *Amanda::Utilc::check_security;
70 *set_pname = *Amanda::Utilc::set_pname;
71 *get_pname = *Amanda::Utilc::get_pname;
72 *set_ptype = *Amanda::Utilc::set_ptype;
73 *get_ptype = *Amanda::Utilc::get_ptype;
74 *set_pcontext = *Amanda::Utilc::set_pcontext;
75 *get_pcontext = *Amanda::Utilc::get_pcontext;
76 *safe_cd = *Amanda::Utilc::safe_cd;
77 *check_running_as = *Amanda::Utilc::check_running_as;
79 ############# Class : Amanda::Util::file_lock ##############
81 package Amanda::Util::file_lock;
82 use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);
83 @ISA = qw( Amanda::Util );
88 my $self = Amanda::Utilc::new_file_lock(@_);
89 bless $self, $pkg if defined($self);
92 *lock = *Amanda::Utilc::file_lock_lock;
93 *unlock = *Amanda::Utilc::file_lock_unlock;
94 *write = *Amanda::Utilc::file_lock_write;
95 *data = *Amanda::Utilc::file_lock_data;
97 return unless $_[0]->isa('HASH');
98 my $self = tied(%{$_[0]});
99 return unless defined $self;
100 delete $ITERATORS{$self};
101 if (exists $OWNER{$self}) {
102 Amanda::Utilc::delete_file_lock($self);
103 delete $OWNER{$self};
109 my $ptr = tied(%$self);
115 my $ptr = tied(%$self);
120 # ------- VARIABLE STUBS --------
122 package Amanda::Util;
124 *RUNNING_AS_ANY = *Amanda::Utilc::RUNNING_AS_ANY;
125 *RUNNING_AS_ROOT = *Amanda::Utilc::RUNNING_AS_ROOT;
126 *RUNNING_AS_DUMPUSER = *Amanda::Utilc::RUNNING_AS_DUMPUSER;
127 *RUNNING_AS_DUMPUSER_PREFERRED = *Amanda::Utilc::RUNNING_AS_DUMPUSER_PREFERRED;
128 *RUNNING_AS_CLIENT_LOGIN = *Amanda::Utilc::RUNNING_AS_CLIENT_LOGIN;
129 *RUNNING_AS_UID_ONLY = *Amanda::Utilc::RUNNING_AS_UID_ONLY;
130 *CONTEXT_DEFAULT = *Amanda::Utilc::CONTEXT_DEFAULT;
131 *CONTEXT_CMDLINE = *Amanda::Utilc::CONTEXT_CMDLINE;
132 *CONTEXT_DAEMON = *Amanda::Utilc::CONTEXT_DAEMON;
133 *CONTEXT_SCRIPTUTIL = *Amanda::Utilc::CONTEXT_SCRIPTUTIL;
134 *AF_INET = *Amanda::Utilc::AF_INET;
135 *STREAM_BUFSIZE = *Amanda::Utilc::STREAM_BUFSIZE;
143 Amanda::Util - Runtime support for Amanda applications
145 =head1 Application Initialization
147 Application initialization generally looks like this:
149 use Amanda::Config qw( :init );
150 use Amanda::Util qw( :constants );
153 Amanda::Util::setup_application("myapp", "server", $CONTEXT_CMDLINE);
154 # .. command-line processing ..
155 Amanda::Config::config_init(...);
156 Amanda::Util::finish_setup($RUNNING_AS_DUMPUSER);
158 Amanda::Util::finish_application();
162 =item setup_application($name, $type, $context)
164 Set up the operating environment for an application, without requiring
167 C<$name> is the name of the application, used in log messages, etc.
168 C<$type> is usualy one of "server" or "client". It specifies the
169 subdirectory in which debug logfiles will be created. C<$context>
170 indicates the usual manner in which this application is invoked; one
171 of C<$CONTEXT_CMDLINE> for a user-invoked command-line utility (e.g.,
172 C<amadmin>) which should send human-readable error messages to stderr;
173 C<$CONTEXT_DAEMON> for a program started by C<amandad>, e.g.,
174 C<sendbackup>; or C<$CONTEXT_SCRIPTUTIL> for a small program used from
175 shell scripts, e.g., C<amgetconf>
177 Based on C<$type> and C<$context>, this function does the following:
183 sets up debug logging;
187 configures internationalization
195 sets the current working directory to the debug or temporary
200 closes any unnecessary file descriptors as a security meaasure;
204 ignores C<SIGPIPE>; and
208 sets the appropriate target for error messages.
212 =item finish_setup($running_as_flags)
214 Perform final initialization tasks that require a loaded
215 configuration. Specifically, move the debug log into a
216 configuration-specific subdirectory, and check that the current userid
217 is appropriate for this applciation.
219 The user is specified by one of the following flags, which are
220 available in export tag C<:check_running_as_flags>:
222 $RUNNING_AS_ANY # any user is OK
223 $RUNNING_AS_ROOT # root
224 $RUNNING_AS_DUMPUSER # dumpuser, from configuration
225 $RUNNING_AS_DUMPUSER_PREFERRED # dumpuser, but client_login is OK too
226 $RUNNING_AS_CLIENT_LOGIN # client_login (--with-user at build time)
228 If the flag C<$RUNNING_AS_UID_ONLY> is bit-or'd into
229 C<$running_as_flags>, then the euid is ignored; this is used for
230 programs that expect to be setuid-root.
232 =item finish_application()
234 Remove old debug files.
235 All applications should call this before exiting.
237 =item get_original_cwd()
239 Return the original current directory with C<get_original_cwd>.
243 Print the version and exit. This is intended to be used in C<GetOptions> invocations, e.g.,
247 'version' => \&Amanda::Util::version_opt,
254 These functions read and write the entire requested size to a file
255 descriptor, even if the underlying syscall returns early. Note that
256 they do not operate on Perl file handles.
258 If fewer than C<$size> bytes are written, C<full_write> returns the
259 number of bytes actually written and sets C<$!> appropriately. When
260 reading, if fewer than C<$size> bytes are read due to a normal EOF,
261 then C<$!> is zero; otherwise, it contains the appropriate error
264 Unlike C<POSIX::read>, C<full_read> returns a scalar containing the
265 bytes it read from the file descriptor.
269 =item full_read($fd, $size)
271 =item full_write($fd, $buf, $size)
275 =head1 Miscellaneous Utilities
281 Return a "safe" environment hash. For non-setuid programs, this means
282 filtering out any localization variables.
284 =item get_fs_usage(file, disk)
286 This is a wrapper around the Gnulib function of the same name. On success, it returns
289 blocksize Size of a block
290 blocks Total blocks on disk
291 bfree Free blocks available to superuser
292 bavail Free blocks available to non-superuser
293 bavail_top_bit_set 1 if fsu_bavail represents a value < 0
294 files Total file nodes
295 ffree Free file nodes
297 On failure, it returns nothing, and C<$!> should be set. If C<$!> is 0, then
298 this is a system which cannot measure usage without a C<disk> argument, which
299 this wrapper does not support.
301 =item is_pid_alive(pid)
303 Return 1 is the process with that pid is still alive.
305 =item weaken_ref($ref)
307 This is exactly the same as C<Scalar::Util::weaken>, but available in all
308 supported versions of perl.
312 Return the number of microseconds since the UNIX epoch.
316 Invoke the C<fsync> syscall.
318 =item set_blocking($fd, $blocking)
320 Set or clear the C<O_NONBLOCK> fd flag on $fd; returns a negative value on
321 failure, or 0 on success.
323 =item openbsd_fd_inform()
325 Due to a particularly poor user-space implementation of threading on OpenBSD,
326 executables that are run with nonstandard file descriptors open (fd > 2) find
327 those descriptors to be in a nonblocking state. This particularly affects
328 amandad services, which begin with several file descriptors in the 50's open.
330 This function "informs" the C library about these descriptors by making an
331 C<fcntl(fd, F_GETFL)> call. This is otherwise harmless, and is only perfomed
334 =item built_with_component($comp)
336 Returns true if Amanda was built with the given component. Component names are
337 in C<config/amanda/components.m4>.
343 These are thin wrappers over functions in C<common-src/stream.h> and other related
350 my $family = $Amanda::Util::AF_INET;
351 my $bufsize = $Amanda::Util::STREAM_BUFSIZE;
352 my ($listensock, $port) = Amanda::Util::stream_server(
353 $family, $bufsize, $bufsize, $priv);
355 This function creates a new socket and binds it to a port, returning both the
356 socket and port. If the socket is -1, then an error occurred and is available
357 in C<$!>. The constants C<$AF_INET> and C<$STREAM_BUFSIZE> are universally
358 used when calling this function. If the final argument, C<$priv>, is true,
359 then a the function opens a privileged port (below 1024).
363 my $sock = Amanda::Util::stream_accept(
364 $listen_sock, $timeout, $bufsize, $bufsize);
366 This function accepts a connection on a listening socket. If the connection is
367 not made within C<$timeout> seconds, or some other error occurs, then the
368 function returns -1. The bufsize arguments are applied to the new socket.
372 my $ok = Amanda::Util::check_security($socket, $userstr);
374 This function takes a socket descriptor and a string of the form C<"USER foo">
375 and performs BSD-style checks on that descriptor. These include verifying
376 round-trip DNS sanity; check that the user is in C<.rhosts> or C<.amandahosts>,
377 and checking that the remote port is reserved. Returns an error string on
378 error, or C<undef> on success.
382 =head1 String Utilities
386 =item quote_string($str)
388 Quote a string using Amanda's quoting algorithm. Strings with no
389 whitespace, control, or quote characters are returned unchanged. An
390 empty string is represented as the two-character string C<"">.
391 Otherwise, tab, newline, carriage return, form-feed, backslash, and
392 double-quote (C<">) characters are escaped with a backslash and the
393 string is surrounded by double quotes.
395 =item unquote_string($str)
397 Unquote a string as quoted with C<quote_string>.
399 =item skip_quoted_string($str)
401 my($q, $remaider) = skip_quoted_string($str)
403 Return the first quoted string and the remainder of the string.
405 =item C<split_quoted_strings($str)>
407 Split string on unquoted whitespace. Multiple consecutive spaces are not
408 collapsed into a single space: C<"x y"> (with two spaces) parses as C<( "x",
409 "", "y")>. The strings are unquoted before they are returned. An empty string
410 is split into C<( "" )>.
412 All of these quoting-related functions are available under the export
415 =item hexencode($str)
417 Encode a string using URI-style hexadecimal encoding.
418 Non-alphanumeric characters will be replaced with "%xx"
419 where "xx" is the two-digit hexadecimal representation of the character.
421 =item hexdecode($str)
423 Decode a string using URI-style hexadecimal encoding.
425 Both C<hexencode> and C<hexdecode> are available under the export tag C<:encoding>
427 =item expand_braced_alternates($str)
428 =item collapse_braced_alternates(\@list)
430 These two functions handle "braced alternates", which is a syntax
431 borrowed, partially, from shells. Comma-separated strings enclosed in
432 curly braces expand into multiple alternatives for the entire string.
435 "{foo,bar,bat}" [ "foo", "bar", "bat" ]
436 "foo{1,2}bar" [ "foo1bar", "foo2bar" ]
437 "foo{1\,2,3}bar" [ "foo1,2bar", "foo3bar" ]
438 "{a,b}-{1,2}" [ "a-1", "a-2", "b-1", "b-2" ]
440 Note that nested braces are not processed. Braces, commas, and
441 backslashes may be escaped with backslashes. On error,
442 C<expand_braced_altnerates> returns undef. These two functions are
443 available in the export tag C<:alternates>.
445 =item generate_timestamp()
447 Generate a timestamp from the current time, obeying the
448 'USETIMESTAMPS' config parameter. The Amanda configuration must
451 =item sanitise_filename($fn)
453 "Santitises" a filename by replacing any characters that might have special
454 meaning to a filesystem with underscores. This operation is I<not> reversible,
455 and distinct input filenames I<may> produce identical output filenames.
457 =item unmarshal_tapespec($tapespec)
458 =item marshal_tapespec($filelist)
460 These functions convert between a tapespec -- formerly, and confusingly, called
461 a "tapelist" -- and a perl data structure like
463 [ $label1 => [ $filenum1, $filenum2, .. ],
464 $label2 => [ $filenum1, $filenum2, .. ],
467 Note that a non-tapespec C<$string> will be unmarshalled as C<[ $string, [] ]>.
473 Amanda provides a basic mechanism to lock a file and read its contents. This
474 uses operating-system facilities to acquire an advisory lock, so non-Amanda
475 applications are not prevented from modifying the file while it is locked.
477 To create a lock object, call the C<file_lock> constructor, passing the
480 my $fl = Amanda::Util::file_lock->new($filename)
486 which also reads the contents of the file into memory, accessible via
488 my $state = $fl->data();
490 to change the file contents, call C<write>:
492 $fl->write($new_contents);
494 and unlock the lock with
498 Note that the file will be automatically unlocked if the C<file_lock> object is
501 =head1 Simple File Reading & Writing
503 For reading small files directly into memory with little code
504 overhead, we can use C<slurp>.
506 my $data = slurp $filename;
508 After processing the data, we can write it back to file with C<burp>. This
509 function always completely overwrites the file.
511 burp $filename, $header;
513 These functions can (and should) be exported to the main namespace
519 use Amanda::Debug qw(:init);
520 use Amanda::Config qw(:getconf);
523 use POSIX qw( :fcntl_h :errno_h );
524 use POSIX qw( strftime );
525 use Amanda::Constants;
528 # private package variables
533 sub setup_application {
534 my ($name, $type, $context) = @_;
537 croak("no name given") unless ($name);
538 croak("no type given") unless ($type);
539 croak("no context given") unless ($context);
541 # store these as perl values
544 $_pcontext = $context;
546 # and let the C side know about them too
549 set_pcontext($context);
551 safe_cd(); # (also sets umask)
554 # set up debugging, now that we have a name, type, and context
558 $SIG{'PIPE'} = 'IGNORE';
562 my ($running_as) = @_;
564 my $config_name = Amanda::Config::get_config_name();
567 dbrename($config_name, $_ptype);
570 check_running_as($running_as);
573 sub finish_application {
578 print "$_pname-$Amanda::Constants::VERSION\n";
583 push @EXPORT_OK, qw(get_original_cwd);
584 push @{$EXPORT_TAGS{"util"}}, qw(get_original_cwd);
589 delete @rv{qw(IFS CDPATH ENV BASH_ENV LANG)};
591 # delete all LC_* variables
592 for my $var (grep /^LC_/, keys %rv) {
600 push @EXPORT_OK, qw(running_as_flags_to_strings);
601 push @{$EXPORT_TAGS{"running_as_flags"}}, qw(running_as_flags_to_strings);
603 my %_running_as_flags_VALUES;
604 #Convert a flag value to a list of names for flags that are set.
605 sub running_as_flags_to_strings {
609 for my $k (keys %_running_as_flags_VALUES) {
610 my $v = $_running_as_flags_VALUES{$k};
612 #is this a matching flag?
613 if (($v == 0 && $flags == 0) || ($v != 0 && ($flags & $v) == $v)) {
618 #by default, just return the number as a 1-element list
626 push @EXPORT_OK, qw($RUNNING_AS_ANY);
627 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ANY);
629 $_running_as_flags_VALUES{"RUNNING_AS_ANY"} = $RUNNING_AS_ANY;
631 push @EXPORT_OK, qw($RUNNING_AS_ROOT);
632 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ROOT);
634 $_running_as_flags_VALUES{"RUNNING_AS_ROOT"} = $RUNNING_AS_ROOT;
636 push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER);
637 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER);
639 $_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER"} = $RUNNING_AS_DUMPUSER;
641 push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER_PREFERRED);
642 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER_PREFERRED);
644 $_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER_PREFERRED"} = $RUNNING_AS_DUMPUSER_PREFERRED;
646 push @EXPORT_OK, qw($RUNNING_AS_CLIENT_LOGIN);
647 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_CLIENT_LOGIN);
649 $_running_as_flags_VALUES{"RUNNING_AS_CLIENT_LOGIN"} = $RUNNING_AS_CLIENT_LOGIN;
651 push @EXPORT_OK, qw($RUNNING_AS_UID_ONLY);
652 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_UID_ONLY);
654 $_running_as_flags_VALUES{"RUNNING_AS_UID_ONLY"} = $RUNNING_AS_UID_ONLY;
656 #copy symbols in running_as_flags to constants
657 push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"running_as_flags"}};
659 push @EXPORT_OK, qw(pcontext_t_to_string);
660 push @{$EXPORT_TAGS{"pcontext_t"}}, qw(pcontext_t_to_string);
662 my %_pcontext_t_VALUES;
663 #Convert an enum value to a single string
664 sub pcontext_t_to_string {
667 for my $k (keys %_pcontext_t_VALUES) {
668 my $v = $_pcontext_t_VALUES{$k};
670 #is this a matching flag?
671 if ($enumval == $v) {
676 #default, just return the number
680 push @EXPORT_OK, qw($CONTEXT_DEFAULT);
681 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DEFAULT);
683 $_pcontext_t_VALUES{"CONTEXT_DEFAULT"} = $CONTEXT_DEFAULT;
685 push @EXPORT_OK, qw($CONTEXT_CMDLINE);
686 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_CMDLINE);
688 $_pcontext_t_VALUES{"CONTEXT_CMDLINE"} = $CONTEXT_CMDLINE;
690 push @EXPORT_OK, qw($CONTEXT_DAEMON);
691 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DAEMON);
693 $_pcontext_t_VALUES{"CONTEXT_DAEMON"} = $CONTEXT_DAEMON;
695 push @EXPORT_OK, qw($CONTEXT_SCRIPTUTIL);
696 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_SCRIPTUTIL);
698 $_pcontext_t_VALUES{"CONTEXT_SCRIPTUTIL"} = $CONTEXT_SCRIPTUTIL;
700 #copy symbols in pcontext_t to constants
701 push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"pcontext_t"}};
704 my ($fd, $count) = @_;
709 my $n_read = POSIX::read($fd, $b, $count);
710 if (!defined $n_read) {
711 next if ($! == EINTR);
713 } elsif ($n_read == 0) {
720 return join('', @bufs);
724 my ($fd, $buf, $count) = @_;
728 my $n_written = POSIX::write($fd, $buf, $count);
729 if (!defined $n_written) {
730 next if ($! == EINTR);
732 } elsif ($n_written == 0) {
736 $count -= $n_written;
737 $total += $n_written;
740 $buf = substr($buf, $n_written);
747 sub skip_quoted_string {
753 my $c = substr $str, $i, 1;
754 while ($c ne "" && !($iq == 0 && $c =~ /\s/)) {
757 } elsif ($c eq '\\') {
761 $c = substr $str, $i, 1;
763 my $quoted_string = substr $str, 0, $i;
764 my $remainder = undef;
765 if (length($str) > $i) {
766 $remainder = substr $str, $i+1;
769 return ($quoted_string, $remainder);
773 push @EXPORT_OK, qw(slurp);
775 push @EXPORT_OK, qw(burp);
777 push @EXPORT_OK, qw(safe_overwrite_file);
784 open my $fh, "<", $file or croak "can't open $file: $!";
793 open my $fh, ">", $file or croak "can't open $file: $!";
797 sub safe_overwrite_file {
798 my ( $filename, $contents ) = @_;
800 my $tmpfname = "$filename." . time;
801 open my $tmpfh, ">", $tmpfname or die "open: $!";
803 print $tmpfh $contents;
804 (fsync($tmpfh) == 0) or die "fsync: $!";
805 return rename $tmpfname, $filename;
809 push @EXPORT_OK, qw(hexencode hexdecode);
810 push @{$EXPORT_TAGS{"encoding"}}, qw(hexencode hexdecode);
812 push @EXPORT_OK, qw(quote_string unquote_string skip_quoted_string sanitise_filename split_quoted_strings);
813 push @{$EXPORT_TAGS{"quoting"}}, qw(quote_string unquote_string skip_quoted_string sanitise_filename split_quoted_strings);
815 push @EXPORT_OK, qw(expand_braced_alternates collapse_braced_alternates);
816 push @{$EXPORT_TAGS{"alternates"}}, qw(expand_braced_alternates collapse_braced_alternates);
819 sub generate_timestamp {
820 # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time
821 if (getconf($CNF_USETIMESTAMPS)) {
822 return strftime "%Y%m%d%H%M%S", localtime;
824 return strftime "%Y%m%d", localtime;
828 sub built_with_component {
829 my ($component) = @_;
830 my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
831 return grep { $_ eq $component } @components;
839 return 1 if $pid == $$;
841 my $Amanda_process = Amanda::Process->new(0);
843 $Amanda_process->load_ps_table();
844 my $alive = $Amanda_process->process_alive($pid);
849 push @EXPORT_OK, qw(weaken_ref);
851 push @EXPORT_OK, qw(stream_server stream_accept check_security);
853 push @EXPORT_OK, qw($AF_INET $STREAM_BUFSIZE);
854 push @{$EXPORT_TAGS{"constants"}}, qw($AF_INET $STREAM_BUFSIZE);
857 # these functions were verified to work similarly to those in
858 # common-src/tapelist.c - they pass the same tests, at least.
860 sub marshal_tapespec {
862 my @filelist = @$filelist; # make a copy we can wreck
866 my $label = shift @filelist;
867 my $files = shift @filelist;
869 $label =~ s/([\\:;,])/\\$1/g;
870 push @specs, "$label:" . join(",", @$files);
872 return join(";", @specs);
875 sub unmarshal_tapespec {
879 # detect a non-tapespec string for special handling; in particular, a string
880 # without an unquoted : followed by digits and commas at the end. The easiest
881 # way to do this is to replace every quoted character with a dummy, then look
882 # for the colon and digits.
884 $tmp =~ s/\\([\\:;,])/X/g;
885 if ($tmp !~ /:[,\d]+$/) {
886 # ok, it doesn't end with the right form, so unquote it and return it
888 $tapespec =~ s/\\([\\:;,])/$1/g;
889 return [ $tapespec, [ 0 ] ];
892 # use a lookbehind to mask out any quoted ;'s
893 my @volumes = split(/(?<!\\);/, $tapespec);
894 for my $vol (@volumes) {
895 my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
897 $label =~ s/\\([\\:;,])/$1/g;
898 push @filelist, $label;
900 my @files = split(/,/, $files);
901 @files = map { $_+0 } @files;
902 @files = sort { $a <=> $b } @files;
903 push @filelist, \@files;
911 fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
912 fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
913 fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");