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

   1 /*
   2  * Copyright (c) 2007-2012 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             g_free(*iter);
 319             argvi++;
 320         }
 321         g_free($1);
 322     }
 323 }
 324
 325 %rename(hexencode) hexencode_string;
 326 char *hexencode_string(char *);
 327 %rename(hexdecode) perl_hexdecode_string;
 328 char *perl_hexdecode_string(char *);
 329 %{
 330 char *perl_hexdecode_string(const char *str) {
 331     GError *err = NULL;
 332     char *tmp;
 333     tmp = hexdecode_string(str, &err);
 334     if (err) {
 335         g_free(tmp);
 336         croak_gerror("Amanda util: hexdecode", &err);
 337     }
 338     return tmp;
 339 }
 340 %}
 341 amglue_export_tag(encoding, hexencode hexdecode);
 342
 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);
 357
 358 %perlcode %{
 359
 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;
 364     } else {
 365         return strftime "%Y%m%d", localtime;
 366     }
 367 }
 368
 369 sub built_with_component {
 370     my ($component) = @_;
 371     my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
 372     return grep { $_ eq $component } @components;
 373 }
 374
 375 %}
 376
 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));
 381     $1 = &fsu;
 382 }
 383
 384 %typemap(argout) (struct fs_usage *fsp) {
 385     SV *sv;
 386     HV *hv;
 387
 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);
 400
 401         $result = newRV((SV *)hv);
 402         SPAGAIN; SP -= argvi;
 403         argvi++;
 404     }
 405 }
 406
 407 %rename(get_fs_usage) get_fs_usage_;
 408 %inline %{
 409 void get_fs_usage_(const char *file, struct fs_usage *fsp)
 410 {
 411     int rv = get_fs_usage(file, NULL, fsp);
 412     if (rv == -1)
 413         /* signal an error to the typemap */
 414         fsp->fsu_blocksize = 0;
 415 }
 416 %}
 417
 418 /*
 419  * Operations that should be in Perl but aren't
 420  */
 421
 422 int fsync(int fd);
 423
 424 /* Perl's fcntl only operates on file handles */
 425 %inline %{
 426 int
 427 set_blocking(int fd, gboolean blocking)
 428 {
 429     int flags = fcntl(fd, F_GETFL, 0);
 430     if (flags < 0)
 431         return flags;
 432     if (blocking)
 433         flags &= ~O_NONBLOCK;
 434     else
 435         flags |= O_NONBLOCK;
 436     flags = fcntl(fd, F_SETFL, flags);
 437     if (flags < 0)
 438         return flags;
 439     return 0;
 440 }
 441 %}
 442
 443 /*
 444  * Locking (see amflock.h)
 445  */
 446
 447 /* SWIG prepends the struct name to the member function name, which
 448  * conflicts with the underlying function names */
 449
 450 typedef struct file_lock {
 451     %extend {
 452         %newobject file_lock;
 453         file_lock(const char *filename) {
 454             return file_lock_new(filename);
 455         }
 456
 457         ~locked_data() {
 458             file_lock_free(self);
 459         }
 460
 461         int lock();
 462         int lock_wr();
 463         int lock_rd();
 464         int unlock();
 465         int locked();
 466
 467         %typemap(in) (const char *data, size_t len) {
 468             $1 = SvPV($input, $2);
 469         }
 470
 471         int write(const char *data, size_t len);
 472
 473         /* get the data as an SV */
 474         %typemap(out) (SV *) { $result = $1; argvi++; };
 475         SV *data() {
 476             if (self->data) {
 477                 return newSVpvn(self->data, self->len);
 478             } else {
 479                 return &PL_sv_undef;
 480             }
 481         }
 482         %typemap(out) (SV *);
 483     }
 484 } file_lock;
 485
 486 %perlcode %{
 487
 488 sub is_pid_alive {
 489     my ($pid) = shift;
 490
 491     return 1 if $pid == $$;
 492
 493     my $Amanda_process = Amanda::Process->new(0);
 494
 495     $Amanda_process->load_ps_table();
 496     my $alive = $Amanda_process->process_alive($pid);
 497     return $alive;
 498
 499 }
 500 %}
 501
 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;"
 507 %inline %{
 508 void weaken_ref(SV *rv) {
 509     sv_rvweaken(rv);
 510 }
 511 %}
 512
 513 %rename(gettimeofday) gettimeofday_for_perl;
 514 %inline %{
 515 static guint64 gettimeofday_for_perl(void)
 516 {
 517     GTimeVal t;
 518     g_get_current_time(&t);
 519     return (guint64)t.tv_sec * G_USEC_PER_SEC + (guint64)t.tv_usec;
 520 }
 521 %}
 522
 523 void openbsd_fd_inform(void);
 524
 525 /*
 526  * Streams
 527  *
 528  * TODO: this should move to Amanda::Security when the rest of the Security API
 529  * is available from Perl.
 530  */
 531
 532 enum { AF_INET };
 533 enum { STREAM_BUFSIZE };
 534 %typemap(in, numinputs=0) in_port_t *port_ARGOUT (in_port_t port) {
 535     $1 = &port;
 536 }
 537 %typemap(argout) in_port_t *port_ARGOUT {
 538     $result = sv_2mortal(newSViv(*$1));
 539     argvi++;
 540 }
 541 /* avoid BigInts for socket fd's */
 542 %{ typedef int socketfd; %}
 543 %typemap(out) socketfd {
 544     $result = sv_2mortal(newSViv($1));
 545     argvi++;
 546 }
 547 socketfd stream_server(int family, in_port_t *port_ARGOUT, size_t sendsize,
 548                   size_t recvsize, gboolean privileged);
 549
 550 socketfd stream_accept(int fd, int timeout, size_t sendsize, size_t recvsize);
 551
 552 %newobject check_security_fd;
 553 %rename(check_security) check_security_fd;
 554 %inline %{
 555 char *check_security_fd(int fd, char *userstr)
 556 {
 557     socklen_t_equiv i;
 558     struct sockaddr_in addr;
 559     char *errstr;
 560
 561     /* get the remote address */
 562     i = SIZEOF(addr);
 563     if (getpeername(fd, (struct sockaddr *)&addr, &i) == -1) {
 564         return g_strdup_printf("getpeername: %s", strerror(errno));
 565     }
 566
 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));
 573     }
 574
 575     /* call out to check_security */
 576     if (!check_security((sockaddr_union *)&addr, userstr, 0, &errstr))
 577         return errstr;
 578
 579     return NULL;
 580 }
 581 %}
 582 amglue_export_ok(
 583         stream_server stream_accept check_security);
 584 amglue_export_tag(constants,
 585         $AF_INET $STREAM_BUFSIZE);
 586
 587 %perlcode %{
 588
 589 # these functions were verified to work similarly to those in
 590 # common-src/tapelist.c - they pass the same tests, at least.
 591
 592 sub marshal_tapespec {
 593     my ($filelist) = @_;
 594     my @filelist = @$filelist; # make a copy we can wreck
 595     my @specs;
 596
 597     while (@filelist) {
 598         my $label = shift @filelist;
 599         my $files = shift @filelist;
 600
 601         $label =~ s/([\\:;,])/\\$1/g;
 602         push @specs, "$label:" . join(",", @$files);
 603     }
 604     return join(";", @specs);
 605 }
 606
 607 sub unmarshal_tapespec {
 608     my ($tapespec) = @_;
 609     my @filelist;
 610
 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.
 615     my $tmp = $tapespec;
 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
 619         # with filenum 0
 620         $tapespec =~ s/\\([\\:;,])/$1/g;
 621         return [ $tapespec, [ 0 ] ];
 622     }
 623
 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,]+)/);
 628
 629         $label =~ s/\\([\\:;,])/$1/g;
 630         push @filelist, $label;
 631
 632         my @files = split(/,/, $files);
 633         @files = map { $_+0 } @files;
 634         @files = sort { $a <=> $b } @files;
 635         push @filelist, \@files;
 636     }
 637
 638     return \@filelist;
 639 }
 640
 641 %}
 642
 643 amglue_export_ok(
 644     match_host match_disk match_datestamp match_level
 645 );
 646
 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);
 651
 652
 653 /* -------------------------------------------------------------------------
 654  * Functions below this line are only meant to be called within this module;
 655  * do not call them externally. */
 656
 657 void set_pname(char *name);
 658 char *get_pname();
 659 void set_ptype(char *type);
 660 char *get_ptype();
 661 void set_pcontext(pcontext_t context);
 662 pcontext_t get_pcontext();
 663 void safe_cd(void);
 664
 665 void check_running_as(running_as_flags who);
 666
 667 /* Check that fd's 0, 1, and 2 are open, calling critical() if not.
 668  */
 669 %perlcode %{
 670 sub check_std_fds {
 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");
 674 }
 675
 676 %}