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);
214 amglue_export_ok(slurp);
215 amglue_export_ok(burp);
216 amglue_export_ok(safe_overwrite_file);
224 open my $fh, "<", $file or croak "can't open $file: $!";
233 open my $fh, ">", $file or croak "can't open $file: $!";
237 sub safe_overwrite_file {
238 my ( $filename, $contents ) = @_;
240 my $tmpfname = "$filename." . time;
241 open my $tmpfh, ">", $tmpfname or die "open: $!";
243 print $tmpfh $contents;
244 (fsync($tmpfh) == 0) or die "fsync: $!";
245 return rename $tmpfname, $filename;
250 %typemap (in) GPtrArray * {
255 if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) {
256 SWIG_exception(SWIG_TypeError, "Expected an arrayref");
258 av = (AV *)SvRV($input);
260 len = av_len(av)+1; /* av_len(av) is like $#av */
261 $1 = g_ptr_array_sized_new(len);
262 for (i = 0; i < len; i++) {
263 SV **elt = av_fetch(av, i, 0);
264 if (!elt || !SvPOK(*elt)) {
265 SWIG_exception(SWIG_TypeError, "Non-string in arrayref");
267 g_ptr_array_add($1, SvPV_nolen(*elt)); /* TODO: handle unicode here */
270 %typemap (freearg) GPtrArray * {
271 g_ptr_array_free($1, FALSE);
274 %typemap (out) GPtrArray * {
277 for (i = 0; i < $1->len; i++) {
278 $result = sv_2mortal(newSVpv(g_ptr_array_index($1, i), 0));
281 g_ptr_array_free($1, TRUE);
283 $result = &PL_sv_undef;
288 /* for split_quoted_strings */
289 %typemap(out) gchar ** {
293 /* Count the DeviceProperties */
294 EXTEND(SP, g_strv_length($1)); /* make room for return values */
296 /* Note that we set $result several times. the nature of
297 * SWIG's wrapping is such that incrementing argvi points
298 * $result to the next location in perl's argument stack.
301 for (iter = $1; *iter; iter++) {
302 $result = sv_2mortal(newSVpv(*iter, 0));
308 %rename(hexencode) hexencode_string;
309 char *hexencode_string(char *);
310 %rename(hexdecode) perl_hexdecode_string;
311 char *perl_hexdecode_string(char *);
313 char *perl_hexdecode_string(const char *str) {
316 tmp = hexdecode_string(str, &err);
319 croak_gerror("Amanda util: hexdecode", &err);
324 amglue_export_tag(encoding, hexencode hexdecode);
326 char *sanitise_filename(char *inp);
327 char *quote_string(char *);
328 char *unquote_string(char *);
329 GPtrArray *expand_braced_alternates(char *);
330 %newobject collapse_braced_alternates;
331 char *collapse_braced_alternates(GPtrArray *source);
332 gchar **split_quoted_strings(const gchar *string);
333 amglue_export_tag(quoting, quote_string unquote_string skip_quoted_string sanitise_filename split_quoted_strings);
334 amglue_export_tag(alternates, expand_braced_alternates collapse_braced_alternates);
338 sub generate_timestamp {
339 # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time
340 if (getconf($CNF_USETIMESTAMPS)) {
341 return strftime "%Y%m%d%H%M%S", localtime;
343 return strftime "%Y%m%d", localtime;
347 sub built_with_component {
348 my ($component) = @_;
349 my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
350 return grep { $_ eq $component } @components;
355 /* interface to gnulib's fsusage */
356 %typemap(in,numinputs=0) (struct fs_usage *fsp)
357 (struct fs_usage fsu) {
358 bzero(&fsu, sizeof(fsu));
362 %typemap(argout) (struct fs_usage *fsp) {
366 /* if there was an error, assume that fsu_blocksize isn't changed,
367 * and return undef. */
368 if ($1->fsu_blocksize) {
369 SP += argvi; PUTBACK; /* save the perl stack so amglue_newSVi64 doesn't kill it */
370 hv = (HV *)sv_2mortal((SV *)newHV());
371 hv_store(hv, "blocksize", 9, amglue_newSVi64($1->fsu_blocksize), 0);
372 hv_store(hv, "blocks", 6, amglue_newSVi64($1->fsu_blocks), 0);
373 hv_store(hv, "bfree", 5, amglue_newSVi64($1->fsu_bfree), 0);
374 hv_store(hv, "bavail", 6, amglue_newSVi64($1->fsu_bavail), 0);
375 hv_store(hv, "bavail_top_bit_set", 18, newSViv($1->fsu_bavail_top_bit_set), 0);
376 hv_store(hv, "files", 5, amglue_newSVi64($1->fsu_files), 0);
377 hv_store(hv, "ffree", 5, amglue_newSVi64($1->fsu_ffree), 0);
379 $result = newRV((SV *)hv);
380 SPAGAIN; SP -= argvi;
385 %rename(get_fs_usage) get_fs_usage_;
387 void get_fs_usage_(const char *file, struct fs_usage *fsp)
389 int rv = get_fs_usage(file, NULL, fsp);
391 /* signal an error to the typemap */
392 fsp->fsu_blocksize = 0;
397 * Operations that should be in Perl but aren't
402 /* Perl's fcntl only operates on file handles */
405 set_blocking(int fd, gboolean blocking)
407 int flags = fcntl(fd, F_GETFL, 0);
411 flags &= ~O_NONBLOCK;
414 flags = fcntl(fd, F_SETFL, flags);
422 * Locking (see amflock.h)
425 /* SWIG prepends the struct name to the member function name, which
426 * conflicts with the underlying function names */
428 typedef struct file_lock {
430 file_lock(const char *filename) {
431 return file_lock_new(filename);
435 file_lock_free(self);
441 %typemap(in) (const char *data, size_t len) {
442 $1 = SvPV($input, $2);
445 int write(const char *data, size_t len);
447 /* get the data as an SV */
448 %typemap(out) (SV *) { $result = $1; argvi++; };
451 return newSVpvn(self->data, self->len);
456 %typemap(out) (SV *);
465 return 1 if $pid == $$;
467 my $Amanda_process = Amanda::Process->new(0);
469 $Amanda_process->load_ps_table();
470 my $alive = $Amanda_process->process_alive($pid);
476 /* Interesting story: Perl added a sv_rvweaken function in 5.6.0 (or earlier?), but
477 * did not include this functionality in Scalar::Util until later. It doesn't make
478 * much sense, does it? */
479 amglue_export_ok(weaken_ref)
480 %typemap(in) SV *rv "$1 = $input;"
482 void weaken_ref(SV *rv) {
487 %rename(gettimeofday) gettimeofday_for_perl;
489 static guint64 gettimeofday_for_perl(void)
492 g_get_current_time(&t);
493 return (guint64)t.tv_sec * G_USEC_PER_SEC + (guint64)t.tv_usec;
497 void openbsd_fd_inform(void);
502 * TODO: this should move to Amanda::Security when the rest of the Security API
503 * is available from Perl.
507 enum { STREAM_BUFSIZE };
508 %typemap(in, numinputs=0) in_port_t *port_ARGOUT (in_port_t port) {
511 %typemap(argout) in_port_t *port_ARGOUT {
512 $result = sv_2mortal(newSViv(*$1));
515 /* avoid BigInts for socket fd's */
516 %{ typedef int socketfd; %}
517 %typemap(out) socketfd {
518 $result = sv_2mortal(newSViv($1));
521 socketfd stream_server(int family, in_port_t *port_ARGOUT, size_t sendsize,
522 size_t recvsize, gboolean privileged);
524 socketfd stream_accept(int fd, int timeout, size_t sendsize, size_t recvsize);
526 %newobject check_security_fd;
527 %rename(check_security) check_security_fd;
529 char *check_security_fd(int fd, char *userstr)
532 struct sockaddr_in addr;
535 /* get the remote address */
537 if (getpeername(fd, (struct sockaddr *)&addr, &i) == -1) {
538 return g_strdup_printf("getpeername: %s", strerror(errno));
541 /* require IPv4 and not port 20 -- apparently this was a common attack
542 * vector for much older Amandas */
543 if ((addr.sin_family != (sa_family_t)AF_INET)
544 || (ntohs(addr.sin_port) == 20)) {
545 return g_strdup_printf("connection rejected from %s family %d port %d",
546 inet_ntoa(addr.sin_addr), addr.sin_family, htons(addr.sin_port));
549 /* call out to check_security */
550 if (!check_security((sockaddr_union *)&addr, userstr, 0, &errstr))
557 stream_server stream_accept check_security);
558 amglue_export_tag(constants,
559 $AF_INET $STREAM_BUFSIZE);
563 # these functions were verified to work similarly to those in
564 # common-src/tapelist.c - they pass the same tests, at least.
566 sub marshal_tapespec {
568 my @filelist = @$filelist; # make a copy we can wreck
572 my $label = shift @filelist;
573 my $files = shift @filelist;
575 $label =~ s/([\\:;,])/\\$1/g;
576 push @specs, "$label:" . join(",", @$files);
578 return join(";", @specs);
581 sub unmarshal_tapespec {
585 # detect a non-tapespec string for special handling; in particular, a string
586 # without an unquoted : followed by digits and commas at the end. The easiest
587 # way to do this is to replace every quoted character with a dummy, then look
588 # for the colon and digits.
590 $tmp =~ s/\\([\\:;,])/X/g;
591 if ($tmp !~ /:[,\d]+$/) {
592 # ok, it doesn't end with the right form, so unquote it and return it
594 $tapespec =~ s/\\([\\:;,])/$1/g;
595 return [ $tapespec, [ 0 ] ];
598 # use a lookbehind to mask out any quoted ;'s
599 my @volumes = split(/(?<!\\);/, $tapespec);
600 for my $vol (@volumes) {
601 my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
603 $label =~ s/\\([\\:;,])/$1/g;
604 push @filelist, $label;
606 my @files = split(/,/, $files);
607 @files = map { $_+0 } @files;
608 @files = sort { $a <=> $b } @files;
609 push @filelist, \@files;
617 /* -------------------------------------------------------------------------
618 * Functions below this line are only meant to be called within this module;
619 * do not call them externally. */
621 void set_pname(char *name);
623 void set_ptype(char *type);
625 void set_pcontext(pcontext_t context);
626 pcontext_t get_pcontext();
629 void check_running_as(running_as_flags who);
631 /* Check that fd's 0, 1, and 2 are open, calling critical() if not.
635 fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
636 fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
637 fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");