X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=perl%2FAmanda%2FUtil.swg;h=f7ebacaf968241c17d24555aa1be6316e1e61f5b;hb=b221e8dc16f345f8c8d7df8df71f4d36daaabb4c;hp=2d6627663ee7ab248f3896d59390ae5c01a63fae;hpb=2627875b7d18858bc1f9f7652811e4d8c15a23eb;p=debian%2Famanda diff --git a/perl/Amanda/Util.swg b/perl/Amanda/Util.swg index 2d66276..f7ebaca 100644 --- a/perl/Amanda/Util.swg +++ b/perl/Amanda/Util.swg @@ -1,108 +1,53 @@ /* - * Copyright (c) Zmanda, Inc. All Rights Reserved. + * Copyright (c) 2007, 2008, 2009, 2010 Zmanda, Inc. All Rights Reserved. * - * This library is free software; you can redistribute it and/or modify it - * under the terms of the GNU Lesser General Public License version 2.1 - * as published by the Free Software Foundation. + * This program is free software; you can redistribute it and/or modify it + * under the terms of the GNU General Public License version 2 as published + * by the Free Software Foundation. * - * This library is distributed in the hope that it will be useful, but + * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY - * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public - * License for more details. + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + * for more details. * - * You should have received a copy of the GNU Lesser General Public License - * along with this library; if not, write to the Free Software Foundation, - * Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * - * Contact information: Zmanda Inc., 465 S Mathlida Ave, Suite 300 - * Sunnyvale, CA 94086, USA, or: http://www.zmanda.com + * Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300 + * Sunnyvale, CA 94085, USA, or: http://www.zmanda.com */ %module "Amanda::Util" %include "amglue/amglue.swg" %include "exception.i" +%include "Amanda/Util.pod" + %{ +#include +#include "amglue.h" #include "debug.h" +#include "full-read.h" +#include "full-write.h" +#include "fsusage.h" +#include "stream.h" /* use a relative path here to avoid conflicting with Perl's util.h. */ #include "../common-src/util.h" #include "file.h" +#include "sockaddr-util.h" %} %perlcode %{ + use Amanda::Debug qw(:init); use Amanda::Config qw(:getconf); +use warnings; use Carp; -use POSIX qw( :fcntl_h strftime ); - -=head1 NAME - -Amanda::Util - Runtime support for Amanda applications - -=head1 Application Initialization - -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); - -=over - -=item C - -Set up the operating environment for an application, without requiring any -configuration. - -C<$name> is the name of the application, used in log messages, etc. C<$type> -is usualy one of "server" or "client". It specifies the subdirectory in which -debug logfiles will be created. C<$context> indicates the usual manner in -which this application is invoked; one of C<$CONTEXT_CMDLINE> for a -user-invoked command-line utility (e.g., C) which should send -human-readable error messages to stderr; C<$CONTEXT_DAEMON> for a program -started by C, e.g., C; or C<$CONTEXT_SCRIPTUTIL> for a -small program used from shell scripts, e.g., C - -Based on C<$type> and C<$context>, this function does the following: - -=over - -=item * - -sets up debug logging; - -=item * - -configures internationalization - -=item * - -sets the umask; - -=item * - -sets the current working directory to the debug or temporary directory; - -=item * - -closes any unnecessary file descriptors as a security meaasure; - -=item * - -ignores C; and - -=item * - -sets the appropriate target for error messages. - -=back - -=cut +use POSIX qw( :fcntl_h :errno_h ); +use POSIX qw( strftime ); +use Amanda::Constants; +use Amanda::Process; # private package variables my $_pname; @@ -137,27 +82,6 @@ sub setup_application { $SIG{'PIPE'} = 'IGNORE'; } -=item C - -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 C<: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 C<$RUNNING_AS_UID_ONLY> is bit-or'd into C<$running_as_flags>, then -the euid is ignored; this is used for programs that expect to be setuid-root. - -=cut - sub finish_setup { my ($running_as) = @_; @@ -170,25 +94,20 @@ sub finish_setup { check_running_as($running_as); } -=item C +sub finish_application { + dbclose(); +} -Return the original current directory with C. +sub version_opt { + print "$_pname-$Amanda::Constants::VERSION\n"; + exit 0; +} -=cut %} char *get_original_cwd(void); amglue_export_tag(util, get_original_cwd); %perlcode %{ -=head1 Miscellaneous Utilities - -=item C - -Return a "safe" environment hash. For non-setuid programs, this means filtering out any -localization variables. - -=cut - sub safe_env { my %rv = %ENV; @@ -221,28 +140,49 @@ amglue_add_constant(CONTEXT_SCRIPTUTIL, pcontext_t); amglue_copy_to_tag(pcontext_t, constants); %perlcode %{ -=item C - -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 C<"">. Otherwise, tab, newline, -carriage return, form-feed, backslash, and double-quote (C<">) characters are -escaped with a backslash and the string is surrounded by double quotes. - -=item C - -Unquote a string as quoted with C. +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; + } -=item C + return join('', @bufs); +} -my($q, $remaider) = skip_quoted_string($str) +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; + } -Return the first quoted string and the remainder of the string. + $count -= $n_written; + $total += $n_written; -Both C, C and C are -available under the export tag C<:quoting>. + if ($count) { + $buf = substr($buf, $n_written); + } + } -=cut + return $total; +} sub skip_quoted_string { my $str = shift; @@ -261,25 +201,155 @@ sub skip_quoted_string { $c = substr $str, $i, 1; } my $quoted_string = substr $str, 0, $i; - my $remainder = substr $str, $i+1; + 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; +} + +%} + +amglue_export_ok(slurp); +amglue_export_ok(burp); +amglue_export_ok(safe_overwrite_file); + +%perlcode %{ + +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; +} + %} +%typemap (in) GPtrArray * { + AV *av; + guint len; + int i; + + if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) { + SWIG_exception(SWIG_TypeError, "Expected an arrayref"); + } + av = (AV *)SvRV($input); + + len = av_len(av)+1; /* av_len(av) is like $#av */ + $1 = g_ptr_array_sized_new(len); + for (i = 0; i < len; i++) { + SV **elt = av_fetch(av, i, 0); + if (!elt || !SvPOK(*elt)) { + SWIG_exception(SWIG_TypeError, "Non-string in arrayref"); + } + g_ptr_array_add($1, SvPV_nolen(*elt)); /* TODO: handle unicode here */ + } +} +%typemap (freearg) GPtrArray * { + g_ptr_array_free($1, FALSE); +} + +%typemap (out) GPtrArray * { + if ($1) { + guint i; + for (i = 0; i < $1->len; i++) { + $result = sv_2mortal(newSVpv(g_ptr_array_index($1, i), 0)); + argvi++; + } + g_ptr_array_free($1, TRUE); + } else { + $result = &PL_sv_undef; + argvi++; + } +} + +/* for split_quoted_strings */ +%typemap(out) gchar ** { + gchar **iter; + + if ($1) { + /* Count the DeviceProperties */ + EXTEND(SP, g_strv_length($1)); /* make room for return values */ + + /* Note that we set $result several times. the nature of + * SWIG's wrapping is such that incrementing argvi points + * $result to the next location in perl's argument stack. + */ + + for (iter = $1; *iter; iter++) { + $result = sv_2mortal(newSVpv(*iter, 0)); + argvi++; + } + } +} + +%rename(hexencode) hexencode_string; +char *hexencode_string(char *); +%rename(hexdecode) perl_hexdecode_string; +char *perl_hexdecode_string(char *); +%{ +char *perl_hexdecode_string(const char *str) { + GError *err = NULL; + char *tmp; + tmp = hexdecode_string(str, &err); + if (err) { + g_free(tmp); + croak_gerror("Amanda util: hexdecode", &err); + } + return tmp; +} +%} +amglue_export_tag(encoding, hexencode hexdecode); + char *sanitise_filename(char *inp); char *quote_string(char *); char *unquote_string(char *); -amglue_export_tag(quoting, quote_string unquote_string skip_quoted_string sanitise_filename); +GPtrArray *expand_braced_alternates(char *); +%newobject collapse_braced_alternates; +char *collapse_braced_alternates(GPtrArray *source); +gchar **split_quoted_strings(const gchar *string); +amglue_export_tag(quoting, quote_string unquote_string skip_quoted_string + sanitise_filename split_quoted_strings split_quoted_strings_friendly); +amglue_export_tag(alternates, expand_braced_alternates collapse_braced_alternates); %perlcode %{ -=item C - -Generate a timestamp from the current time, obeying the 'USETIMESTAMPS' -config parameter. The Amanda configuration must already be loaded. - -=cut sub generate_timestamp { # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time @@ -289,6 +359,278 @@ sub generate_timestamp { return strftime "%Y%m%d", localtime; } } + +sub built_with_component { + my ($component) = @_; + my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS; + return grep { $_ eq $component } @components; +} + +%} + +/* interface to gnulib's fsusage */ +%typemap(in,numinputs=0) (struct fs_usage *fsp) + (struct fs_usage fsu) { + bzero(&fsu, sizeof(fsu)); + $1 = &fsu; +} + +%typemap(argout) (struct fs_usage *fsp) { + SV *sv; + HV *hv; + + /* if there was an error, assume that fsu_blocksize isn't changed, + * and return undef. */ + if ($1->fsu_blocksize) { + SP += argvi; PUTBACK; /* save the perl stack so amglue_newSVi64 doesn't kill it */ + hv = (HV *)sv_2mortal((SV *)newHV()); + hv_store(hv, "blocksize", 9, amglue_newSVi64($1->fsu_blocksize), 0); + hv_store(hv, "blocks", 6, amglue_newSVi64($1->fsu_blocks), 0); + hv_store(hv, "bfree", 5, amglue_newSVi64($1->fsu_bfree), 0); + hv_store(hv, "bavail", 6, amglue_newSVi64($1->fsu_bavail), 0); + hv_store(hv, "bavail_top_bit_set", 18, newSViv($1->fsu_bavail_top_bit_set), 0); + hv_store(hv, "files", 5, amglue_newSVi64($1->fsu_files), 0); + hv_store(hv, "ffree", 5, amglue_newSVi64($1->fsu_ffree), 0); + + $result = newRV((SV *)hv); + SPAGAIN; SP -= argvi; + argvi++; + } +} + +%rename(get_fs_usage) get_fs_usage_; +%inline %{ +void get_fs_usage_(const char *file, struct fs_usage *fsp) +{ + int rv = get_fs_usage(file, NULL, fsp); + if (rv == -1) + /* signal an error to the typemap */ + fsp->fsu_blocksize = 0; +} +%} + +/* + * Operations that should be in Perl but aren't + */ + +int fsync(int fd); + +/* Perl's fcntl only operates on file handles */ +%inline %{ +int +set_blocking(int fd, gboolean blocking) +{ + int flags = fcntl(fd, F_GETFL, 0); + if (flags < 0) + return flags; + if (blocking) + flags &= ~O_NONBLOCK; + else + flags |= O_NONBLOCK; + flags = fcntl(fd, F_SETFL, flags); + if (flags < 0) + return flags; + return 0; +} +%} + +/* + * Locking (see amflock.h) + */ + +/* SWIG prepends the struct name to the member function name, which + * conflicts with the underlying function names */ + +typedef struct file_lock { + %extend { + file_lock(const char *filename) { + return file_lock_new(filename); + } + + ~locked_data() { + file_lock_free(self); + } + + int lock(); + int lock_wr(); + int lock_rd(); + int unlock(); + int locked(); + + %typemap(in) (const char *data, size_t len) { + $1 = SvPV($input, $2); + } + + int write(const char *data, size_t len); + + /* get the data as an SV */ + %typemap(out) (SV *) { $result = $1; argvi++; }; + SV *data() { + if (self->data) { + return newSVpvn(self->data, self->len); + } else { + return &PL_sv_undef; + } + } + %typemap(out) (SV *); + } +} file_lock; + +%perlcode %{ + +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; + +} +%} + +/* Interesting story: Perl added a sv_rvweaken function in 5.6.0 (or earlier?), but + * did not include this functionality in Scalar::Util until later. It doesn't make + * much sense, does it? */ +amglue_export_ok(weaken_ref) +%typemap(in) SV *rv "$1 = $input;" +%inline %{ +void weaken_ref(SV *rv) { + sv_rvweaken(rv); +} +%} + +%rename(gettimeofday) gettimeofday_for_perl; +%inline %{ +static guint64 gettimeofday_for_perl(void) +{ + GTimeVal t; + g_get_current_time(&t); + return (guint64)t.tv_sec * G_USEC_PER_SEC + (guint64)t.tv_usec; +} +%} + +void openbsd_fd_inform(void); + +/* + * Streams + * + * TODO: this should move to Amanda::Security when the rest of the Security API + * is available from Perl. + */ + +enum { AF_INET }; +enum { STREAM_BUFSIZE }; +%typemap(in, numinputs=0) in_port_t *port_ARGOUT (in_port_t port) { + $1 = &port; +} +%typemap(argout) in_port_t *port_ARGOUT { + $result = sv_2mortal(newSViv(*$1)); + argvi++; +} +/* avoid BigInts for socket fd's */ +%{ typedef int socketfd; %} +%typemap(out) socketfd { + $result = sv_2mortal(newSViv($1)); + argvi++; +} +socketfd stream_server(int family, in_port_t *port_ARGOUT, size_t sendsize, + size_t recvsize, gboolean privileged); + +socketfd stream_accept(int fd, int timeout, size_t sendsize, size_t recvsize); + +%newobject check_security_fd; +%rename(check_security) check_security_fd; +%inline %{ +char *check_security_fd(int fd, char *userstr) +{ + socklen_t_equiv i; + struct sockaddr_in addr; + char *errstr; + + /* get the remote address */ + i = SIZEOF(addr); + if (getpeername(fd, (struct sockaddr *)&addr, &i) == -1) { + return g_strdup_printf("getpeername: %s", strerror(errno)); + } + + /* require IPv4 and not port 20 -- apparently this was a common attack + * vector for much older Amandas */ + if ((addr.sin_family != (sa_family_t)AF_INET) + || (ntohs(addr.sin_port) == 20)) { + return g_strdup_printf("connection rejected from %s family %d port %d", + inet_ntoa(addr.sin_addr), addr.sin_family, htons(addr.sin_port)); + } + + /* call out to check_security */ + if (!check_security((sockaddr_union *)&addr, userstr, 0, &errstr)) + return errstr; + + return NULL; +} +%} +amglue_export_ok( + stream_server stream_accept check_security); +amglue_export_tag(constants, + $AF_INET $STREAM_BUFSIZE); + +%perlcode %{ + +# 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(/(? $b } @files; + push @filelist, \@files; + } + + return \@filelist; +} + %} /* ------------------------------------------------------------------------- @@ -296,8 +638,11 @@ sub generate_timestamp { * do not call them externally. */ void set_pname(char *name); +char *get_pname(); void set_ptype(char *type); +char *get_ptype(); void set_pcontext(pcontext_t context); +pcontext_t get_pcontext(); void safe_cd(void); void check_running_as(running_as_flags who); @@ -311,7 +656,4 @@ sub check_std_fds { fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open"); } -=back - -=cut %}