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