Amanda::Util - Runtime support for Amanda applications
Application initialization generally looks like this:
use Amanda::Config qw( :init ); use Amanda::Util qw( :constants ); use Amanda::Debug;
Amanda::Util::setup_application("myapp", "server", $CONTEXT_CMDLINE);
# .. command-line processing ..
Amanda::Config::config_init(...);
Amanda::Util::finish_setup($RUNNING_AS_DUMPUSER);
# ..
Amanda::Util::finish_application();
Set up the operating environment for an application, without requiring any configuration.
$name is the name of the application, used in log messages, etc.
$type is usualy one of "server" or "client". It specifies the
subdirectory in which debug logfiles will be created. $context
indicates the usual manner in which this application is invoked; one
of $CONTEXT_CMDLINE for a user-invoked command-line utility (e.g.,
amadmin) which should send human-readable error messages to stderr;
$CONTEXT_DAEMON for a program started by amandad, e.g.,
sendbackup; or $CONTEXT_SCRIPTUTIL for a small program used from
shell scripts, e.g., amgetconf
Based on $type and $context, this function does the following:
sets up debug logging;
configures internationalization
sets the umask;
sets the current working directory to the debug or temporary directory;
closes any unnecessary file descriptors as a security meaasure;
ignores SIGPIPE; and
sets the appropriate target for error messages.
finish_setup($running_as_flags)Perform final initialization tasks that require a loaded configuration. Specifically, move the debug log into a configuration-specific subdirectory, and check that the current userid is appropriate for this applciation.
The user is specified by one of the following flags, which are
available in export tag :check_running_as_flags:
$RUNNING_AS_ANY # any user is OK $RUNNING_AS_ROOT # root $RUNNING_AS_DUMPUSER # dumpuser, from configuration $RUNNING_AS_DUMPUSER_PREFERRED # dumpuser, but client_login is OK too $RUNNING_AS_CLIENT_LOGIN # client_login (--with-user at build time)
If the flag $RUNNING_AS_UID_ONLY is bit-or'd into
$running_as_flags, then the euid is ignored; this is used for
programs that expect to be setuid-root.
finish_application()Remove old debug files. All applications should call this before exiting.
get_original_cwd()Return the original current directory with get_original_cwd.
version_opt()Print the version and exit. This is intended to be used in GetOptions invocations, e.g.,
GetOptions(
# ...
'version' => \&Amanda::Util::version_opt,
);
These functions read and write the entire requested size to a file descriptor, even if the underlying syscall returns early. Note that they do not operate on Perl file handles.
If fewer than $size bytes are written, full_write returns the
number of bytes actually written and sets $! appropriately. When
reading, if fewer than $size bytes are read due to a normal EOF,
then $! is zero; otherwise, it contains the appropriate error
message.
Unlike POSIX::read, full_read returns a scalar containing the
bytes it read from the file descriptor.
safe_env()Return a "safe" environment hash. For non-setuid programs, this means filtering out any localization variables.
This is a wrapper around the Gnulib function of the same name. On success, it returns a hash with keys:
blocksize Size of a block blocks Total blocks on disk bfree Free blocks available to superuser bavail Free blocks available to non-superuser bavail_top_bit_set 1 if fsu_bavail represents a value < 0 files Total file nodes ffree Free file nodes
On failure, it returns nothing, and $! should be set. If $! is 0, then
this is a system which cannot measure usage without a disk argument, which
this wrapper does not support.
Return 1 is the process with that pid is still alive.
weaken_ref($ref)This is exactly the same as Scalar::Util::weaken, but available in all
supported versions of perl.
gettimeofday()Return the number of microseconds since the UNIX epoch.
fsync($fd)Invoke the fsync syscall.
Set or clear the O_NONBLOCK fd flag on $fd; returns a negative value on
failure, or 0 on success.
openbsd_fd_inform()Due to a particularly poor user-space implementation of threading on OpenBSD, executables that are run with nonstandard file descriptors open (fd > 2) find those descriptors to be in a nonblocking state. This particularly affects amandad services, which begin with several file descriptors in the 50's open.
This function "informs" the C library about these descriptors by making an
fcntl(fd, F_GETFL) call. This is otherwise harmless, and is only perfomed
on OpenBSD.
built_with_component($comp)Returns true if Amanda was built with the given component. Component names are
in config/amanda/components.m4.
These are thin wrappers over functions in common-src/stream.h and other related
functions.
my $family = $Amanda::Util::AF_INET;
my $bufsize = $Amanda::Util::STREAM_BUFSIZE;
my ($listensock, $port) = Amanda::Util::stream_server(
$family, $bufsize, $bufsize, $priv);
This function creates a new socket and binds it to a port, returning both the
socket and port. If the socket is -1, then an error occurred and is available
in $!. The constants $AF_INET and $STREAM_BUFSIZE are universally
used when calling this function. If the final argument, $priv, is true,
then a the function opens a privileged port (below 1024).
my $sock = Amanda::Util::stream_accept(
$listen_sock, $timeout, $bufsize, $bufsize);
This function accepts a connection on a listening socket. If the connection is
not made within $timeout seconds, or some other error occurs, then the
function returns -1. The bufsize arguments are applied to the new socket.
my $ok = Amanda::Util::check_security($socket, $userstr);
This function takes a socket descriptor and a string of the form "USER foo"
and performs BSD-style checks on that descriptor. These include verifying
round-trip DNS sanity; check that the user is in .rhosts or .amandahosts,
and checking that the remote port is reserved. Returns an error string on
error, or undef on success.
quote_string($str)Quote a string using Amanda's quoting algorithm. Strings with no
whitespace, control, or quote characters are returned unchanged. An
empty string is represented as the two-character string "".
Otherwise, tab, newline, carriage return, form-feed, backslash, and
double-quote (") characters are escaped with a backslash and the
string is surrounded by double quotes.
unquote_string($str)Unquote a string as quoted with quote_string.
skip_quoted_string($str)my($q, $remaider) = skip_quoted_string($str)
Return the first quoted string and the remainder of the string, as separated by
any whitespace. Note that the remainder of the string does not include the
single separating whitespace character, but will include any subsequent
whitespace. The $q is not unquoted.
split_quoted_strings($str)Split string on unquoted whitespace. Multiple consecutive spaces are not
collapsed into a single space: "x y" (with two spaces) parses as ( "x",
"", "y"). The strings are unquoted before they are returned. An empty string
is split into ( "" ). This method is generally used for parsing IPC messages,
where blank space is significant and well-controlled.
split_quoted_strings_friendly($str)Similar to split_quoted_strings, but intended for user-friendly uses. In
particular, this function treats any sequence of zero or more whitespace
characters as a separator, rather than the more strict interpretation applied
by split_quoted_strings. All of the strings are unquoted.
All of these quoting-related functions are available under the export
tag :quoting.
hexencode($str)Encode a string using URI-style hexadecimal encoding. Non-alphanumeric characters will be replaced with "%xx" where "xx" is the two-digit hexadecimal representation of the character.
hexdecode($str)Decode a string using URI-style hexadecimal encoding.
Both hexencode and hexdecode are available under the export tag :encoding
expand_braced_alternates($str)
=item collapse_braced_alternates(\@list)These two functions handle "braced alternates", which is a syntax borrowed, partially, from shells. Comma-separated strings enclosed in curly braces expand into multiple alternatives for the entire string. For example:
"{foo,bar,bat}" [ "foo", "bar", "bat" ]
"foo{1,2}bar" [ "foo1bar", "foo2bar" ]
"foo{1\,2,3}bar" [ "foo1,2bar", "foo3bar" ]
"{a,b}-{1,2}" [ "a-1", "a-2", "b-1", "b-2" ]
Note that nested braces are not processed. Braces, commas, and
backslashes may be escaped with backslashes. On error,
expand_braced_altnerates returns undef. These two functions are
available in the export tag :alternates.
generate_timestamp()Generate a timestamp from the current time, obeying the 'USETIMESTAMPS' config parameter. The Amanda configuration must already be loaded.
sanitise_filename($fn)"Santitises" a filename by replacing any characters that might have special meaning to a filesystem with underscores. This operation is not reversible, and distinct input filenames may produce identical output filenames.
unmarshal_tapespec($tapespec)
=item marshal_tapespec($filelist)These functions convert between a tapespec -- formerly, and confusingly, called a "tapelist" -- and a perl data structure like
[ $label1 => [ $filenum1, $filenum2, .. ],
$label2 => [ $filenum1, $filenum2, .. ],
]
Note that a non-tapespec $string will be unmarshalled as [ $string, [] ].
Amanda provides a basic mechanism to lock a file and read its contents. This uses operating-system facilities to acquire an advisory lock, so non-Amanda applications are not prevented from modifying the file while it is locked.
To create a lock object, call the file_lock constructor, passing the
filename to lock:
my $fl = Amanda::Util::file_lock->new($filename)
then, lock the file:
$fl->lock();
which also reads the contents of the file into memory, accessible via
my $state = $fl->data();
to change the file contents, call write:
$fl->write($new_contents);
and unlock the lock with
$fl->unlock();
Note that the file will be automatically unlocked if the file_lock object is
garbage-collected.
For reading small files directly into memory with little code
overhead, we can use slurp.
my $data = slurp $filename;
After processing the data, we can write it back to file with burp. This
function always completely overwrites the file.
burp $filename, $header;
These functions can (and should) be exported to the main namespace
=cut
use Amanda::Debug qw(:init); use Amanda::Config qw(:getconf); use warnings; use Carp; use POSIX qw( :fcntl_h :errno_h ); use POSIX qw( strftime ); use Amanda::Constants; use Amanda::Process;
# private package variables my $_pname; my $_ptype; my $_pcontext;
sub setup_application { my ($name, $type, $context) = @_;
# sanity check
croak("no name given") unless ($name);
croak("no type given") unless ($type);
croak("no context given") unless ($context);
# store these as perl values
$_pname = $name;
$_ptype = $type;
$_pcontext = $context;
# and let the C side know about them too
set_pname($name);
set_ptype($type);
set_pcontext($context);
safe_cd(); # (also sets umask)
check_std_fds();
# set up debugging, now that we have a name, type, and context
debug_init();
# ignore SIGPIPE
$SIG{'PIPE'} = 'IGNORE';
}
sub finish_setup { my ($running_as) = @_;
my $config_name = Amanda::Config::get_config_name();
if ($config_name) {
dbrename($config_name, $_ptype);
}
check_running_as($running_as);
}
sub finish_application {
dbclose();
}
sub version_opt { print "$_pname-$Amanda::Constants::VERSION\n"; exit 0; }
push @EXPORT_OK, qw(get_original_cwd); push @{$EXPORT_TAGS{"util"}}, qw(get_original_cwd);
sub safe_env { my %rv = %ENV;
delete @rv{qw(IFS CDPATH ENV BASH_ENV LANG)};
# delete all LC_* variables
for my $var (grep /^LC_/, keys %rv) {
delete $rv{$var};
}
return %rv;
}
push @EXPORT_OK, qw(running_as_flags_to_strings); push @{$EXPORT_TAGS{"running_as_flags"}}, qw(running_as_flags_to_strings);
my %_running_as_flags_VALUES; #Convert a flag value to a list of names for flags that are set. sub running_as_flags_to_strings { my ($flags) = @_; my @result = ();
for my $k (keys %_running_as_flags_VALUES) {
my $v = $_running_as_flags_VALUES{$k};
#is this a matching flag?
if (($v == 0 && $flags == 0) || ($v != 0 && ($flags & $v) == $v)) {
push @result, $k;
}
}
#by default, just return the number as a 1-element list if (!@result) { return ($flags); }
return @result;
}
push @EXPORT_OK, qw($RUNNING_AS_ANY);
push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ANY);
$_running_as_flags_VALUES{"RUNNING_AS_ANY"} = $RUNNING_AS_ANY;
push @EXPORT_OK, qw($RUNNING_AS_ROOT);
push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ROOT);
$_running_as_flags_VALUES{"RUNNING_AS_ROOT"} = $RUNNING_AS_ROOT;
push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER);
push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER);
$_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER"} = $RUNNING_AS_DUMPUSER;
push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER_PREFERRED);
push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER_PREFERRED);
$_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER_PREFERRED"} = $RUNNING_AS_DUMPUSER_PREFERRED;
push @EXPORT_OK, qw($RUNNING_AS_CLIENT_LOGIN);
push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_CLIENT_LOGIN);
$_running_as_flags_VALUES{"RUNNING_AS_CLIENT_LOGIN"} = $RUNNING_AS_CLIENT_LOGIN;
push @EXPORT_OK, qw($RUNNING_AS_UID_ONLY);
push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_UID_ONLY);
$_running_as_flags_VALUES{"RUNNING_AS_UID_ONLY"} = $RUNNING_AS_UID_ONLY;
#copy symbols in running_as_flags to constants push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"running_as_flags"}};
push @EXPORT_OK, qw(pcontext_t_to_string); push @{$EXPORT_TAGS{"pcontext_t"}}, qw(pcontext_t_to_string);
my %_pcontext_t_VALUES; #Convert an enum value to a single string sub pcontext_t_to_string { my ($enumval) = @_;
for my $k (keys %_pcontext_t_VALUES) {
my $v = $_pcontext_t_VALUES{$k};
#is this a matching flag?
if ($enumval == $v) {
return $k;
}
}
#default, just return the number return $enumval; }
push @EXPORT_OK, qw($CONTEXT_DEFAULT);
push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DEFAULT);
$_pcontext_t_VALUES{"CONTEXT_DEFAULT"} = $CONTEXT_DEFAULT;
push @EXPORT_OK, qw($CONTEXT_CMDLINE);
push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_CMDLINE);
$_pcontext_t_VALUES{"CONTEXT_CMDLINE"} = $CONTEXT_CMDLINE;
push @EXPORT_OK, qw($CONTEXT_DAEMON);
push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DAEMON);
$_pcontext_t_VALUES{"CONTEXT_DAEMON"} = $CONTEXT_DAEMON;
push @EXPORT_OK, qw($CONTEXT_SCRIPTUTIL);
push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_SCRIPTUTIL);
$_pcontext_t_VALUES{"CONTEXT_SCRIPTUTIL"} = $CONTEXT_SCRIPTUTIL;
#copy symbols in pcontext_t to constants push @{$EXPORT_TAGS{"constants"}}, @{$EXPORT_TAGS{"pcontext_t"}};
sub full_read { my ($fd, $count) = @_; my @bufs;
while ($count > 0) {
my $b;
my $n_read = POSIX::read($fd, $b, $count);
if (!defined $n_read) {
next if ($! == EINTR);
return undef;
} elsif ($n_read == 0) {
last;
}
push @bufs, $b;
$count -= $n_read;
}
return join('', @bufs);
}
sub full_write { my ($fd, $buf, $count) = @_; my $total = 0;
while ($count > 0) {
my $n_written = POSIX::write($fd, $buf, $count);
if (!defined $n_written) {
next if ($! == EINTR);
return undef;
} elsif ($n_written == 0) {
last;
}
$count -= $n_written;
$total += $n_written;
if ($count) {
$buf = substr($buf, $n_written);
}
}
return $total;
}
sub skip_quoted_string { my $str = shift;
chomp $str;
my $iq = 0;
my $i = 0;
my $c = substr $str, $i, 1;
while ($c ne "" && !($iq == 0 && $c =~ /\s/)) {
if ($c eq '"') {
$iq = !$iq;
} elsif ($c eq '\\') {
$i++;
}
$i++;
$c = substr $str, $i, 1;
}
my $quoted_string = substr $str, 0, $i;
my $remainder = undef;
if (length($str) > $i) {
$remainder = substr $str, $i+1;
}
return ($quoted_string, $remainder);
}
sub split_quoted_string_friendly { my $str = shift; my @result;
chomp $str;
$str =~ s/^\s+//;
while ($str) {
(my $elt, $str) = skip_quoted_string($str);
push @result, unquote_string($elt);
$str =~ s/^\s+// if $str;
}
return @result;
}
push @EXPORT_OK, qw(slurp);
push @EXPORT_OK, qw(burp);
push @EXPORT_OK, qw(safe_overwrite_file);
sub slurp { my $file = shift @_; local $/;
open my $fh, "<", $file or croak "can't open $file: $!";
my $data = <$fh>;
close $fh;
return $data;
}
sub burp { my $file = shift @_; open my $fh, ">", $file or croak "can't open $file: $!"; print $fh @_; }
sub safe_overwrite_file { my ( $filename, $contents ) = @_;
my $tmpfname = "$filename." . time;
open my $tmpfh, ">", $tmpfname or die "open: $!";
print $tmpfh $contents;
(fsync($tmpfh) == 0) or die "fsync: $!";
return rename $tmpfname, $filename;
}
push @EXPORT_OK, qw(hexencode hexdecode); push @{$EXPORT_TAGS{"encoding"}}, qw(hexencode hexdecode);
push @EXPORT_OK, qw(quote_string unquote_string skip_quoted_string sanitise_filename split_quoted_strings split_quoted_strings_friendly); push @{$EXPORT_TAGS{"quoting"}}, qw(quote_string unquote_string skip_quoted_string sanitise_filename split_quoted_strings split_quoted_strings_friendly);
push @EXPORT_OK, qw(expand_braced_alternates collapse_braced_alternates); push @{$EXPORT_TAGS{"alternates"}}, qw(expand_braced_alternates collapse_braced_alternates);
sub generate_timestamp { # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time if (getconf($CNF_USETIMESTAMPS)) { return strftime "%Y%m%d%H%M%S", localtime; } else { return strftime "%Y%m%d", localtime; } }
sub built_with_component { my ($component) = @_; my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS; return grep { $_ eq $component } @components; }
sub is_pid_alive { my ($pid) = shift;
return 1 if $pid == $$;
my $Amanda_process = Amanda::Process->new(0);
$Amanda_process->load_ps_table();
my $alive = $Amanda_process->process_alive($pid);
return $alive;
}
push @EXPORT_OK, qw(weaken_ref);
push @EXPORT_OK, qw(stream_server stream_accept check_security);
push @EXPORT_OK, qw($AF_INET $STREAM_BUFSIZE); push @{$EXPORT_TAGS{"constants"}}, qw($AF_INET $STREAM_BUFSIZE);
# these functions were verified to work similarly to those in # common-src/tapelist.c - they pass the same tests, at least.
sub marshal_tapespec { my ($filelist) = @_; my @filelist = @$filelist; # make a copy we can wreck my @specs;
while (@filelist) {
my $label = shift @filelist;
my $files = shift @filelist;
$label =~ s/([\\:;,])/\\$1/g;
push @specs, "$label:" . join(",", @$files);
}
return join(";", @specs);
}
sub unmarshal_tapespec { my ($tapespec) = @_; my @filelist;
# detect a non-tapespec string for special handling; in particular, a string
# without an unquoted : followed by digits and commas at the end. The easiest
# way to do this is to replace every quoted character with a dummy, then look
# for the colon and digits.
my $tmp = $tapespec;
$tmp =~ s/\\([\\:;,])/X/g;
if ($tmp !~ /:[,\d]+$/) {
# ok, it doesn't end with the right form, so unquote it and return it
# with filenum 0
$tapespec =~ s/\\([\\:;,])/$1/g;
return [ $tapespec, [ 0 ] ];
}
# use a lookbehind to mask out any quoted ;'s
my @volumes = split(/(?<!\\);/, $tapespec);
for my $vol (@volumes) {
my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
$label =~ s/\\([\\:;,])/$1/g;
push @filelist, $label;
my @files = split(/,/, $files);
@files = map { $_+0 } @files;
@files = sort { $a <=> $b } @files;
push @filelist, \@files;
}
return \@filelist;
}
sub check_std_fds { fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open"); fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open"); fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open"); }
1;
This page was automatically generated Tue Nov 19 20:05:35 2013 from the Amanda source tree, and documents the most recent development version of Amanda. For documentation specific to the version of Amanda on your system, use the 'perldoc' command.