2 * Copyright (c) 2007, 2008, 2009, 2010 Zmanda, Inc. All Rights Reserved.
4 * This program is free software; you can redistribute it and/or modify it
5 * under the terms of the GNU General Public License version 2 as published
6 * by the Free Software Foundation.
8 * This program is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
10 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13 * You should have received a copy of the GNU General Public License along
14 * with this program; if not, write to the Free Software Foundation, Inc.,
15 * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17 * Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300
18 * Sunnyvale, CA 94085, USA, or: http://www.zmanda.com
21 %module "Amanda::Util"
22 %include "amglue/amglue.swg"
23 %include "exception.i"
25 %include "Amanda/Util.pod"
31 #include "full-read.h"
32 #include "full-write.h"
35 /* use a relative path here to avoid conflicting with Perl's util.h. */
36 #include "../common-src/util.h"
38 #include "sockaddr-util.h"
43 use Amanda::Debug qw(:init);
44 use Amanda::Config qw(:getconf);
47 use POSIX qw( :fcntl_h :errno_h );
48 use POSIX qw( strftime );
49 use Amanda::Constants;
52 # private package variables
57 sub setup_application {
58 my ($name, $type, $context) = @_;
61 croak("no name given") unless ($name);
62 croak("no type given") unless ($type);
63 croak("no context given") unless ($context);
65 # store these as perl values
68 $_pcontext = $context;
70 # and let the C side know about them too
73 set_pcontext($context);
75 safe_cd(); # (also sets umask)
78 # set up debugging, now that we have a name, type, and context
82 $SIG{'PIPE'} = 'IGNORE';
86 my ($running_as) = @_;
88 my $config_name = Amanda::Config::get_config_name();
91 dbrename($config_name, $_ptype);
94 check_running_as($running_as);
97 sub finish_application {
102 print "$_pname-$Amanda::Constants::VERSION\n";
107 char *get_original_cwd(void);
108 amglue_export_tag(util, get_original_cwd);
114 delete @rv{qw(IFS CDPATH ENV BASH_ENV LANG)};
116 # delete all LC_* variables
117 for my $var (grep /^LC_/, keys %rv) {
126 amglue_add_flag_tag_fns(running_as_flags);
127 amglue_add_constant(RUNNING_AS_ANY, running_as_flags);
128 amglue_add_constant(RUNNING_AS_ROOT, running_as_flags);
129 amglue_add_constant(RUNNING_AS_DUMPUSER, running_as_flags);
130 amglue_add_constant(RUNNING_AS_DUMPUSER_PREFERRED, running_as_flags);
131 amglue_add_constant(RUNNING_AS_CLIENT_LOGIN, running_as_flags);
132 amglue_add_constant(RUNNING_AS_UID_ONLY, running_as_flags);
133 amglue_copy_to_tag(running_as_flags, constants);
135 amglue_add_enum_tag_fns(pcontext_t);
136 amglue_add_constant(CONTEXT_DEFAULT, pcontext_t);
137 amglue_add_constant(CONTEXT_CMDLINE, pcontext_t);
138 amglue_add_constant(CONTEXT_DAEMON, pcontext_t);
139 amglue_add_constant(CONTEXT_SCRIPTUTIL, pcontext_t);
140 amglue_copy_to_tag(pcontext_t, constants);
144 my ($fd, $count) = @_;
149 my $n_read = POSIX::read($fd, $b, $count);
150 if (!defined $n_read) {
151 next if ($! == EINTR);
153 } elsif ($n_read == 0) {
160 return join('', @bufs);
164 my ($fd, $buf, $count) = @_;
168 my $n_written = POSIX::write($fd, $buf, $count);
169 if (!defined $n_written) {
170 next if ($! == EINTR);
172 } elsif ($n_written == 0) {
176 $count -= $n_written;
177 $total += $n_written;
180 $buf = substr($buf, $n_written);
187 sub skip_quoted_string {
193 my $c = substr $str, $i, 1;
194 while ($c ne "" && !($iq == 0 && $c =~ /\s/)) {
197 } elsif ($c eq '\\') {
201 $c = substr $str, $i, 1;
203 my $quoted_string = substr $str, 0, $i;
204 my $remainder = undef;
205 if (length($str) > $i) {
206 $remainder = substr $str, $i+1;
209 return ($quoted_string, $remainder);
212 sub split_quoted_string_friendly {
219 (my $elt, $str) = skip_quoted_string($str);
220 push @result, unquote_string($elt);
221 $str =~ s/^\s+// if $str;
229 amglue_export_ok(slurp);
230 amglue_export_ok(burp);
231 amglue_export_ok(safe_overwrite_file);
239 open my $fh, "<", $file or croak "can't open $file: $!";
248 open my $fh, ">", $file or croak "can't open $file: $!";
252 sub safe_overwrite_file {
253 my ( $filename, $contents ) = @_;
255 my $tmpfname = "$filename." . time;
256 open my $tmpfh, ">", $tmpfname or die "open: $!";
258 print $tmpfh $contents;
259 (fsync($tmpfh) == 0) or die "fsync: $!";
260 return rename $tmpfname, $filename;
265 %typemap (in) GPtrArray * {
270 if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) {
271 SWIG_exception(SWIG_TypeError, "Expected an arrayref");
273 av = (AV *)SvRV($input);
275 len = av_len(av)+1; /* av_len(av) is like $#av */
276 $1 = g_ptr_array_sized_new(len);
277 for (i = 0; i < len; i++) {
278 SV **elt = av_fetch(av, i, 0);
279 if (!elt || !SvPOK(*elt)) {
280 SWIG_exception(SWIG_TypeError, "Non-string in arrayref");
282 g_ptr_array_add($1, SvPV_nolen(*elt)); /* TODO: handle unicode here */
285 %typemap (freearg) GPtrArray * {
286 g_ptr_array_free($1, FALSE);
289 %typemap (out) GPtrArray * {
292 for (i = 0; i < $1->len; i++) {
293 $result = sv_2mortal(newSVpv(g_ptr_array_index($1, i), 0));
296 g_ptr_array_free($1, TRUE);
298 $result = &PL_sv_undef;
303 /* for split_quoted_strings */
304 %typemap(out) gchar ** {
308 /* Count the DeviceProperties */
309 EXTEND(SP, g_strv_length($1)); /* make room for return values */
311 /* Note that we set $result several times. the nature of
312 * SWIG's wrapping is such that incrementing argvi points
313 * $result to the next location in perl's argument stack.
316 for (iter = $1; *iter; iter++) {
317 $result = sv_2mortal(newSVpv(*iter, 0));
323 %rename(hexencode) hexencode_string;
324 char *hexencode_string(char *);
325 %rename(hexdecode) perl_hexdecode_string;
326 char *perl_hexdecode_string(char *);
328 char *perl_hexdecode_string(const char *str) {
331 tmp = hexdecode_string(str, &err);
334 croak_gerror("Amanda util: hexdecode", &err);
339 amglue_export_tag(encoding, hexencode hexdecode);
341 char *sanitise_filename(char *inp);
342 char *quote_string(char *);
343 char *unquote_string(char *);
344 GPtrArray *expand_braced_alternates(char *);
345 %newobject collapse_braced_alternates;
346 char *collapse_braced_alternates(GPtrArray *source);
347 gchar **split_quoted_strings(const gchar *string);
348 amglue_export_tag(quoting, quote_string unquote_string skip_quoted_string
349 sanitise_filename split_quoted_strings split_quoted_strings_friendly);
350 amglue_export_tag(alternates, expand_braced_alternates collapse_braced_alternates);
354 sub generate_timestamp {
355 # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time
356 if (getconf($CNF_USETIMESTAMPS)) {
357 return strftime "%Y%m%d%H%M%S", localtime;
359 return strftime "%Y%m%d", localtime;
363 sub built_with_component {
364 my ($component) = @_;
365 my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
366 return grep { $_ eq $component } @components;
371 /* interface to gnulib's fsusage */
372 %typemap(in,numinputs=0) (struct fs_usage *fsp)
373 (struct fs_usage fsu) {
374 bzero(&fsu, sizeof(fsu));
378 %typemap(argout) (struct fs_usage *fsp) {
382 /* if there was an error, assume that fsu_blocksize isn't changed,
383 * and return undef. */
384 if ($1->fsu_blocksize) {
385 SP += argvi; PUTBACK; /* save the perl stack so amglue_newSVi64 doesn't kill it */
386 hv = (HV *)sv_2mortal((SV *)newHV());
387 hv_store(hv, "blocksize", 9, amglue_newSVi64($1->fsu_blocksize), 0);
388 hv_store(hv, "blocks", 6, amglue_newSVi64($1->fsu_blocks), 0);
389 hv_store(hv, "bfree", 5, amglue_newSVi64($1->fsu_bfree), 0);
390 hv_store(hv, "bavail", 6, amglue_newSVi64($1->fsu_bavail), 0);
391 hv_store(hv, "bavail_top_bit_set", 18, newSViv($1->fsu_bavail_top_bit_set), 0);
392 hv_store(hv, "files", 5, amglue_newSVi64($1->fsu_files), 0);
393 hv_store(hv, "ffree", 5, amglue_newSVi64($1->fsu_ffree), 0);
395 $result = newRV((SV *)hv);
396 SPAGAIN; SP -= argvi;
401 %rename(get_fs_usage) get_fs_usage_;
403 void get_fs_usage_(const char *file, struct fs_usage *fsp)
405 int rv = get_fs_usage(file, NULL, fsp);
407 /* signal an error to the typemap */
408 fsp->fsu_blocksize = 0;
413 * Operations that should be in Perl but aren't
418 /* Perl's fcntl only operates on file handles */
421 set_blocking(int fd, gboolean blocking)
423 int flags = fcntl(fd, F_GETFL, 0);
427 flags &= ~O_NONBLOCK;
430 flags = fcntl(fd, F_SETFL, flags);
438 * Locking (see amflock.h)
441 /* SWIG prepends the struct name to the member function name, which
442 * conflicts with the underlying function names */
444 typedef struct file_lock {
446 file_lock(const char *filename) {
447 return file_lock_new(filename);
451 file_lock_free(self);
460 %typemap(in) (const char *data, size_t len) {
461 $1 = SvPV($input, $2);
464 int write(const char *data, size_t len);
466 /* get the data as an SV */
467 %typemap(out) (SV *) { $result = $1; argvi++; };
470 return newSVpvn(self->data, self->len);
475 %typemap(out) (SV *);
484 return 1 if $pid == $$;
486 my $Amanda_process = Amanda::Process->new(0);
488 $Amanda_process->load_ps_table();
489 my $alive = $Amanda_process->process_alive($pid);
495 /* Interesting story: Perl added a sv_rvweaken function in 5.6.0 (or earlier?), but
496 * did not include this functionality in Scalar::Util until later. It doesn't make
497 * much sense, does it? */
498 amglue_export_ok(weaken_ref)
499 %typemap(in) SV *rv "$1 = $input;"
501 void weaken_ref(SV *rv) {
506 %rename(gettimeofday) gettimeofday_for_perl;
508 static guint64 gettimeofday_for_perl(void)
511 g_get_current_time(&t);
512 return (guint64)t.tv_sec * G_USEC_PER_SEC + (guint64)t.tv_usec;
516 void openbsd_fd_inform(void);
521 * TODO: this should move to Amanda::Security when the rest of the Security API
522 * is available from Perl.
526 enum { STREAM_BUFSIZE };
527 %typemap(in, numinputs=0) in_port_t *port_ARGOUT (in_port_t port) {
530 %typemap(argout) in_port_t *port_ARGOUT {
531 $result = sv_2mortal(newSViv(*$1));
534 /* avoid BigInts for socket fd's */
535 %{ typedef int socketfd; %}
536 %typemap(out) socketfd {
537 $result = sv_2mortal(newSViv($1));
540 socketfd stream_server(int family, in_port_t *port_ARGOUT, size_t sendsize,
541 size_t recvsize, gboolean privileged);
543 socketfd stream_accept(int fd, int timeout, size_t sendsize, size_t recvsize);
545 %newobject check_security_fd;
546 %rename(check_security) check_security_fd;
548 char *check_security_fd(int fd, char *userstr)
551 struct sockaddr_in addr;
554 /* get the remote address */
556 if (getpeername(fd, (struct sockaddr *)&addr, &i) == -1) {
557 return g_strdup_printf("getpeername: %s", strerror(errno));
560 /* require IPv4 and not port 20 -- apparently this was a common attack
561 * vector for much older Amandas */
562 if ((addr.sin_family != (sa_family_t)AF_INET)
563 || (ntohs(addr.sin_port) == 20)) {
564 return g_strdup_printf("connection rejected from %s family %d port %d",
565 inet_ntoa(addr.sin_addr), addr.sin_family, htons(addr.sin_port));
568 /* call out to check_security */
569 if (!check_security((sockaddr_union *)&addr, userstr, 0, &errstr))
576 stream_server stream_accept check_security);
577 amglue_export_tag(constants,
578 $AF_INET $STREAM_BUFSIZE);
582 # these functions were verified to work similarly to those in
583 # common-src/tapelist.c - they pass the same tests, at least.
585 sub marshal_tapespec {
587 my @filelist = @$filelist; # make a copy we can wreck
591 my $label = shift @filelist;
592 my $files = shift @filelist;
594 $label =~ s/([\\:;,])/\\$1/g;
595 push @specs, "$label:" . join(",", @$files);
597 return join(";", @specs);
600 sub unmarshal_tapespec {
604 # detect a non-tapespec string for special handling; in particular, a string
605 # without an unquoted : followed by digits and commas at the end. The easiest
606 # way to do this is to replace every quoted character with a dummy, then look
607 # for the colon and digits.
609 $tmp =~ s/\\([\\:;,])/X/g;
610 if ($tmp !~ /:[,\d]+$/) {
611 # ok, it doesn't end with the right form, so unquote it and return it
613 $tapespec =~ s/\\([\\:;,])/$1/g;
614 return [ $tapespec, [ 0 ] ];
617 # use a lookbehind to mask out any quoted ;'s
618 my @volumes = split(/(?<!\\);/, $tapespec);
619 for my $vol (@volumes) {
620 my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
622 $label =~ s/\\([\\:;,])/$1/g;
623 push @filelist, $label;
625 my @files = split(/,/, $files);
626 @files = map { $_+0 } @files;
627 @files = sort { $a <=> $b } @files;
628 push @filelist, \@files;
637 match_host match_disk match_datestamp match_level
640 gboolean match_host(char *pat, char *value);
641 gboolean match_disk(char *pat, char *value);
642 gboolean match_datestamp(char *pat, char *value);
643 gboolean match_level(char *pat, char *value);
646 /* -------------------------------------------------------------------------
647 * Functions below this line are only meant to be called within this module;
648 * do not call them externally. */
650 void set_pname(char *name);
652 void set_ptype(char *type);
654 void set_pcontext(pcontext_t context);
655 pcontext_t get_pcontext();
658 void check_running_as(running_as_flags who);
660 /* Check that fd's 0, 1, and 2 are open, calling critical() if not.
664 fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
665 fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
666 fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");