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