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 sub split_quoted_string_friendly {
 213     my $str = shift;
 214     my @result;
 215
 216     chomp $str;
 217     $str =~ s/^\s+//;
 218     while ($str) {
 219         (my $elt, $str) = skip_quoted_string($str);
 220         push @result, unquote_string($elt);
 221         $str =~ s/^\s+// if $str;
 222     }
 223
 224     return @result;
 225 }
 226
 227 %}
 228
 229 amglue_export_ok(slurp);
 230 amglue_export_ok(burp);
 231 amglue_export_ok(safe_overwrite_file);
 232
 233 %perlcode %{
 234
 235 sub slurp {
 236     my $file = shift @_;
 237     local $/;
 238
 239     open my $fh, "<", $file or croak "can't open $file: $!";
 240     my $data = <$fh>;
 241     close $fh;
 242
 243     return $data;
 244 }
 245
 246 sub burp {
 247     my $file = shift @_;
 248     open my $fh, ">", $file or croak "can't open $file: $!";
 249     print $fh @_;
 250 }
 251
 252 sub safe_overwrite_file {
 253     my ( $filename, $contents ) = @_;
 254
 255     my $tmpfname = "$filename." . time;
 256     open my $tmpfh, ">", $tmpfname or die "open: $!";
 257
 258     print $tmpfh $contents;
 259     (fsync($tmpfh) == 0) or die "fsync: $!";
 260     return rename $tmpfname, $filename;
 261 }
 262
 263 %}
 264
 265 %typemap (in) GPtrArray * {
 266     AV *av;
 267     guint len;
 268     int i;
 269
 270     if (!SvROK($input) || SvTYPE(SvRV($input)) != SVt_PVAV) {
 271         SWIG_exception(SWIG_TypeError, "Expected an arrayref");
 272     }
 273     av = (AV *)SvRV($input);
 274
 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");
 281         }
 282         g_ptr_array_add($1, SvPV_nolen(*elt)); /* TODO: handle unicode here */
 283     }
 284 }
 285 %typemap (freearg) GPtrArray * {
 286     g_ptr_array_free($1, FALSE);
 287 }
 288
 289 %typemap (out) GPtrArray * {
 290     if ($1) {
 291         guint i;
 292         for (i = 0; i < $1->len; i++) {
 293             $result = sv_2mortal(newSVpv(g_ptr_array_index($1, i), 0));
 294             argvi++;
 295         }
 296         g_ptr_array_free($1, TRUE);
 297     } else {
 298         $result = &PL_sv_undef;
 299         argvi++;
 300     }
 301 }
 302
 303 /* for split_quoted_strings */
 304 %typemap(out) gchar ** {
 305     gchar **iter;
 306
 307     if ($1) {
 308         /* Count the DeviceProperties */
 309         EXTEND(SP, g_strv_length($1)); /* make room for return values */
 310
 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.
 314          */
 315
 316         for (iter = $1; *iter; iter++) {
 317             $result = sv_2mortal(newSVpv(*iter, 0));
 318             argvi++;
 319         }
 320     }
 321 }
 322
 323 %rename(hexencode) hexencode_string;
 324 char *hexencode_string(char *);
 325 %rename(hexdecode) perl_hexdecode_string;
 326 char *perl_hexdecode_string(char *);
 327 %{
 328 char *perl_hexdecode_string(const char *str) {
 329     GError *err = NULL;
 330     char *tmp;
 331     tmp = hexdecode_string(str, &err);
 332     if (err) {
 333         g_free(tmp);
 334         croak_gerror("Amanda util: hexdecode", &err);
 335     }
 336     return tmp;
 337 }
 338 %}
 339 amglue_export_tag(encoding, hexencode hexdecode);
 340
 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);
 351
 352 %perlcode %{
 353
 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;
 358     } else {
 359         return strftime "%Y%m%d", localtime;
 360     }
 361 }
 362
 363 sub built_with_component {
 364     my ($component) = @_;
 365     my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
 366     return grep { $_ eq $component } @components;
 367 }
 368
 369 %}
 370
 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));
 375     $1 = &fsu;
 376 }
 377
 378 %typemap(argout) (struct fs_usage *fsp) {
 379     SV *sv;
 380     HV *hv;
 381
 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);
 394
 395         $result = newRV((SV *)hv);
 396         SPAGAIN; SP -= argvi;
 397         argvi++;
 398     }
 399 }
 400
 401 %rename(get_fs_usage) get_fs_usage_;
 402 %inline %{
 403 void get_fs_usage_(const char *file, struct fs_usage *fsp)
 404 {
 405     int rv = get_fs_usage(file, NULL, fsp);
 406     if (rv == -1)
 407         /* signal an error to the typemap */
 408         fsp->fsu_blocksize = 0;
 409 }
 410 %}
 411
 412 /*
 413  * Operations that should be in Perl but aren't
 414  */
 415
 416 int fsync(int fd);
 417
 418 /* Perl's fcntl only operates on file handles */
 419 %inline %{
 420 int
 421 set_blocking(int fd, gboolean blocking)
 422 {
 423     int flags = fcntl(fd, F_GETFL, 0);
 424     if (flags < 0)
 425         return flags;
 426     if (blocking)
 427         flags &= ~O_NONBLOCK;
 428     else
 429         flags |= O_NONBLOCK;
 430     flags = fcntl(fd, F_SETFL, flags);
 431     if (flags < 0)
 432         return flags;
 433     return 0;
 434 }
 435 %}
 436
 437 /*
 438  * Locking (see amflock.h)
 439  */
 440
 441 /* SWIG prepends the struct name to the member function name, which
 442  * conflicts with the underlying function names */
 443
 444 typedef struct file_lock {
 445     %extend {
 446         file_lock(const char *filename) {
 447             return file_lock_new(filename);
 448         }
 449
 450         ~locked_data() {
 451             file_lock_free(self);
 452         }
 453
 454         int lock();
 455         int unlock();
 456
 457         %typemap(in) (const char *data, size_t len) {
 458             $1 = SvPV($input, $2);
 459         }
 460
 461         int write(const char *data, size_t len);
 462
 463         /* get the data as an SV */
 464         %typemap(out) (SV *) { $result = $1; argvi++; };
 465         SV *data() {
 466             if (self->data) {
 467                 return newSVpvn(self->data, self->len);
 468             } else {
 469                 return &PL_sv_undef;
 470             }
 471         }
 472         %typemap(out) (SV *);
 473     }
 474 } file_lock;
 475
 476 %perlcode %{
 477
 478 sub is_pid_alive {
 479     my ($pid) = shift;
 480
 481     return 1 if $pid == $$;
 482
 483     my $Amanda_process = Amanda::Process->new(0);
 484
 485     $Amanda_process->load_ps_table();
 486     my $alive = $Amanda_process->process_alive($pid);
 487     return $alive;
 488
 489 }
 490 %}
 491
 492 /* Interesting story: Perl added a sv_rvweaken function in 5.6.0 (or earlier?), but
 493  * did not include this functionality in Scalar::Util until later.  It doesn't make
 494  * much sense, does it? */
 495 amglue_export_ok(weaken_ref)
 496 %typemap(in) SV *rv "$1 = $input;"
 497 %inline %{
 498 void weaken_ref(SV *rv) {
 499     sv_rvweaken(rv);
 500 }
 501 %}
 502
 503 %rename(gettimeofday) gettimeofday_for_perl;
 504 %inline %{
 505 static guint64 gettimeofday_for_perl(void)
 506 {
 507     GTimeVal t;
 508     g_get_current_time(&t);
 509     return (guint64)t.tv_sec * G_USEC_PER_SEC + (guint64)t.tv_usec;
 510 }
 511 %}
 512
 513 void openbsd_fd_inform(void);
 514
 515 /*
 516  * Streams
 517  *
 518  * TODO: this should move to Amanda::Security when the rest of the Security API
 519  * is available from Perl.
 520  */
 521
 522 enum { AF_INET };
 523 enum { STREAM_BUFSIZE };
 524 %typemap(in, numinputs=0) in_port_t *port_ARGOUT (in_port_t port) {
 525     $1 = &port;
 526 }
 527 %typemap(argout) in_port_t *port_ARGOUT {
 528     $result = sv_2mortal(newSViv(*$1));
 529     argvi++;
 530 }
 531 /* avoid BigInts for socket fd's */
 532 %{ typedef int socketfd; %}
 533 %typemap(out) socketfd {
 534     $result = sv_2mortal(newSViv($1));
 535     argvi++;
 536 }
 537 socketfd stream_server(int family, in_port_t *port_ARGOUT, size_t sendsize,
 538                   size_t recvsize, gboolean privileged);
 539
 540 socketfd stream_accept(int fd, int timeout, size_t sendsize, size_t recvsize);
 541
 542 %newobject check_security_fd;
 543 %rename(check_security) check_security_fd;
 544 %inline %{
 545 char *check_security_fd(int fd, char *userstr)
 546 {
 547     socklen_t_equiv i;
 548     struct sockaddr_in addr;
 549     char *errstr;
 550
 551     /* get the remote address */
 552     i = SIZEOF(addr);
 553     if (getpeername(fd, (struct sockaddr *)&addr, &i) == -1) {
 554         return g_strdup_printf("getpeername: %s", strerror(errno));
 555     }
 556
 557     /* require IPv4 and not port 20 -- apparently this was a common attack
 558      * vector for much older Amandas */
 559     if ((addr.sin_family != (sa_family_t)AF_INET)
 560                 || (ntohs(addr.sin_port) == 20)) {
 561         return g_strdup_printf("connection rejected from %s family %d port %d",
 562              inet_ntoa(addr.sin_addr), addr.sin_family, htons(addr.sin_port));
 563     }
 564
 565     /* call out to check_security */
 566     if (!check_security((sockaddr_union *)&addr, userstr, 0, &errstr))
 567         return errstr;
 568
 569     return NULL;
 570 }
 571 %}
 572 amglue_export_ok(
 573         stream_server stream_accept check_security);
 574 amglue_export_tag(constants,
 575         $AF_INET $STREAM_BUFSIZE);
 576
 577 %perlcode %{
 578
 579 # these functions were verified to work similarly to those in
 580 # common-src/tapelist.c - they pass the same tests, at least.
 581
 582 sub marshal_tapespec {
 583     my ($filelist) = @_;
 584     my @filelist = @$filelist; # make a copy we can wreck
 585     my @specs;
 586
 587     while (@filelist) {
 588         my $label = shift @filelist;
 589         my $files = shift @filelist;
 590
 591         $label =~ s/([\\:;,])/\\$1/g;
 592         push @specs, "$label:" . join(",", @$files);
 593     }
 594     return join(";", @specs);
 595 }
 596
 597 sub unmarshal_tapespec {
 598     my ($tapespec) = @_;
 599     my @filelist;
 600
 601     # detect a non-tapespec string for special handling; in particular, a string
 602     # without an unquoted : followed by digits and commas at the end.  The easiest
 603     # way to do this is to replace every quoted character with a dummy, then look
 604     # for the colon and digits.
 605     my $tmp = $tapespec;
 606     $tmp =~ s/\\([\\:;,])/X/g;
 607     if ($tmp !~ /:[,\d]+$/) {
 608         # ok, it doesn't end with the right form, so unquote it and return it
 609         # with filenum 0
 610         $tapespec =~ s/\\([\\:;,])/$1/g;
 611         return [ $tapespec, [ 0 ] ];
 612     }
 613
 614     # use a lookbehind to mask out any quoted ;'s
 615     my @volumes = split(/(?<!\\);/, $tapespec);
 616     for my $vol (@volumes) {
 617         my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
 618
 619         $label =~ s/\\([\\:;,])/$1/g;
 620         push @filelist, $label;
 621
 622         my @files = split(/,/, $files);
 623         @files = map { $_+0 } @files;
 624         @files = sort { $a <=> $b } @files;
 625         push @filelist, \@files;
 626     }
 627
 628     return \@filelist;
 629 }
 630
 631 %}
 632
 633 /* -------------------------------------------------------------------------
 634  * Functions below this line are only meant to be called within this module;
 635  * do not call them externally. */
 636
 637 void set_pname(char *name);
 638 char *get_pname();
 639 void set_ptype(char *type);
 640 char *get_ptype();
 641 void set_pcontext(pcontext_t context);
 642 pcontext_t get_pcontext();
 643 void safe_cd(void);
 644
 645 void check_running_as(running_as_flags who);
 646
 647 /* Check that fd's 0, 1, and 2 are open, calling critical() if not.
 648  */
 649 %perlcode %{
 650 sub check_std_fds {
 651     fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
 652     fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
 653     fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");
 654 }
 655
 656 %}