2 * Copyright (c) 2007-2012 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));
325 %rename(hexencode) hexencode_string;
326 char *hexencode_string(char *);
327 %rename(hexdecode) perl_hexdecode_string;
328 char *perl_hexdecode_string(char *);
330 char *perl_hexdecode_string(const char *str) {
333 tmp = hexdecode_string(str, &err);
336 croak_gerror("Amanda util: hexdecode", &err);
341 amglue_export_tag(encoding, hexencode hexdecode);
343 %newobject sanitise_filename;
344 char *sanitise_filename(char *inp);
345 %newobject quote_string;
346 char *quote_string(char *);
347 %newobject unquote_string;
348 char *unquote_string(char *);
349 GPtrArray *expand_braced_alternates(char *);
350 %newobject collapse_braced_alternates;
351 char *collapse_braced_alternates(GPtrArray *source);
352 %newobject split_quoted_strings;
353 gchar **split_quoted_strings(const gchar *string);
354 amglue_export_tag(quoting, quote_string unquote_string skip_quoted_string
355 sanitise_filename split_quoted_strings split_quoted_strings_friendly);
356 amglue_export_tag(alternates, expand_braced_alternates collapse_braced_alternates);
360 sub generate_timestamp {
361 # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time
362 if (getconf($CNF_USETIMESTAMPS)) {
363 return strftime "%Y%m%d%H%M%S", localtime;
365 return strftime "%Y%m%d", localtime;
369 sub built_with_component {
370 my ($component) = @_;
371 my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
372 return grep { $_ eq $component } @components;
377 /* interface to gnulib's fsusage */
378 %typemap(in,numinputs=0) (struct fs_usage *fsp)
379 (struct fs_usage fsu) {
380 bzero(&fsu, sizeof(fsu));
384 %typemap(argout) (struct fs_usage *fsp) {
388 /* if there was an error, assume that fsu_blocksize isn't changed,
389 * and return undef. */
390 if ($1->fsu_blocksize) {
391 SP += argvi; PUTBACK; /* save the perl stack so amglue_newSVi64 doesn't kill it */
392 hv = (HV *)sv_2mortal((SV *)newHV());
393 hv_store(hv, "blocksize", 9, amglue_newSVi64($1->fsu_blocksize), 0);
394 hv_store(hv, "blocks", 6, amglue_newSVi64($1->fsu_blocks), 0);
395 hv_store(hv, "bfree", 5, amglue_newSVi64($1->fsu_bfree), 0);
396 hv_store(hv, "bavail", 6, amglue_newSVi64($1->fsu_bavail), 0);
397 hv_store(hv, "bavail_top_bit_set", 18, newSViv($1->fsu_bavail_top_bit_set), 0);
398 hv_store(hv, "files", 5, amglue_newSVi64($1->fsu_files), 0);
399 hv_store(hv, "ffree", 5, amglue_newSVi64($1->fsu_ffree), 0);
401 $result = newRV((SV *)hv);
402 SPAGAIN; SP -= argvi;
407 %rename(get_fs_usage) get_fs_usage_;
409 void get_fs_usage_(const char *file, struct fs_usage *fsp)
411 int rv = get_fs_usage(file, NULL, fsp);
413 /* signal an error to the typemap */
414 fsp->fsu_blocksize = 0;
419 * Operations that should be in Perl but aren't
424 /* Perl's fcntl only operates on file handles */
427 set_blocking(int fd, gboolean blocking)
429 int flags = fcntl(fd, F_GETFL, 0);
433 flags &= ~O_NONBLOCK;
436 flags = fcntl(fd, F_SETFL, flags);
444 * Locking (see amflock.h)
447 /* SWIG prepends the struct name to the member function name, which
448 * conflicts with the underlying function names */
450 typedef struct file_lock {
452 %newobject file_lock;
453 file_lock(const char *filename) {
454 return file_lock_new(filename);
458 file_lock_free(self);
467 %typemap(in) (const char *data, size_t len) {
468 $1 = SvPV($input, $2);
471 int write(const char *data, size_t len);
473 /* get the data as an SV */
474 %typemap(out) (SV *) { $result = $1; argvi++; };
477 return newSVpvn(self->data, self->len);
482 %typemap(out) (SV *);
491 return 1 if $pid == $$;
493 my $Amanda_process = Amanda::Process->new(0);
495 $Amanda_process->load_ps_table();
496 my $alive = $Amanda_process->process_alive($pid);
502 /* Interesting story: Perl added a sv_rvweaken function in 5.6.0 (or earlier?), but
503 * did not include this functionality in Scalar::Util until later. It doesn't make
504 * much sense, does it? */
505 amglue_export_ok(weaken_ref)
506 %typemap(in) SV *rv "$1 = $input;"
508 void weaken_ref(SV *rv) {
513 %rename(gettimeofday) gettimeofday_for_perl;
515 static guint64 gettimeofday_for_perl(void)
518 g_get_current_time(&t);
519 return (guint64)t.tv_sec * G_USEC_PER_SEC + (guint64)t.tv_usec;
523 void openbsd_fd_inform(void);
528 * TODO: this should move to Amanda::Security when the rest of the Security API
529 * is available from Perl.
533 enum { STREAM_BUFSIZE };
534 %typemap(in, numinputs=0) in_port_t *port_ARGOUT (in_port_t port) {
537 %typemap(argout) in_port_t *port_ARGOUT {
538 $result = sv_2mortal(newSViv(*$1));
541 /* avoid BigInts for socket fd's */
542 %{ typedef int socketfd; %}
543 %typemap(out) socketfd {
544 $result = sv_2mortal(newSViv($1));
547 socketfd stream_server(int family, in_port_t *port_ARGOUT, size_t sendsize,
548 size_t recvsize, gboolean privileged);
550 socketfd stream_accept(int fd, int timeout, size_t sendsize, size_t recvsize);
552 %newobject check_security_fd;
553 %rename(check_security) check_security_fd;
555 char *check_security_fd(int fd, char *userstr)
558 struct sockaddr_in addr;
561 /* get the remote address */
563 if (getpeername(fd, (struct sockaddr *)&addr, &i) == -1) {
564 return g_strdup_printf("getpeername: %s", strerror(errno));
567 /* require IPv4 and not port 20 -- apparently this was a common attack
568 * vector for much older Amandas */
569 if ((addr.sin_family != (sa_family_t)AF_INET)
570 || (ntohs(addr.sin_port) == 20)) {
571 return g_strdup_printf("connection rejected from %s family %d port %d",
572 inet_ntoa(addr.sin_addr), addr.sin_family, htons(addr.sin_port));
575 /* call out to check_security */
576 if (!check_security((sockaddr_union *)&addr, userstr, 0, &errstr))
583 stream_server stream_accept check_security);
584 amglue_export_tag(constants,
585 $AF_INET $STREAM_BUFSIZE);
589 # these functions were verified to work similarly to those in
590 # common-src/tapelist.c - they pass the same tests, at least.
592 sub marshal_tapespec {
594 my @filelist = @$filelist; # make a copy we can wreck
598 my $label = shift @filelist;
599 my $files = shift @filelist;
601 $label =~ s/([\\:;,])/\\$1/g;
602 push @specs, "$label:" . join(",", @$files);
604 return join(";", @specs);
607 sub unmarshal_tapespec {
611 # detect a non-tapespec string for special handling; in particular, a string
612 # without an unquoted : followed by digits and commas at the end. The easiest
613 # way to do this is to replace every quoted character with a dummy, then look
614 # for the colon and digits.
616 $tmp =~ s/\\([\\:;,])/X/g;
617 if ($tmp !~ /:[,\d]+$/) {
618 # ok, it doesn't end with the right form, so unquote it and return it
620 $tapespec =~ s/\\([\\:;,])/$1/g;
621 return [ $tapespec, [ 0 ] ];
624 # use a lookbehind to mask out any quoted ;'s
625 my @volumes = split(/(?<!\\);/, $tapespec);
626 for my $vol (@volumes) {
627 my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
629 $label =~ s/\\([\\:;,])/$1/g;
630 push @filelist, $label;
632 my @files = split(/,/, $files);
633 @files = map { $_+0 } @files;
634 @files = sort { $a <=> $b } @files;
635 push @filelist, \@files;
644 match_host match_disk match_datestamp match_level
647 gboolean match_host(char *pat, char *value);
648 gboolean match_disk(char *pat, char *value);
649 gboolean match_datestamp(char *pat, char *value);
650 gboolean match_level(char *pat, char *value);
653 /* -------------------------------------------------------------------------
654 * Functions below this line are only meant to be called within this module;
655 * do not call them externally. */
657 void set_pname(char *name);
659 void set_ptype(char *type);
661 void set_pcontext(pcontext_t context);
662 pcontext_t get_pcontext();
665 void check_running_as(running_as_flags who);
667 /* Check that fd's 0, 1, and 2 are open, calling critical() if not.
671 fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
672 fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
673 fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");