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 *match_host = *Amanda::Utilc::match_host;
71 *match_disk = *Amanda::Utilc::match_disk;
72 *match_datestamp = *Amanda::Utilc::match_datestamp;
73 *match_level = *Amanda::Utilc::match_level;
74 *set_pname = *Amanda::Utilc::set_pname;
75 *get_pname = *Amanda::Utilc::get_pname;
76 *set_ptype = *Amanda::Utilc::set_ptype;
77 *get_ptype = *Amanda::Utilc::get_ptype;
78 *set_pcontext = *Amanda::Utilc::set_pcontext;
79 *get_pcontext = *Amanda::Utilc::get_pcontext;
80 *safe_cd = *Amanda::Utilc::safe_cd;
81 *check_running_as = *Amanda::Utilc::check_running_as;
83 ############# Class : Amanda::Util::file_lock ##############
85 package Amanda::Util::file_lock;
86 use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);
87 @ISA = qw( Amanda::Util );
92 my $self = Amanda::Utilc::new_file_lock(@_);
93 bless $self, $pkg if defined($self);
96 *lock = *Amanda::Utilc::file_lock_lock;
97 *lock_wr = *Amanda::Utilc::file_lock_lock_wr;
98 *lock_rd = *Amanda::Utilc::file_lock_lock_rd;
99 *unlock = *Amanda::Utilc::file_lock_unlock;
100 *locked = *Amanda::Utilc::file_lock_locked;
101 *write = *Amanda::Utilc::file_lock_write;
102 *data = *Amanda::Utilc::file_lock_data;
104 return unless $_[0]->isa('HASH');
105 my $self = tied(%{$_[0]});
106 return unless defined $self;
107 delete $ITERATORS{$self};
108 if (exists $OWNER{$self}) {
109 Amanda::Utilc::delete_file_lock($self);
110 delete $OWNER{$self};
116 my $ptr = tied(%$self);
122 my $ptr = tied(%$self);
127 # ------- VARIABLE STUBS --------
129 package Amanda::Util;
131 *RUNNING_AS_ANY = *Amanda::Utilc::RUNNING_AS_ANY;
132 *RUNNING_AS_ROOT = *Amanda::Utilc::RUNNING_AS_ROOT;
133 *RUNNING_AS_DUMPUSER = *Amanda::Utilc::RUNNING_AS_DUMPUSER;
134 *RUNNING_AS_DUMPUSER_PREFERRED = *Amanda::Utilc::RUNNING_AS_DUMPUSER_PREFERRED;
135 *RUNNING_AS_CLIENT_LOGIN = *Amanda::Utilc::RUNNING_AS_CLIENT_LOGIN;
136 *RUNNING_AS_UID_ONLY = *Amanda::Utilc::RUNNING_AS_UID_ONLY;
137 *CONTEXT_DEFAULT = *Amanda::Utilc::CONTEXT_DEFAULT;
138 *CONTEXT_CMDLINE = *Amanda::Utilc::CONTEXT_CMDLINE;
139 *CONTEXT_DAEMON = *Amanda::Utilc::CONTEXT_DAEMON;
140 *CONTEXT_SCRIPTUTIL = *Amanda::Utilc::CONTEXT_SCRIPTUTIL;
141 *AF_INET = *Amanda::Utilc::AF_INET;
142 *STREAM_BUFSIZE = *Amanda::Utilc::STREAM_BUFSIZE;
150 Amanda::Util - Runtime support for Amanda applications
152 =head1 Application Initialization
154 Application initialization generally looks like this:
156 use Amanda::Config qw( :init );
157 use Amanda::Util qw( :constants );
160 Amanda::Util::setup_application("myapp", "server", $CONTEXT_CMDLINE);
161 # .. command-line processing ..
162 Amanda::Config::config_init(...);
163 Amanda::Util::finish_setup($RUNNING_AS_DUMPUSER);
165 Amanda::Util::finish_application();
169 =item setup_application($name, $type, $context)
171 Set up the operating environment for an application, without requiring
174 C<$name> is the name of the application, used in log messages, etc.
175 C<$type> is usualy one of "server" or "client". It specifies the
176 subdirectory in which debug logfiles will be created. C<$context>
177 indicates the usual manner in which this application is invoked; one
178 of C<$CONTEXT_CMDLINE> for a user-invoked command-line utility (e.g.,
179 C<amadmin>) which should send human-readable error messages to stderr;
180 C<$CONTEXT_DAEMON> for a program started by C<amandad>, e.g.,
181 C<sendbackup>; or C<$CONTEXT_SCRIPTUTIL> for a small program used from
182 shell scripts, e.g., C<amgetconf>
184 Based on C<$type> and C<$context>, this function does the following:
190 sets up debug logging;
194 configures internationalization
202 sets the current working directory to the debug or temporary
207 closes any unnecessary file descriptors as a security meaasure;
211 ignores C<SIGPIPE>; and
215 sets the appropriate target for error messages.
219 =item finish_setup($running_as_flags)
221 Perform final initialization tasks that require a loaded
222 configuration. Specifically, move the debug log into a
223 configuration-specific subdirectory, and check that the current userid
224 is appropriate for this applciation.
226 The user is specified by one of the following flags, which are
227 available in export tag C<:check_running_as_flags>:
229 $RUNNING_AS_ANY # any user is OK
230 $RUNNING_AS_ROOT # root
231 $RUNNING_AS_DUMPUSER # dumpuser, from configuration
232 $RUNNING_AS_DUMPUSER_PREFERRED # dumpuser, but client_login is OK too
233 $RUNNING_AS_CLIENT_LOGIN # client_login (--with-user at build time)
235 If the flag C<$RUNNING_AS_UID_ONLY> is bit-or'd into
236 C<$running_as_flags>, then the euid is ignored; this is used for
237 programs that expect to be setuid-root.
239 =item finish_application()
241 Remove old debug files.
242 All applications should call this before exiting.
244 =item get_original_cwd()
246 Return the original current directory with C<get_original_cwd>.
250 Print the version and exit. This is intended to be used in C<GetOptions> invocations, e.g.,
254 'version' => \&Amanda::Util::version_opt,
261 These functions read and write the entire requested size to a file
262 descriptor, even if the underlying syscall returns early. Note that
263 they do not operate on Perl file handles.
265 If fewer than C<$size> bytes are written, C<full_write> returns the
266 number of bytes actually written and sets C<$!> appropriately. When
267 reading, if fewer than C<$size> bytes are read due to a normal EOF,
268 then C<$!> is zero; otherwise, it contains the appropriate error
271 Unlike C<POSIX::read>, C<full_read> returns a scalar containing the
272 bytes it read from the file descriptor.
276 =item full_read($fd, $size)
278 =item full_write($fd, $buf, $size)
282 =head1 Miscellaneous Utilities
288 Return a "safe" environment hash. For non-setuid programs, this means
289 filtering out any localization variables.
291 =item get_fs_usage(file)
293 This is a wrapper around the Gnulib function of the same name. On success, it returns
296 blocksize Size of a block
297 blocks Total blocks on disk
298 bfree Free blocks available to superuser
299 bavail Free blocks available to non-superuser
300 bavail_top_bit_set 1 if fsu_bavail represents a value < 0
301 files Total file nodes
302 ffree Free file nodes
304 On failure, it returns nothing, and C<$!> should be set. If C<$!> is 0, then
305 this is a system which cannot measure usage without a C<disk> argument, which
306 this wrapper does not support.
308 =item is_pid_alive(pid)
310 Return 1 is the process with that pid is still alive.
312 =item weaken_ref($ref)
314 This is exactly the same as C<Scalar::Util::weaken>, but available in all
315 supported versions of perl.
319 Return the number of microseconds since the UNIX epoch.
323 Invoke the C<fsync> syscall.
325 =item set_blocking($fd, $blocking)
327 Set or clear the C<O_NONBLOCK> fd flag on $fd; returns a negative value on
328 failure, or 0 on success.
330 =item openbsd_fd_inform()
332 Due to a particularly poor user-space implementation of threading on OpenBSD,
333 executables that are run with nonstandard file descriptors open (fd > 2) find
334 those descriptors to be in a nonblocking state. This particularly affects
335 amandad services, which begin with several file descriptors in the 50's open.
337 This function "informs" the C library about these descriptors by making an
338 C<fcntl(fd, F_GETFL)> call. This is otherwise harmless, and is only perfomed
341 =item built_with_component($comp)
343 Returns true if Amanda was built with the given component. Component names are
344 in C<config/amanda/components.m4>.
350 These are thin wrappers over functions in C<common-src/stream.h> and other related
357 my $family = $Amanda::Util::AF_INET;
358 my $bufsize = $Amanda::Util::STREAM_BUFSIZE;
359 my ($listensock, $port) = Amanda::Util::stream_server(
360 $family, $bufsize, $bufsize, $priv);
362 This function creates a new socket and binds it to a port, returning both the
363 socket and port. If the socket is -1, then an error occurred and is available
364 in C<$!>. The constants C<$AF_INET> and C<$STREAM_BUFSIZE> are universally
365 used when calling this function. If the final argument, C<$priv>, is true,
366 then a the function opens a privileged port (below 1024).
370 my $sock = Amanda::Util::stream_accept(
371 $listen_sock, $timeout, $bufsize, $bufsize);
373 This function accepts a connection on a listening socket. If the connection is
374 not made within C<$timeout> seconds, or some other error occurs, then the
375 function returns -1. The bufsize arguments are applied to the new socket.
379 my $ok = Amanda::Util::check_security($socket, $userstr);
381 This function takes a socket descriptor and a string of the form C<"USER foo">
382 and performs BSD-style checks on that descriptor. These include verifying
383 round-trip DNS sanity; check that the user is in C<.rhosts> or C<.amandahosts>,
384 and checking that the remote port is reserved. Returns an error string on
385 error, or C<undef> on success.
389 =head1 String Utilities
393 =item quote_string($str)
395 Quote a string using Amanda's quoting algorithm. Strings with no
396 whitespace, control, or quote characters are returned unchanged. An
397 empty string is represented as the two-character string C<"">.
398 Otherwise, tab, newline, carriage return, form-feed, backslash, and
399 double-quote (C<">) characters are escaped with a backslash and the
400 string is surrounded by double quotes.
402 =item unquote_string($str)
404 Unquote a string as quoted with C<quote_string>.
406 =item skip_quoted_string($str)
408 my($q, $remaider) = skip_quoted_string($str)
410 Return the first quoted string and the remainder of the string, as separated by
411 any whitespace. Note that the remainder of the string does not include the
412 single separating whitespace character, but will include any subsequent
413 whitespace. The C<$q> is not unquoted.
415 =item C<split_quoted_strings($str)>
417 Split string on unquoted whitespace. Multiple consecutive spaces are I<not>
418 collapsed into a single space: C<"x y"> (with two spaces) parses as C<( "x",
419 "", "y")>. The strings are unquoted before they are returned. An empty string
420 is split into C<( "" )>. This method is generally used for parsing IPC messages,
421 where blank space is significant and well-controlled.
423 =item C<split_quoted_strings_friendly($str)>
425 Similar to C<split_quoted_strings>, but intended for user-friendly uses. In
426 particular, this function treats any sequence of zero or more whitespace
427 characters as a separator, rather than the more strict interpretation applied
428 by C<split_quoted_strings>. All of the strings are unquoted.
430 All of these quoting-related functions are available under the export
433 =item hexencode($str)
435 Encode a string using URI-style hexadecimal encoding.
436 Non-alphanumeric characters will be replaced with "%xx"
437 where "xx" is the two-digit hexadecimal representation of the character.
439 =item hexdecode($str)
441 Decode a string using URI-style hexadecimal encoding.
443 Both C<hexencode> and C<hexdecode> are available under the export tag C<:encoding>
445 =item expand_braced_alternates($str)
446 =item collapse_braced_alternates(\@list)
448 These two functions handle "braced alternates", which is a syntax
449 borrowed, partially, from shells. Comma-separated strings enclosed in
450 curly braces expand into multiple alternatives for the entire string.
453 "{foo,bar,bat}" [ "foo", "bar", "bat" ]
454 "foo{1,2}bar" [ "foo1bar", "foo2bar" ]
455 "foo{1\,2,3}bar" [ "foo1,2bar", "foo3bar" ]
456 "{a,b}-{1,2}" [ "a-1", "a-2", "b-1", "b-2" ]
458 Note that nested braces are not processed. Braces, commas, and
459 backslashes may be escaped with backslashes.
461 As a special case for numeric ranges, if the braces contain only digits
462 followed by two dots followed by more digits, and the digits sort in the
463 correct order, then they will be treated as a sequence. If the first number in
464 the sequence has leading zeroes, then all generated numbers will have that
465 length, padded with leading zeroes.
467 "tape-{01..10}" [ "tape-01", "tape-02", "tape-03", "tape-04",
468 "tape-05", "tape-06", "tape-07", "tape-08",
469 "tape-09", "tape-10" ]
471 On error, C<expand_braced_altnerates> returns undef. These two functions are
472 available in the export tag C<:alternates>.
474 =item generate_timestamp()
476 Generate a timestamp from the current time, obeying the
477 'USETIMESTAMPS' config parameter. The Amanda configuration must
480 =item sanitise_filename($fn)
482 "Santitises" a filename by replacing any characters that might have special
483 meaning to a filesystem with underscores. This operation is I<not> reversible,
484 and distinct input filenames I<may> produce identical output filenames.
486 =item unmarshal_tapespec($tapespec)
487 =item marshal_tapespec($filelist)
489 These functions convert between a tapespec -- formerly, and confusingly, called
490 a "tapelist" -- and a perl data structure like
492 [ $label1 => [ $filenum1, $filenum2, .. ],
493 $label2 => [ $filenum1, $filenum2, .. ],
496 Note that a non-tapespec C<$string> will be unmarshalled as C<[ $string, [] ]>.
502 Amanda provides a basic mechanism to lock a file and read its contents. This
503 uses operating-system facilities to acquire an advisory lock, so non-Amanda
504 applications are not prevented from modifying the file while it is locked.
506 To create a lock object, call the C<file_lock> constructor, passing the
509 my $fl = Amanda::Util::file_lock->new($filename)
511 then, three ways to lock the file:
513 $fl->lock_wr(); # take a write lock (exclusive)
514 $fl->lock_rd(); # take a read lock
515 $fl->lock(); # take a write lock and reads the contents of
516 # the file into memory.
518 they return -1 on failure, 0 if the lock is taken or 1 if the lock in not
519 taken (you can retry later).
521 to access the data in memory
523 my $state = $fl->data();
525 to change the file contents, call C<write>:
527 $fl->write($new_contents);
529 and unlock the lock with
533 Note that the file will be automatically unlocked if the C<file_lock> object is
536 =head1 Simple File Reading & Writing
538 For reading small files directly into memory with little code
539 overhead, we can use C<slurp>.
541 my $data = slurp $filename;
543 After processing the data, we can write it back to file with C<burp>. This
544 function always completely overwrites the file.
546 burp $filename, $header;
548 These functions can (and should) be exported to the main namespace
552 The following functions are available to match strings against patterns using
553 the rules described in amanda(8):
555 match_host($pat, $str);
556 match_disk($pat, $str);
557 match_datestamp($pat, $str);
558 match_level($pat, $str);
564 use Amanda::Debug qw(:init);
565 use Amanda::Config qw(:getconf);
568 use POSIX qw( :fcntl_h :errno_h );
569 use POSIX qw( strftime );
570 use Amanda::Constants;
573 # private package variables
578 sub setup_application {
579 my ($name, $type, $context) = @_;
582 croak("no name given") unless ($name);
583 croak("no type given") unless ($type);
584 croak("no context given") unless ($context);
586 # store these as perl values
589 $_pcontext = $context;
591 # and let the C side know about them too
594 set_pcontext($context);
596 safe_cd(); # (also sets umask)
599 # set up debugging, now that we have a name, type, and context
603 $SIG{'PIPE'} = 'IGNORE';
607 my ($running_as) = @_;
609 my $config_name = Amanda::Config::get_config_name();
612 dbrename($config_name, $_ptype);
615 check_running_as($running_as);
618 sub finish_application {
623 print "$_pname-$Amanda::Constants::VERSION\n";
628 push @EXPORT_OK, qw(get_original_cwd);
629 push @{$EXPORT_TAGS{"util"}}, qw(get_original_cwd);
634 delete @rv{qw(IFS CDPATH ENV BASH_ENV LANG)};
636 # delete all LC_* variables
637 for my $var (grep /^LC_/, keys %rv) {
645 push @EXPORT_OK, qw(running_as_flags_to_strings);
646 push @{$EXPORT_TAGS{"running_as_flags"}}, qw(running_as_flags_to_strings);
648 my %_running_as_flags_VALUES;
649 #Convert a flag value to a list of names for flags that are set.
650 sub running_as_flags_to_strings {
654 for my $k (keys %_running_as_flags_VALUES) {
655 my $v = $_running_as_flags_VALUES{$k};
657 #is this a matching flag?
658 if (($v == 0 && $flags == 0) || ($v != 0 && ($flags & $v) == $v)) {
663 #by default, just return the number as a 1-element list
671 push @EXPORT_OK, qw($RUNNING_AS_ANY);
672 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ANY);
674 $_running_as_flags_VALUES{"RUNNING_AS_ANY"} = $RUNNING_AS_ANY;
676 push @EXPORT_OK, qw($RUNNING_AS_ROOT);
677 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ROOT);
679 $_running_as_flags_VALUES{"RUNNING_AS_ROOT"} = $RUNNING_AS_ROOT;
681 push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER);
682 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER);
684 $_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER"} = $RUNNING_AS_DUMPUSER;
686 push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER_PREFERRED);
687 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER_PREFERRED);
689 $_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER_PREFERRED"} = $RUNNING_AS_DUMPUSER_PREFERRED;
691 push @EXPORT_OK, qw($RUNNING_AS_CLIENT_LOGIN);
692 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_CLIENT_LOGIN);
694 $_running_as_flags_VALUES{"RUNNING_AS_CLIENT_LOGIN"} = $RUNNING_AS_CLIENT_LOGIN;
696 push @EXPORT_OK, qw($RUNNING_AS_UID_ONLY);
697 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_UID_ONLY);
699 $_running_as_flags_VALUES{"RUNNING_AS_UID_ONLY"} = $RUNNING_AS_UID_ONLY;
701 #copy symbols in running_as_flags to constants
702 push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"running_as_flags"}};
704 push @EXPORT_OK, qw(pcontext_t_to_string);
705 push @{$EXPORT_TAGS{"pcontext_t"}}, qw(pcontext_t_to_string);
707 my %_pcontext_t_VALUES;
708 #Convert an enum value to a single string
709 sub pcontext_t_to_string {
712 for my $k (keys %_pcontext_t_VALUES) {
713 my $v = $_pcontext_t_VALUES{$k};
715 #is this a matching flag?
716 if ($enumval == $v) {
721 #default, just return the number
725 push @EXPORT_OK, qw($CONTEXT_DEFAULT);
726 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DEFAULT);
728 $_pcontext_t_VALUES{"CONTEXT_DEFAULT"} = $CONTEXT_DEFAULT;
730 push @EXPORT_OK, qw($CONTEXT_CMDLINE);
731 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_CMDLINE);
733 $_pcontext_t_VALUES{"CONTEXT_CMDLINE"} = $CONTEXT_CMDLINE;
735 push @EXPORT_OK, qw($CONTEXT_DAEMON);
736 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DAEMON);
738 $_pcontext_t_VALUES{"CONTEXT_DAEMON"} = $CONTEXT_DAEMON;
740 push @EXPORT_OK, qw($CONTEXT_SCRIPTUTIL);
741 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_SCRIPTUTIL);
743 $_pcontext_t_VALUES{"CONTEXT_SCRIPTUTIL"} = $CONTEXT_SCRIPTUTIL;
745 #copy symbols in pcontext_t to constants
746 push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"pcontext_t"}};
749 my ($fd, $count) = @_;
754 my $n_read = POSIX::read($fd, $b, $count);
755 if (!defined $n_read) {
756 next if ($! == EINTR);
758 } elsif ($n_read == 0) {
765 return join('', @bufs);
769 my ($fd, $buf, $count) = @_;
773 my $n_written = POSIX::write($fd, $buf, $count);
774 if (!defined $n_written) {
775 next if ($! == EINTR);
777 } elsif ($n_written == 0) {
781 $count -= $n_written;
782 $total += $n_written;
785 $buf = substr($buf, $n_written);
792 sub skip_quoted_string {
798 my $c = substr $str, $i, 1;
799 while ($c ne "" && !($iq == 0 && $c =~ /\s/)) {
802 } elsif ($c eq '\\') {
806 $c = substr $str, $i, 1;
808 my $quoted_string = substr $str, 0, $i;
809 my $remainder = undef;
810 if (length($str) > $i) {
811 $remainder = substr $str, $i+1;
814 return ($quoted_string, $remainder);
817 sub split_quoted_string_friendly {
824 (my $elt, $str) = skip_quoted_string($str);
825 push @result, unquote_string($elt);
826 $str =~ s/^\s+// if $str;
833 push @EXPORT_OK, qw(slurp);
835 push @EXPORT_OK, qw(burp);
837 push @EXPORT_OK, qw(safe_overwrite_file);
844 open my $fh, "<", $file or croak "can't open $file: $!";
853 open my $fh, ">", $file or croak "can't open $file: $!";
857 sub safe_overwrite_file {
858 my ( $filename, $contents ) = @_;
860 my $tmpfname = "$filename." . time;
861 open my $tmpfh, ">", $tmpfname or die "open: $!";
863 print $tmpfh $contents;
864 (fsync($tmpfh) == 0) or die "fsync: $!";
865 return rename $tmpfname, $filename;
869 push @EXPORT_OK, qw(hexencode hexdecode);
870 push @{$EXPORT_TAGS{"encoding"}}, qw(hexencode hexdecode);
872 push @EXPORT_OK, qw(quote_string unquote_string skip_quoted_string
873 sanitise_filename split_quoted_strings split_quoted_strings_friendly);
874 push @{$EXPORT_TAGS{"quoting"}}, qw(quote_string unquote_string skip_quoted_string
875 sanitise_filename split_quoted_strings split_quoted_strings_friendly);
877 push @EXPORT_OK, qw(expand_braced_alternates collapse_braced_alternates);
878 push @{$EXPORT_TAGS{"alternates"}}, qw(expand_braced_alternates collapse_braced_alternates);
881 sub generate_timestamp {
882 # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time
883 if (getconf($CNF_USETIMESTAMPS)) {
884 return strftime "%Y%m%d%H%M%S", localtime;
886 return strftime "%Y%m%d", localtime;
890 sub built_with_component {
891 my ($component) = @_;
892 my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
893 return grep { $_ eq $component } @components;
901 return 1 if $pid == $$;
903 my $Amanda_process = Amanda::Process->new(0);
905 $Amanda_process->load_ps_table();
906 my $alive = $Amanda_process->process_alive($pid);
911 push @EXPORT_OK, qw(weaken_ref);
913 push @EXPORT_OK, qw(stream_server stream_accept check_security);
915 push @EXPORT_OK, qw($AF_INET $STREAM_BUFSIZE);
916 push @{$EXPORT_TAGS{"constants"}}, qw($AF_INET $STREAM_BUFSIZE);
919 # these functions were verified to work similarly to those in
920 # common-src/tapelist.c - they pass the same tests, at least.
922 sub marshal_tapespec {
924 my @filelist = @$filelist; # make a copy we can wreck
928 my $label = shift @filelist;
929 my $files = shift @filelist;
931 $label =~ s/([\\:;,])/\\$1/g;
932 push @specs, "$label:" . join(",", @$files);
934 return join(";", @specs);
937 sub unmarshal_tapespec {
941 # detect a non-tapespec string for special handling; in particular, a string
942 # without an unquoted : followed by digits and commas at the end. The easiest
943 # way to do this is to replace every quoted character with a dummy, then look
944 # for the colon and digits.
946 $tmp =~ s/\\([\\:;,])/X/g;
947 if ($tmp !~ /:[,\d]+$/) {
948 # ok, it doesn't end with the right form, so unquote it and return it
950 $tapespec =~ s/\\([\\:;,])/$1/g;
951 return [ $tapespec, [ 0 ] ];
954 # use a lookbehind to mask out any quoted ;'s
955 my @volumes = split(/(?<!\\);/, $tapespec);
956 for my $vol (@volumes) {
957 my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
959 $label =~ s/\\([\\:;,])/$1/g;
960 push @filelist, $label;
962 my @files = split(/,/, $files);
963 @files = map { $_+0 } @files;
964 @files = sort { $a <=> $b } @files;
965 push @filelist, \@files;
972 push @EXPORT_OK, qw(match_host match_disk match_datestamp match_level);
975 fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
976 fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
977 fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");