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, as separated by
404 any whitespace. Note that the remainder of the string does not include the
405 single separating whitespace character, but will include any subsequent
406 whitespace. The C<$q> is not unquoted.
408 =item C<split_quoted_strings($str)>
410 Split string on unquoted whitespace. Multiple consecutive spaces are I<not>
411 collapsed into a single space: C<"x y"> (with two spaces) parses as C<( "x",
412 "", "y")>. The strings are unquoted before they are returned. An empty string
413 is split into C<( "" )>. This method is generally used for parsing IPC messages,
414 where blank space is significant and well-controlled.
416 =item C<split_quoted_strings_friendly($str)>
418 Similar to C<split_quoted_strings>, but intended for user-friendly uses. In
419 particular, this function treats any sequence of zero or more whitespace
420 characters as a separator, rather than the more strict interpretation applied
421 by C<split_quoted_strings>. All of the strings are unquoted.
423 All of these quoting-related functions are available under the export
426 =item hexencode($str)
428 Encode a string using URI-style hexadecimal encoding.
429 Non-alphanumeric characters will be replaced with "%xx"
430 where "xx" is the two-digit hexadecimal representation of the character.
432 =item hexdecode($str)
434 Decode a string using URI-style hexadecimal encoding.
436 Both C<hexencode> and C<hexdecode> are available under the export tag C<:encoding>
438 =item expand_braced_alternates($str)
439 =item collapse_braced_alternates(\@list)
441 These two functions handle "braced alternates", which is a syntax
442 borrowed, partially, from shells. Comma-separated strings enclosed in
443 curly braces expand into multiple alternatives for the entire string.
446 "{foo,bar,bat}" [ "foo", "bar", "bat" ]
447 "foo{1,2}bar" [ "foo1bar", "foo2bar" ]
448 "foo{1\,2,3}bar" [ "foo1,2bar", "foo3bar" ]
449 "{a,b}-{1,2}" [ "a-1", "a-2", "b-1", "b-2" ]
451 Note that nested braces are not processed. Braces, commas, and
452 backslashes may be escaped with backslashes.
454 As a special case for numeric ranges, if the braces contain only digits
455 followed by two dots followed by more digits, and the digits sort in the
456 correct order, then they will be treated as a sequence. If the first number in
457 the sequence has leading zeroes, then all generated numbers will have that
458 length, padded with leading zeroes.
460 "tape-{01..10}" [ "tape-01", "tape-02", "tape-03", "tape-04",
461 "tape-05", "tape-06", "tape-07", "tape-08",
462 "tape-09", "tape-10" ]
464 On error, C<expand_braced_altnerates> returns undef. These two functions are
465 available in the export tag C<:alternates>.
467 =item generate_timestamp()
469 Generate a timestamp from the current time, obeying the
470 'USETIMESTAMPS' config parameter. The Amanda configuration must
473 =item sanitise_filename($fn)
475 "Santitises" a filename by replacing any characters that might have special
476 meaning to a filesystem with underscores. This operation is I<not> reversible,
477 and distinct input filenames I<may> produce identical output filenames.
479 =item unmarshal_tapespec($tapespec)
480 =item marshal_tapespec($filelist)
482 These functions convert between a tapespec -- formerly, and confusingly, called
483 a "tapelist" -- and a perl data structure like
485 [ $label1 => [ $filenum1, $filenum2, .. ],
486 $label2 => [ $filenum1, $filenum2, .. ],
489 Note that a non-tapespec C<$string> will be unmarshalled as C<[ $string, [] ]>.
495 Amanda provides a basic mechanism to lock a file and read its contents. This
496 uses operating-system facilities to acquire an advisory lock, so non-Amanda
497 applications are not prevented from modifying the file while it is locked.
499 To create a lock object, call the C<file_lock> constructor, passing the
502 my $fl = Amanda::Util::file_lock->new($filename)
508 which also reads the contents of the file into memory, accessible via
510 my $state = $fl->data();
512 to change the file contents, call C<write>:
514 $fl->write($new_contents);
516 and unlock the lock with
520 Note that the file will be automatically unlocked if the C<file_lock> object is
523 =head1 Simple File Reading & Writing
525 For reading small files directly into memory with little code
526 overhead, we can use C<slurp>.
528 my $data = slurp $filename;
530 After processing the data, we can write it back to file with C<burp>. This
531 function always completely overwrites the file.
533 burp $filename, $header;
535 These functions can (and should) be exported to the main namespace
541 use Amanda::Debug qw(:init);
542 use Amanda::Config qw(:getconf);
545 use POSIX qw( :fcntl_h :errno_h );
546 use POSIX qw( strftime );
547 use Amanda::Constants;
550 # private package variables
555 sub setup_application {
556 my ($name, $type, $context) = @_;
559 croak("no name given") unless ($name);
560 croak("no type given") unless ($type);
561 croak("no context given") unless ($context);
563 # store these as perl values
566 $_pcontext = $context;
568 # and let the C side know about them too
571 set_pcontext($context);
573 safe_cd(); # (also sets umask)
576 # set up debugging, now that we have a name, type, and context
580 $SIG{'PIPE'} = 'IGNORE';
584 my ($running_as) = @_;
586 my $config_name = Amanda::Config::get_config_name();
589 dbrename($config_name, $_ptype);
592 check_running_as($running_as);
595 sub finish_application {
600 print "$_pname-$Amanda::Constants::VERSION\n";
605 push @EXPORT_OK, qw(get_original_cwd);
606 push @{$EXPORT_TAGS{"util"}}, qw(get_original_cwd);
611 delete @rv{qw(IFS CDPATH ENV BASH_ENV LANG)};
613 # delete all LC_* variables
614 for my $var (grep /^LC_/, keys %rv) {
622 push @EXPORT_OK, qw(running_as_flags_to_strings);
623 push @{$EXPORT_TAGS{"running_as_flags"}}, qw(running_as_flags_to_strings);
625 my %_running_as_flags_VALUES;
626 #Convert a flag value to a list of names for flags that are set.
627 sub running_as_flags_to_strings {
631 for my $k (keys %_running_as_flags_VALUES) {
632 my $v = $_running_as_flags_VALUES{$k};
634 #is this a matching flag?
635 if (($v == 0 && $flags == 0) || ($v != 0 && ($flags & $v) == $v)) {
640 #by default, just return the number as a 1-element list
648 push @EXPORT_OK, qw($RUNNING_AS_ANY);
649 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ANY);
651 $_running_as_flags_VALUES{"RUNNING_AS_ANY"} = $RUNNING_AS_ANY;
653 push @EXPORT_OK, qw($RUNNING_AS_ROOT);
654 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ROOT);
656 $_running_as_flags_VALUES{"RUNNING_AS_ROOT"} = $RUNNING_AS_ROOT;
658 push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER);
659 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER);
661 $_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER"} = $RUNNING_AS_DUMPUSER;
663 push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER_PREFERRED);
664 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER_PREFERRED);
666 $_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER_PREFERRED"} = $RUNNING_AS_DUMPUSER_PREFERRED;
668 push @EXPORT_OK, qw($RUNNING_AS_CLIENT_LOGIN);
669 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_CLIENT_LOGIN);
671 $_running_as_flags_VALUES{"RUNNING_AS_CLIENT_LOGIN"} = $RUNNING_AS_CLIENT_LOGIN;
673 push @EXPORT_OK, qw($RUNNING_AS_UID_ONLY);
674 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_UID_ONLY);
676 $_running_as_flags_VALUES{"RUNNING_AS_UID_ONLY"} = $RUNNING_AS_UID_ONLY;
678 #copy symbols in running_as_flags to constants
679 push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"running_as_flags"}};
681 push @EXPORT_OK, qw(pcontext_t_to_string);
682 push @{$EXPORT_TAGS{"pcontext_t"}}, qw(pcontext_t_to_string);
684 my %_pcontext_t_VALUES;
685 #Convert an enum value to a single string
686 sub pcontext_t_to_string {
689 for my $k (keys %_pcontext_t_VALUES) {
690 my $v = $_pcontext_t_VALUES{$k};
692 #is this a matching flag?
693 if ($enumval == $v) {
698 #default, just return the number
702 push @EXPORT_OK, qw($CONTEXT_DEFAULT);
703 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DEFAULT);
705 $_pcontext_t_VALUES{"CONTEXT_DEFAULT"} = $CONTEXT_DEFAULT;
707 push @EXPORT_OK, qw($CONTEXT_CMDLINE);
708 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_CMDLINE);
710 $_pcontext_t_VALUES{"CONTEXT_CMDLINE"} = $CONTEXT_CMDLINE;
712 push @EXPORT_OK, qw($CONTEXT_DAEMON);
713 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DAEMON);
715 $_pcontext_t_VALUES{"CONTEXT_DAEMON"} = $CONTEXT_DAEMON;
717 push @EXPORT_OK, qw($CONTEXT_SCRIPTUTIL);
718 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_SCRIPTUTIL);
720 $_pcontext_t_VALUES{"CONTEXT_SCRIPTUTIL"} = $CONTEXT_SCRIPTUTIL;
722 #copy symbols in pcontext_t to constants
723 push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"pcontext_t"}};
726 my ($fd, $count) = @_;
731 my $n_read = POSIX::read($fd, $b, $count);
732 if (!defined $n_read) {
733 next if ($! == EINTR);
735 } elsif ($n_read == 0) {
742 return join('', @bufs);
746 my ($fd, $buf, $count) = @_;
750 my $n_written = POSIX::write($fd, $buf, $count);
751 if (!defined $n_written) {
752 next if ($! == EINTR);
754 } elsif ($n_written == 0) {
758 $count -= $n_written;
759 $total += $n_written;
762 $buf = substr($buf, $n_written);
769 sub skip_quoted_string {
775 my $c = substr $str, $i, 1;
776 while ($c ne "" && !($iq == 0 && $c =~ /\s/)) {
779 } elsif ($c eq '\\') {
783 $c = substr $str, $i, 1;
785 my $quoted_string = substr $str, 0, $i;
786 my $remainder = undef;
787 if (length($str) > $i) {
788 $remainder = substr $str, $i+1;
791 return ($quoted_string, $remainder);
794 sub split_quoted_string_friendly {
801 (my $elt, $str) = skip_quoted_string($str);
802 push @result, unquote_string($elt);
803 $str =~ s/^\s+// if $str;
810 push @EXPORT_OK, qw(slurp);
812 push @EXPORT_OK, qw(burp);
814 push @EXPORT_OK, qw(safe_overwrite_file);
821 open my $fh, "<", $file or croak "can't open $file: $!";
830 open my $fh, ">", $file or croak "can't open $file: $!";
834 sub safe_overwrite_file {
835 my ( $filename, $contents ) = @_;
837 my $tmpfname = "$filename." . time;
838 open my $tmpfh, ">", $tmpfname or die "open: $!";
840 print $tmpfh $contents;
841 (fsync($tmpfh) == 0) or die "fsync: $!";
842 return rename $tmpfname, $filename;
846 push @EXPORT_OK, qw(hexencode hexdecode);
847 push @{$EXPORT_TAGS{"encoding"}}, qw(hexencode hexdecode);
849 push @EXPORT_OK, qw(quote_string unquote_string skip_quoted_string
850 sanitise_filename split_quoted_strings split_quoted_strings_friendly);
851 push @{$EXPORT_TAGS{"quoting"}}, qw(quote_string unquote_string skip_quoted_string
852 sanitise_filename split_quoted_strings split_quoted_strings_friendly);
854 push @EXPORT_OK, qw(expand_braced_alternates collapse_braced_alternates);
855 push @{$EXPORT_TAGS{"alternates"}}, qw(expand_braced_alternates collapse_braced_alternates);
858 sub generate_timestamp {
859 # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time
860 if (getconf($CNF_USETIMESTAMPS)) {
861 return strftime "%Y%m%d%H%M%S", localtime;
863 return strftime "%Y%m%d", localtime;
867 sub built_with_component {
868 my ($component) = @_;
869 my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
870 return grep { $_ eq $component } @components;
878 return 1 if $pid == $$;
880 my $Amanda_process = Amanda::Process->new(0);
882 $Amanda_process->load_ps_table();
883 my $alive = $Amanda_process->process_alive($pid);
888 push @EXPORT_OK, qw(weaken_ref);
890 push @EXPORT_OK, qw(stream_server stream_accept check_security);
892 push @EXPORT_OK, qw($AF_INET $STREAM_BUFSIZE);
893 push @{$EXPORT_TAGS{"constants"}}, qw($AF_INET $STREAM_BUFSIZE);
896 # these functions were verified to work similarly to those in
897 # common-src/tapelist.c - they pass the same tests, at least.
899 sub marshal_tapespec {
901 my @filelist = @$filelist; # make a copy we can wreck
905 my $label = shift @filelist;
906 my $files = shift @filelist;
908 $label =~ s/([\\:;,])/\\$1/g;
909 push @specs, "$label:" . join(",", @$files);
911 return join(";", @specs);
914 sub unmarshal_tapespec {
918 # detect a non-tapespec string for special handling; in particular, a string
919 # without an unquoted : followed by digits and commas at the end. The easiest
920 # way to do this is to replace every quoted character with a dummy, then look
921 # for the colon and digits.
923 $tmp =~ s/\\([\\:;,])/X/g;
924 if ($tmp !~ /:[,\d]+$/) {
925 # ok, it doesn't end with the right form, so unquote it and return it
927 $tapespec =~ s/\\([\\:;,])/$1/g;
928 return [ $tapespec, [ 0 ] ];
931 # use a lookbehind to mask out any quoted ;'s
932 my @volumes = split(/(?<!\\);/, $tapespec);
933 for my $vol (@volumes) {
934 my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
936 $label =~ s/\\([\\:;,])/$1/g;
937 push @filelist, $label;
939 my @files = split(/,/, $files);
940 @files = map { $_+0 } @files;
941 @files = sort { $a <=> $b } @files;
942 push @filelist, \@files;
950 fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
951 fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
952 fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");