1/*
2 * Copyright (c) 2007-2013 Zmanda, Inc.  All Rights Reserved.
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
11 * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
12 * for more details.
13 *
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
17 *
18 * Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300
19 * Sunnyvale, CA 94085, USA, or: http://www.zmanda.com
20 */
21
22%module "Amanda::Util"
23%include "amglue/amglue.swg"
24%include "exception.i"
25
26%include "Amanda/Util.pod"
27
28%{
29#include <unistd.h>
30#include "amglue.h"
31#include "debug.h"
32#include "full-read.h"
33#include "full-write.h"
34#include "fsusage.h"
35#include "stream.h"
36/* use a relative path here to avoid conflicting with Perl's util.h. */
37#include "../common-src/util.h"
38#include "file.h"
39#include "sockaddr-util.h"
40#include "match.h"
41%}
42
43void glib_init(void);
44
45%perlcode %{
46
47use Amanda::Debug qw(:init);
48use Amanda::Config qw(:getconf);
49use warnings;
50use Carp;
51use POSIX qw( :fcntl_h :errno_h );
52use POSIX qw( strftime );
53use Amanda::Constants;
54use Amanda::Process;
55
56# private package variables
57my $_pname;
58my $_ptype;
59my $_pcontext;
60
61sub setup_application {
62    my ($name, $type, $context) = @_;
63
64    # sanity check
65    croak("no name given") unless ($name);
66    croak("no type given") unless ($type);
67    croak("no context given") unless ($context);
68
69    # store these as perl values
70    $_pname = $name;
71    $_ptype = $type;
72    $_pcontext = $context;
73
74    # and let the C side know about them too
75    set_pname($name);
76    set_ptype($type);
77    set_pcontext($context);
78
79    safe_cd(); # (also sets umask)
80    check_std_fds();
81
82    make_crc_table();
83
84    # set up debugging, now that we have a name, type, and context
85    debug_init();
86
87    glib_init();
88
89    # ignore SIGPIPE
90    $SIG{'PIPE'} = 'IGNORE';
91}
92
93sub finish_setup {
94    my ($running_as) = @_;
95
96    my $config_name = Amanda::Config::get_config_name();
97
98    if ($config_name) {
99	dbrename($config_name, $_ptype);
100    }
101
102    check_running_as($running_as);
103}
104
105sub finish_application {
106    dbclose();
107}
108
109sub version_opt {
110    print "$_pname-$Amanda::Constants::VERSION\n";
111    exit 0;
112}
113
114%}
115char *get_original_cwd(void);
116amglue_export_tag(util, get_original_cwd);
117
118%perlcode %{
119sub safe_env {
120    my %rv = %ENV;
121
122    delete @rv{qw(IFS CDPATH ENV BASH_ENV LANG)};
123
124    # delete all LC_* variables
125    for my $var (grep /^LC_/, keys %rv) {
126        delete $rv{$var};
127    }
128
129    return %rv;
130}
131
132%}
133
134amglue_add_flag_tag_fns(running_as_flags);
135amglue_add_constant(RUNNING_AS_ANY, running_as_flags);
136amglue_add_constant(RUNNING_AS_ROOT, running_as_flags);
137amglue_add_constant(RUNNING_AS_DUMPUSER, running_as_flags);
138amglue_add_constant(RUNNING_AS_DUMPUSER_PREFERRED, running_as_flags);
139amglue_add_constant(RUNNING_AS_CLIENT_LOGIN, running_as_flags);
140amglue_add_constant(RUNNING_AS_UID_ONLY, running_as_flags);
141amglue_copy_to_tag(running_as_flags, constants);
142
143amglue_add_enum_tag_fns(pcontext_t);
144amglue_add_constant(CONTEXT_DEFAULT, pcontext_t);
145amglue_add_constant(CONTEXT_CMDLINE, pcontext_t);
146amglue_add_constant(CONTEXT_DAEMON, pcontext_t);
147amglue_add_constant(CONTEXT_SCRIPTUTIL, pcontext_t);
148amglue_copy_to_tag(pcontext_t, constants);
149
150%perlcode %{
151sub full_read {
152    my ($fd, $count) = @_;
153    my @bufs;
154
155    while ($count > 0) {
156	my $b;
157	my $n_read = POSIX::read($fd, $b, $count);
158	if (!defined $n_read) {
159	    next if ($! == EINTR);
160	    return undef;
161	} elsif ($n_read == 0) {
162	    last;
163	}
164	push @bufs, $b;
165	$count -= $n_read;
166    }
167
168    return join('', @bufs);
169}
170
171sub full_write {
172    my ($fd, $buf, $count) = @_;
173    my $total = 0;
174
175    while ($count > 0) {
176	my $n_written = POSIX::write($fd, $buf, $count);
177	if (!defined $n_written) {
178	    next if ($! == EINTR);
179	    return undef;
180	} elsif ($n_written == 0) {
181	    last;
182	}
183
184	$count -= $n_written;
185	$total += $n_written;
186
187	if ($count) {
188	    $buf = substr($buf, $n_written);
189	}
190    }
191
192    return $total;
193}
194
195sub skip_quoted_string {
196    my $str = shift;
197
198    chomp $str;
199    my $iq = 0;
200    my $i = 0;
201    my $c = substr $str, $i, 1;
202    while ($c ne "" && !($iq == 0 && $c =~ /\s/)) {
203	if ($c eq '"') {
204	    $iq = !$iq;
205	} elsif ($c eq '\\') {
206	    $i++;
207	}
208	$i++;
209	$c = substr $str, $i, 1;
210    }
211    my $quoted_string = substr $str, 0, $i;
212    my $remainder     = undef;
213    if (length($str) > $i) {
214	$remainder    = substr $str, $i+1;
215    }
216
217    return ($quoted_string, $remainder);
218}
219
220sub split_quoted_string_friendly {
221    my $str = shift;
222    my @result;
223
224    chomp $str;
225    $str =~ s/^\s+//;
226    while ($str) {
227	(my $elt, $str) = skip_quoted_string($str);
228	push @result, unquote_string($elt);
229	$str =~ s/^\s+// if $str;
230    }
231
232    return @result;
233}
234
235%}
236
237amglue_export_ok(slurp);
238amglue_export_ok(burp);
239amglue_export_ok(safe_overwrite_file);
240
241%perlcode %{
242
243sub slurp {
244    my $file = shift @_;
245    local $/;
246
247    open my $fh, "<", $file or croak "can't open $file: $!";
248    my $data = <$fh>;
249    close $fh;
250
251    return $data;
252}
253
254sub burp {
255    my $file = shift @_;
256    open my $fh, ">", $file or croak "can't open $file: $!";
257    print $fh @_;
258}
259
260sub safe_overwrite_file {
261    my ( $filename, $contents ) = @_;
262
263    my $tmpfname = "$filename." . time;
264    open my $tmpfh, ">", $tmpfname or die "open: $!";
265
266    print $tmpfh $contents;
267    (fsync($tmpfh) == 0) or die "fsync: $!";
268    return rename $tmpfname, $filename;
269}
270
271%}
272
273%typemap (in) GPtrArray * {
274    AV *av;
275    guint len;
276    int i;
277
278    if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) {
279	SWIG_exception(SWIG_TypeError, "Expected an arrayref");
280    }
281    av = (AV *)SvRV($input);
282
283    len = av_len(av)+1; /* av_len(av) is like $#av */
284    $1 = g_ptr_array_sized_new(len);
285    for (i = 0; i < len; i++) {
286	SV **elt = av_fetch(av, i, 0);
287	if (!elt || !SvPOK(*elt)) {
288	    SWIG_exception(SWIG_TypeError, "Non-string in arrayref");
289	}
290	g_ptr_array_add($1, SvPV_nolen(*elt)); /* TODO: handle unicode here */
291    }
292}
293%typemap (freearg) GPtrArray * {
294    g_ptr_array_free($1, FALSE);
295}
296
297%typemap (out) GPtrArray * {
298    if ($1) {
299	guint i;
300	gpointer *pdata;
301
302	EXTEND(sp, $1->len);
303	for (i = 0, pdata = $1->pdata; i < $1->len; i++) {
304	    char *str = *pdata++;
305	    $result = sv_2mortal(newSVpv(str, 0));
306	    g_free(str);
307	    argvi++;
308	}
309	g_ptr_array_free($1, TRUE);
310    } else {
311	$result = &PL_sv_undef;
312	argvi++;
313    }
314}
315
316/* for split_quoted_strings */
317%typemap(out) gchar ** {
318    gchar **iter;
319
320    if ($1) {
321	/* Count the DeviceProperties */
322	EXTEND(SP, g_strv_length($1)); /* make room for return values */
323
324	/* Note that we set $result several times. the nature of
325	 * SWIG's wrapping is such that incrementing argvi points
326	 * $result to the next location in perl's argument stack.
327	 */
328
329	for (iter = $1; *iter; iter++) {
330	    $result = sv_2mortal(newSVpv(*iter, 0));
331	    g_free(*iter);
332	    argvi++;
333	}
334	g_free($1);
335    }
336}
337
338%rename(hexencode) hexencode_string;
339char *hexencode_string(char *);
340%rename(hexdecode) perl_hexdecode_string;
341char *perl_hexdecode_string(char *);
342%{
343char *perl_hexdecode_string(const char *str) {
344    GError *err = NULL;
345    char *tmp;
346    tmp = hexdecode_string(str, &err);
347    if (err) {
348        g_free(tmp);
349        croak_gerror("Amanda util: hexdecode", &err);
350    }
351    return tmp;
352}
353%}
354amglue_export_tag(encoding, hexencode hexdecode);
355
356%newobject sanitise_filename;
357char *sanitise_filename(char *inp);
358%newobject quote_string;
359char *quote_string(char *);
360%newobject unquote_string;
361char *unquote_string(char *);
362GPtrArray *expand_braced_alternates(char *);
363%newobject collapse_braced_alternates;
364char *collapse_braced_alternates(GPtrArray *source);
365%newobject split_quoted_strings;
366gchar **split_quoted_strings(const gchar *string);
367amglue_export_tag(quoting, quote_string unquote_string skip_quoted_string
368		sanitise_filename split_quoted_strings split_quoted_strings_friendly);
369amglue_export_tag(alternates, expand_braced_alternates collapse_braced_alternates);
370
371%perlcode %{
372
373sub generate_timestamp {
374    # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time
375    if (getconf($CNF_USETIMESTAMPS)) {
376	return strftime "%Y%m%d%H%M%S", localtime;
377    } else {
378	return strftime "%Y%m%d", localtime;
379    }
380}
381
382sub built_with_component {
383    my ($component) = @_;
384    my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
385    return grep { $_ eq $component } @components;
386}
387
388%}
389
390/* interface to gnulib's fsusage */
391%typemap(in,numinputs=0) (struct fs_usage *fsp)
392    (struct fs_usage fsu) {
393    bzero(&fsu, sizeof(fsu));
394    $1 = &fsu;
395}
396
397%typemap(argout) (struct fs_usage *fsp) {
398    SV *sv;
399    HV *hv;
400
401    /* if there was an error, assume that fsu_blocksize isn't changed,
402     * and return undef. */
403    if ($1->fsu_blocksize) {
404	SP += argvi; PUTBACK; /* save the perl stack so amglue_newSVi64 doesn't kill it */
405	hv = (HV *)sv_2mortal((SV *)newHV());
406	hv_store(hv, "blocksize", 9, amglue_newSVi64($1->fsu_blocksize), 0);
407	hv_store(hv, "blocks", 6, amglue_newSVi64($1->fsu_blocks), 0);
408	hv_store(hv, "bfree", 5, amglue_newSVi64($1->fsu_bfree), 0);
409	hv_store(hv, "bavail", 6, amglue_newSVi64($1->fsu_bavail), 0);
410	hv_store(hv, "bavail_top_bit_set", 18, newSViv($1->fsu_bavail_top_bit_set), 0);
411	hv_store(hv, "files", 5, amglue_newSVi64($1->fsu_files), 0);
412	hv_store(hv, "ffree", 5, amglue_newSVi64($1->fsu_ffree), 0);
413
414	$result = newRV((SV *)hv);
415	SPAGAIN; SP -= argvi;
416	argvi++;
417    }
418}
419
420%rename(get_fs_usage) get_fs_usage_;
421%inline %{
422void get_fs_usage_(const char *file, struct fs_usage *fsp)
423{
424    int rv = get_fs_usage(file, NULL, fsp);
425    if (rv == -1)
426	/* signal an error to the typemap */
427	fsp->fsu_blocksize = 0;
428}
429%}
430
431/*
432 * Operations that should be in Perl but aren't
433 */
434
435int fsync(int fd);
436
437/* Perl's fcntl only operates on file handles */
438%inline %{
439int
440set_blocking(int fd, gboolean blocking)
441{
442    int flags = fcntl(fd, F_GETFL, 0);
443    if (flags < 0)
444	return flags;
445    if (blocking)
446	flags &= ~O_NONBLOCK;
447    else
448	flags |= O_NONBLOCK;
449    flags = fcntl(fd, F_SETFL, flags);
450    if (flags < 0)
451	return flags;
452    return 0;
453}
454%}
455
456/*
457 * Locking (see amflock.h)
458 */
459
460/* SWIG prepends the struct name to the member function name, which
461 * conflicts with the underlying function names */
462
463typedef struct {
464    %extend {
465	%newobject file_lock;
466	file_lock(const char *filename) {
467	    return file_lock_new(filename);
468	}
469
470	~file_lock() {
471	    file_lock_free(self);
472	}
473
474	~locked_data() {
475	    file_lock_free(self);
476	}
477
478	int lock();
479	int lock_wr();
480	int lock_rd();
481	int unlock();
482	int locked();
483
484	%typemap(in) (const char *data, size_t len) {
485	    $1 = SvPV($input, $2);
486	}
487
488	int write(const char *data, size_t len);
489
490	/* get the data as an SV */
491	%typemap(out) (SV *) { $result = $1; argvi++; };
492	SV *data() {
493	    if (self->data) {
494		return sv_2mortal(newSVpvn(self->data, self->len));
495	    } else {
496		return &PL_sv_undef;
497	    }
498	}
499	%typemap(out) (SV *);
500    }
501} file_lock;
502
503%perlcode %{
504
505sub is_pid_alive {
506    my ($pid) = shift;
507
508    return 1 if $pid == $$;
509
510    my $Amanda_process = Amanda::Process->new(0);
511
512    $Amanda_process->load_ps_table();
513    my $alive = $Amanda_process->process_alive($pid);
514    return $alive;
515
516}
517%}
518
519/* Interesting story: Perl added a sv_rvweaken function in 5.6.0 (or earlier?), but
520 * did not include this functionality in Scalar::Util until later.  It doesn't make
521 * much sense, does it? */
522amglue_export_ok(weaken_ref)
523%typemap(in) SV *rv "$1 = $input;"
524%inline %{
525void weaken_ref(SV *rv) {
526    sv_rvweaken(rv);
527}
528%}
529
530%rename(gettimeofday) gettimeofday_for_perl;
531%inline %{
532static guint64 gettimeofday_for_perl(void)
533{
534    GTimeVal t;
535    g_get_current_time(&t);
536    return (guint64)t.tv_sec * G_USEC_PER_SEC + (guint64)t.tv_usec;
537}
538%}
539
540void openbsd_fd_inform(void);
541
542/*
543 * Streams
544 *
545 * TODO: this should move to Amanda::Security when the rest of the Security API
546 * is available from Perl.
547 */
548
549enum { AF_INET };
550enum { STREAM_BUFSIZE };
551%typemap(in, numinputs=0) in_port_t *port_ARGOUT (in_port_t port) {
552    $1 = &port;
553}
554%typemap(argout) in_port_t *port_ARGOUT {
555    $result = sv_2mortal(newSViv(*$1));
556    argvi++;
557}
558/* avoid BigInts for socket fd's */
559%{ typedef int socketfd; %}
560%typemap(out) socketfd {
561    $result = sv_2mortal(newSViv($1));
562    argvi++;
563}
564socketfd stream_server(int family, in_port_t *port_ARGOUT, size_t sendsize,
565		  size_t recvsize, gboolean privileged);
566
567socketfd stream_accept(int fd, int timeout, size_t sendsize, size_t recvsize);
568
569%newobject check_security_fd;
570%rename(check_security) check_security_fd;
571%inline %{
572char *check_security_fd(int fd, char *userstr, char *service)
573{
574    socklen_t_equiv i;
575    struct sockaddr_in addr;
576    char *errstr;
577
578    /* get the remote address */
579    i = SIZEOF(addr);
580    if (getpeername(fd, (struct sockaddr *)&addr, &i) == -1) {
581	return g_strdup_printf("getpeername: %s", strerror(errno));
582    }
583
584    /* require IPv4 and not port 20 -- apparently this was a common attack
585     * vector for much older Amandas */
586    if ((addr.sin_family != (sa_family_t)AF_INET)
587		|| (ntohs(addr.sin_port) == 20)) {
588	return g_strdup_printf("connection rejected from %s family %d port %d",
589             inet_ntoa(addr.sin_addr), addr.sin_family, htons(addr.sin_port));
590    }
591
592    /* call out to check_security */
593    if (!check_security((sockaddr_union *)&addr, userstr, 0, &errstr, service))
594	return errstr;
595
596    return NULL;
597}
598%}
599amglue_export_ok(
600	stream_server stream_accept check_security);
601amglue_export_tag(constants,
602	$AF_INET $STREAM_BUFSIZE);
603
604%perlcode %{
605
606# these functions were verified to work similarly to those in
607# common-src/tapelist.c - they pass the same tests, at least.
608
609sub marshal_tapespec {
610    my ($filelist) = @_;
611    my @filelist = @$filelist; # make a copy we can wreck
612    my @specs;
613
614    while (@filelist) {
615	my $label = shift @filelist;
616	my $files = shift @filelist;
617
618	$label =~ s/([\\:;,])/\\$1/g;
619	push @specs, "$label:" . join(",", @$files);
620    }
621    return join(";", @specs);
622}
623
624sub unmarshal_tapespec {
625    my ($tapespec) = @_;
626    my @filelist;
627
628    # detect a non-tapespec string for special handling; in particular, a string
629    # without an unquoted : followed by digits and commas at the end.  The easiest
630    # way to do this is to replace every quoted character with a dummy, then look
631    # for the colon and digits.
632    my $tmp = $tapespec;
633    $tmp =~ s/\\([\\:;,])/X/g;
634    if ($tmp !~ /:[,\d]+$/) {
635	# ok, it doesn't end with the right form, so unquote it and return it
636	# with filenum 0
637	$tapespec =~ s/\\([\\:;,])/$1/g;
638	return [ $tapespec, [ 0 ] ];
639    }
640
641    # use a lookbehind to mask out any quoted ;'s
642    my @volumes = split(/(?<!\\);/, $tapespec);
643    for my $vol (@volumes) {
644	my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
645
646	$label =~ s/\\([\\:;,])/$1/g;
647	push @filelist, $label;
648
649	my @files = split(/,/, $files);
650	@files = map { $_+0 } @files;
651	@files = sort { $a <=> $b } @files;
652	push @filelist, \@files;
653    }
654
655    return \@filelist;
656}
657
658%}
659
660amglue_export_ok(
661    match_host match_disk match_datestamp match_level match_labelstr_expr
662);
663
664gboolean match_host(char *pat, char *value);
665gboolean match_disk(char *pat, char *value);
666gboolean match_datestamp(char *pat, char *value);
667gboolean match_level(char *pat, char *value);
668
669%perlcode %{
670sub match_labelstr_expr {
671    my $labelstr_expr = shift;
672    my $label = shift;
673
674    return $label =~ /$labelstr_expr/;
675}
676
677%}
678
679void make_crc_table(void);
680void crc32_init(crc_t *crc);
681void crc32_add(uint8_t *buf, size_t len, crc_t *crc);
682uint32_t crc32_finish(crc_t *crc);
683
684/* -------------------------------------------------------------------------
685 * Functions below this line are only meant to be called within this module;
686 * do not call them externally. */
687
688void set_pname(char *name);
689char *get_pname();
690void set_ptype(char *type);
691char *get_ptype();
692void set_pcontext(pcontext_t context);
693pcontext_t get_pcontext();
694void safe_cd(void);
695
696void check_running_as(running_as_flags who);
697
698/* Check that fd's 0, 1, and 2 are open, calling critical() if not.
699 */
700%perlcode %{
701sub check_std_fds {
702    fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
703    fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
704    fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");
705}
706
707%}
708