git.gag.com Git - debian/amanda/blob - perl/Amanda/Util.swg

   1 /*
   2  * Copyright (c) 2007, 2008, 2009, 2010 Zmanda, Inc.  All Rights Reserved.
   3  *
   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.
   7  *
   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
  11  * for more details.
  12  *
  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
  16  *
  17  * Contact information: Zmanda Inc., 465 S. Mathilda Ave., Suite 300
  18  * Sunnyvale, CA 94085, USA, or: http://www.zmanda.com
  19  */
  20
  21 %module "Amanda::Util"
  22 %include "amglue/amglue.swg"
  23 %include "exception.i"
  24
  25 %include "Amanda/Util.pod"
  26
  27 %{
  28 #include <unistd.h>
  29 #include "amglue.h"
  30 #include "debug.h"
  31 #include "full-read.h"
  32 #include "full-write.h"
  33 #include "fsusage.h"
  34 #include "stream.h"
  35 /* use a relative path here to avoid conflicting with Perl's util.h. */
  36 #include "../common-src/util.h"
  37 #include "file.h"
  38 #include "sockaddr-util.h"
  39 %}
  40
  41 %perlcode %{
  42
  43 use Amanda::Debug qw(:init);
  44 use Amanda::Config qw(:getconf);
  45 use warnings;
  46 use Carp;
  47 use POSIX qw( :fcntl_h :errno_h );
  48 use POSIX qw( strftime );
  49 use Amanda::Constants;
  50 use Amanda::Process;
  51
  52 # private package variables
  53 my $_pname;
  54 my $_ptype;
  55 my $_pcontext;
  56
  57 sub setup_application {
  58     my ($name, $type, $context) = @_;
  59
  60     # sanity check
  61     croak("no name given") unless ($name);
  62     croak("no type given") unless ($type);
  63     croak("no context given") unless ($context);
  64
  65     # store these as perl values
  66     $_pname = $name;
  67     $_ptype = $type;
  68     $_pcontext = $context;
  69
  70     # and let the C side know about them too
  71     set_pname($name);
  72     set_ptype($type);
  73     set_pcontext($context);
  74
  75     safe_cd(); # (also sets umask)
  76     check_std_fds();
  77
  78     # set up debugging, now that we have a name, type, and context
  79     debug_init();
  80
  81     # ignore SIGPIPE
  82     $SIG{'PIPE'} = 'IGNORE';
  83 }
  84
  85 sub finish_setup {
  86     my ($running_as) = @_;
  87
  88     my $config_name = Amanda::Config::get_config_name();
  89
  90     if ($config_name) {
  91         dbrename($config_name, $_ptype);
  92     }
  93
  94     check_running_as($running_as);
  95 }
  96
  97 sub finish_application {
  98     dbclose();
  99 }
 100
 101 sub version_opt {
 102     print "$_pname-$Amanda::Constants::VERSION\n";
 103     exit 0;
 104 }
 105
 106 %}
 107 char *get_original_cwd(void);
 108 amglue_export_tag(util, get_original_cwd);
 109
 110 %perlcode %{
 111 sub safe_env {
 112     my %rv = %ENV;
 113
 114     delete @rv{qw(IFS CDPATH ENV BASH_ENV LANG)};
 115
 116     # delete all LC_* variables
 117     for my $var (grep /^LC_/, keys %rv) {
 118         delete $rv{$var};
 119     }
 120
 121     return %rv;
 122 }
 123
 124 %}
 125
 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);
 134
 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);
 141
 142 %perlcode %{
 143 sub full_read {
 144     my ($fd, $count) = @_;
 145     my @bufs;
 146
 147     while ($count > 0) {
 148         my $b;
 149         my $n_read = POSIX::read($fd, $b, $count);
 150         if (!defined $n_read) {
 151             next if ($! == EINTR);
 152             return undef;
 153         } elsif ($n_read == 0) {
 154             last;
 155         }
 156         push @bufs, $b;
 157         $count -= $n_read;
 158     }
 159
 160     return join('', @bufs);
 161 }
 162
 163 sub full_write {
 164     my ($fd, $buf, $count) = @_;
 165     my $total = 0;
 166
 167     while ($count > 0) {
 168         my $n_written = POSIX::write($fd, $buf, $count);
 169         if (!defined $n_written) {
 170             next if ($! == EINTR);
 171             return undef;
 172         } elsif ($n_written == 0) {
 173             last;
 174         }
 175
 176         $count -= $n_written;
 177         $total += $n_written;
 178
 179         if ($count) {
 180             $buf = substr($buf, $n_written);
 181         }
 182     }
 183
 184     return $total;
 185 }
 186
 187 sub skip_quoted_string {
 188     my $str = shift;
 189
 190     chomp $str;
 191     my $iq = 0;
 192     my $i = 0;
 193     my $c = substr $str, $i, 1;
 194     while ($c ne "" && !($iq == 0 && $c =~ /\s/)) {
 195         if ($c eq '"') {
 196             $iq = !$iq;
 197         } elsif ($c eq '\\') {
 198             $i++;
 199         }
 200         $i++;
 201         $c = substr $str, $i, 1;
 202     }
 203     my $quoted_string = substr $str, 0, $i;
 204     my $remainder     = undef;
 205     if (length($str) > $i) {
 206         $remainder    = substr $str, $i+1;
 207     }
 208
 209     return ($quoted_string, $remainder);
 210 }
 211
 212 %}
 213
 214 amglue_export_ok(slurp);
 215 amglue_export_ok(burp);
 216 amglue_export_ok(safe_overwrite_file);
 217
 218 %perlcode %{
 219
 220 sub slurp {
 221     my $file = shift @_;
 222     local $/;
 223
 224     open my $fh, "<", $file or croak "can't open $file: $!";
 225     my $data = <$fh>;
 226     close $fh;
 227
 228     return $data;
 229 }
 230
 231 sub burp {
 232     my $file = shift @_;
 233     open my $fh, ">", $file or croak "can't open $file: $!";
 234     print $fh @_;
 235 }
 236
 237 sub safe_overwrite_file {
 238     my ( $filename, $contents ) = @_;
 239
 240     my $tmpfname = "$filename." . time;
 241     open my $tmpfh, ">", $tmpfname or die "open: $!";
 242
 243     print $tmpfh $contents;
 244     (fsync($tmpfh) == 0) or die "fsync: $!";
 245     return rename $tmpfname, $filename;
 246 }
 247
 248 %}
 249
 250 %typemap (in) GPtrArray * {
 251     AV *av;
 252     guint len;
 253     int i;
 254
 255     if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) {
 256         SWIG_exception(SWIG_TypeError, "Expected an arrayref");
 257     }
 258     av = (AV *)SvRV($input);
 259
 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");
 266         }
 267         g_ptr_array_add($1, SvPV_nolen(*elt)); /* TODO: handle unicode here */
 268     }
 269 }
 270 %typemap (freearg) GPtrArray * {
 271     g_ptr_array_free($1, FALSE);
 272 }
 273
 274 %typemap (out) GPtrArray * {
 275     if ($1) {
 276         guint i;
 277         for (i = 0; i < $1->len; i++) {
 278             $result = sv_2mortal(newSVpv(g_ptr_array_index($1, i), 0));
 279             argvi++;
 280         }
 281         g_ptr_array_free($1, TRUE);
 282     } else {
 283         $result = &PL_sv_undef;
 284         argvi++;
 285     }
 286 }
 287
 288 /* for split_quoted_strings */
 289 %typemap(out) gchar ** {
 290     gchar **iter;
 291
 292     if ($1) {
 293         /* Count the DeviceProperties */
 294         EXTEND(SP, g_strv_length($1)); /* make room for return values */
 295
 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.
 299          */
 300
 301         for (iter = $1; *iter; iter++) {
 302             $result = sv_2mortal(newSVpv(*iter, 0));
 303             argvi++;
 304         }
 305     }
 306 }
 307
 308 %rename(hexencode) hexencode_string;
 309 char *hexencode_string(char *);
 310 %rename(hexdecode) perl_hexdecode_string;
 311 char *perl_hexdecode_string(char *);
 312 %{
 313 char *perl_hexdecode_string(const char *str) {
 314     GError *err = NULL;
 315     char *tmp;
 316     tmp = hexdecode_string(str, &err);
 317     if (err) {
 318         g_free(tmp);
 319         croak_gerror("Amanda util: hexdecode", &err);
 320     }
 321     return tmp;
 322 }
 323 %}
 324 amglue_export_tag(encoding, hexencode hexdecode);
 325
 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);
 335
 336 %perlcode %{
 337
 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;
 342     } else {
 343         return strftime "%Y%m%d", localtime;
 344     }
 345 }
 346
 347 sub built_with_component {
 348     my ($component) = @_;
 349     my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
 350     return grep { $_ eq $component } @components;
 351 }
 352
 353 %}
 354
 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));
 359     $1 = &fsu;
 360 }
 361
 362 %typemap(argout) (struct fs_usage *fsp) {
 363     SV *sv;
 364     HV *hv;
 365
 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);
 378
 379         $result = newRV((SV *)hv);
 380         SPAGAIN; SP -= argvi;
 381         argvi++;
 382     }
 383 }
 384
 385 %rename(get_fs_usage) get_fs_usage_;
 386 %inline %{
 387 void get_fs_usage_(const char *file, struct fs_usage *fsp)
 388 {
 389     int rv = get_fs_usage(file, NULL, fsp);
 390     if (rv == -1)
 391         /* signal an error to the typemap */
 392         fsp->fsu_blocksize = 0;
 393 }
 394 %}
 395
 396 /*
 397  * Operations that should be in Perl but aren't
 398  */
 399
 400 int fsync(int fd);
 401
 402 /* Perl's fcntl only operates on file handles */
 403 %inline %{
 404 int
 405 set_blocking(int fd, gboolean blocking)
 406 {
 407     int flags = fcntl(fd, F_GETFL, 0);
 408     if (flags < 0)
 409         return flags;
 410     if (blocking)
 411         flags &= ~O_NONBLOCK;
 412     else
 413         flags |= O_NONBLOCK;
 414     flags = fcntl(fd, F_SETFL, flags);
 415     if (flags < 0)
 416         return flags;
 417     return 0;
 418 }
 419 %}
 420
 421 /*
 422  * Locking (see amflock.h)
 423  */
 424
 425 /* SWIG prepends the struct name to the member function name, which
 426  * conflicts with the underlying function names */
 427
 428 typedef struct file_lock {
 429     %extend {
 430         file_lock(const char *filename) {
 431             return file_lock_new(filename);
 432         }
 433
 434         ~locked_data() {
 435             file_lock_free(self);
 436         }
 437
 438         int lock();
 439         int unlock();
 440
 441         %typemap(in) (const char *data, size_t len) {
 442             $1 = SvPV($input, $2);
 443         }
 444
 445         int write(const char *data, size_t len);
 446
 447         /* get the data as an SV */
 448         %typemap(out) (SV *) { $result = $1; argvi++; };
 449         SV *data() {
 450             if (self->data) {
 451                 return newSVpvn(self->data, self->len);
 452             } else {
 453                 return &PL_sv_undef;
 454             }
 455         }
 456         %typemap(out) (SV *);
 457     }
 458 } file_lock;
 459
 460 %perlcode %{
 461
 462 sub is_pid_alive {
 463     my ($pid) = shift;
 464
 465     return 1 if $pid == $$;
 466
 467     my $Amanda_process = Amanda::Process->new(0);
 468
 469     $Amanda_process->load_ps_table();
 470     my $alive = $Amanda_process->process_alive($pid);
 471     return $alive;
 472
 473 }
 474 %}
 475
 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;"
 481 %inline %{
 482 void weaken_ref(SV *rv) {
 483     sv_rvweaken(rv);
 484 }
 485 %}
 486
 487 %rename(gettimeofday) gettimeofday_for_perl;
 488 %inline %{
 489 static guint64 gettimeofday_for_perl(void)
 490 {
 491     GTimeVal t;
 492     g_get_current_time(&t);
 493     return (guint64)t.tv_sec * G_USEC_PER_SEC + (guint64)t.tv_usec;
 494 }
 495 %}
 496
 497 void openbsd_fd_inform(void);
 498
 499 /*
 500  * Streams
 501  *
 502  * TODO: this should move to Amanda::Security when the rest of the Security API
 503  * is available from Perl.
 504  */
 505
 506 enum { AF_INET };
 507 enum { STREAM_BUFSIZE };
 508 %typemap(in, numinputs=0) in_port_t *port_ARGOUT (in_port_t port) {
 509     $1 = &port;
 510 }
 511 %typemap(argout) in_port_t *port_ARGOUT {
 512     $result = sv_2mortal(newSViv(*$1));
 513     argvi++;
 514 }
 515 /* avoid BigInts for socket fd's */
 516 %{ typedef int socketfd; %}
 517 %typemap(out) socketfd {
 518     $result = sv_2mortal(newSViv($1));
 519     argvi++;
 520 }
 521 socketfd stream_server(int family, in_port_t *port_ARGOUT, size_t sendsize,
 522                   size_t recvsize, gboolean privileged);
 523
 524 socketfd stream_accept(int fd, int timeout, size_t sendsize, size_t recvsize);
 525
 526 %newobject check_security_fd;
 527 %rename(check_security) check_security_fd;
 528 %inline %{
 529 char *check_security_fd(int fd, char *userstr)
 530 {
 531     socklen_t_equiv i;
 532     struct sockaddr_in addr;
 533     char *errstr;
 534
 535     /* get the remote address */
 536     i = SIZEOF(addr);
 537     if (getpeername(fd, (struct sockaddr *)&addr, &i) == -1) {
 538         return g_strdup_printf("getpeername: %s", strerror(errno));
 539     }
 540
 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));
 547     }
 548
 549     /* call out to check_security */
 550     if (!check_security((sockaddr_union *)&addr, userstr, 0, &errstr))
 551         return errstr;
 552
 553     return NULL;
 554 }
 555 %}
 556 amglue_export_ok(
 557         stream_server stream_accept check_security);
 558 amglue_export_tag(constants,
 559         $AF_INET $STREAM_BUFSIZE);
 560
 561 %perlcode %{
 562
 563 # these functions were verified to work similarly to those in
 564 # common-src/tapelist.c - they pass the same tests, at least.
 565
 566 sub marshal_tapespec {
 567     my ($filelist) = @_;
 568     my @filelist = @$filelist; # make a copy we can wreck
 569     my @specs;
 570
 571     while (@filelist) {
 572         my $label = shift @filelist;
 573         my $files = shift @filelist;
 574
 575         $label =~ s/([\\:;,])/\\$1/g;
 576         push @specs, "$label:" . join(",", @$files);
 577     }
 578     return join(";", @specs);
 579 }
 580
 581 sub unmarshal_tapespec {
 582     my ($tapespec) = @_;
 583     my @filelist;
 584
 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.
 589     my $tmp = $tapespec;
 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
 593         # with filenum 0
 594         $tapespec =~ s/\\([\\:;,])/$1/g;
 595         return [ $tapespec, [ 0 ] ];
 596     }
 597
 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,]+)/);
 602
 603         $label =~ s/\\([\\:;,])/$1/g;
 604         push @filelist, $label;
 605
 606         my @files = split(/,/, $files);
 607         @files = map { $_+0 } @files;
 608         @files = sort { $a <=> $b } @files;
 609         push @filelist, \@files;
 610     }
 611
 612     return \@filelist;
 613 }
 614
 615 %}
 616
 617 /* -------------------------------------------------------------------------
 618  * Functions below this line are only meant to be called within this module;
 619  * do not call them externally. */
 620
 621 void set_pname(char *name);
 622 char *get_pname();
 623 void set_ptype(char *type);
 624 char *get_ptype();
 625 void set_pcontext(pcontext_t context);
 626 pcontext_t get_pcontext();
 627 void safe_cd(void);
 628
 629 void check_running_as(running_as_flags who);
 630
 631 /* Check that fd's 0, 1, and 2 are open, calling critical() if not.
 632  */
 633 %perlcode %{
 634 sub check_std_fds {
 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");
 638 }
 639
 640 %}