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

   1 # This file was automatically generated by SWIG (http://www.swig.org).
   2 # Version 1.3.39
   3 #
   4 # Do not make changes to this file unless you know what you are doing--modify
   5 # the SWIG interface file instead.
   6
   7 package Amanda::Util;
   8 use base qw(Exporter);
   9 use base qw(DynaLoader);
  10 package Amanda::Utilc;
  11 bootstrap Amanda::Util;
  12 package Amanda::Util;
  13 @EXPORT = qw();
  14
  15 # ---------- BASE METHODS -------------
  16
  17 package Amanda::Util;
  18
  19 sub TIEHASH {
  20     my ($classname,$obj) = @_;
  21     return bless $obj, $classname;
  22 }
  23
  24 sub CLEAR { }
  25
  26 sub FIRSTKEY { }
  27
  28 sub NEXTKEY { }
  29
  30 sub FETCH {
  31     my ($self,$field) = @_;
  32     my $member_func = "swig_${field}_get";
  33     $self->$member_func();
  34 }
  35
  36 sub STORE {
  37     my ($self,$field,$newval) = @_;
  38     my $member_func = "swig_${field}_set";
  39     $self->$member_func($newval);
  40 }
  41
  42 sub this {
  43     my $ptr = shift;
  44     return tied(%$ptr);
  45 }
  46
  47
  48 # ------- FUNCTION WRAPPERS --------
  49
  50 package Amanda::Util;
  51
  52 *get_original_cwd = *Amanda::Utilc::get_original_cwd;
  53 *hexencode = *Amanda::Utilc::hexencode;
  54 *hexdecode = *Amanda::Utilc::hexdecode;
  55 *sanitise_filename = *Amanda::Utilc::sanitise_filename;
  56 *quote_string = *Amanda::Utilc::quote_string;
  57 *unquote_string = *Amanda::Utilc::unquote_string;
  58 *expand_braced_alternates = *Amanda::Utilc::expand_braced_alternates;
  59 *collapse_braced_alternates = *Amanda::Utilc::collapse_braced_alternates;
  60 *split_quoted_strings = *Amanda::Utilc::split_quoted_strings;
  61 *get_fs_usage = *Amanda::Utilc::get_fs_usage;
  62 *fsync = *Amanda::Utilc::fsync;
  63 *set_blocking = *Amanda::Utilc::set_blocking;
  64 *weaken_ref = *Amanda::Utilc::weaken_ref;
  65 *gettimeofday = *Amanda::Utilc::gettimeofday;
  66 *openbsd_fd_inform = *Amanda::Utilc::openbsd_fd_inform;
  67 *stream_server = *Amanda::Utilc::stream_server;
  68 *stream_accept = *Amanda::Utilc::stream_accept;
  69 *check_security = *Amanda::Utilc::check_security;
  70 *set_pname = *Amanda::Utilc::set_pname;
  71 *get_pname = *Amanda::Utilc::get_pname;
  72 *set_ptype = *Amanda::Utilc::set_ptype;
  73 *get_ptype = *Amanda::Utilc::get_ptype;
  74 *set_pcontext = *Amanda::Utilc::set_pcontext;
  75 *get_pcontext = *Amanda::Utilc::get_pcontext;
  76 *safe_cd = *Amanda::Utilc::safe_cd;
  77 *check_running_as = *Amanda::Utilc::check_running_as;
  78
  79 ############# Class : Amanda::Util::file_lock ##############
  80
  81 package Amanda::Util::file_lock;
  82 use vars qw(@ISA %OWNER %ITERATORS %BLESSEDMEMBERS);
  83 @ISA = qw( Amanda::Util );
  84 %OWNER = ();
  85 %ITERATORS = ();
  86 sub new {
  87     my $pkg = shift;
  88     my $self = Amanda::Utilc::new_file_lock(@_);
  89     bless $self, $pkg if defined($self);
  90 }
  91
  92 *lock = *Amanda::Utilc::file_lock_lock;
  93 *lock_wr = *Amanda::Utilc::file_lock_lock_wr;
  94 *lock_rd = *Amanda::Utilc::file_lock_lock_rd;
  95 *unlock = *Amanda::Utilc::file_lock_unlock;
  96 *locked = *Amanda::Utilc::file_lock_locked;
  97 *write = *Amanda::Utilc::file_lock_write;
  98 *data = *Amanda::Utilc::file_lock_data;
  99 sub DESTROY {
 100     return unless $_[0]->isa('HASH');
 101     my $self = tied(%{$_[0]});
 102     return unless defined $self;
 103     delete $ITERATORS{$self};
 104     if (exists $OWNER{$self}) {
 105         Amanda::Utilc::delete_file_lock($self);
 106         delete $OWNER{$self};
 107     }
 108 }
 109
 110 sub DISOWN {
 111     my $self = shift;
 112     my $ptr = tied(%$self);
 113     delete $OWNER{$ptr};
 114 }
 115
 116 sub ACQUIRE {
 117     my $self = shift;
 118     my $ptr = tied(%$self);
 119     $OWNER{$ptr} = 1;
 120 }
 121
 122
 123 # ------- VARIABLE STUBS --------
 124
 125 package Amanda::Util;
 126
 127 *RUNNING_AS_ANY = *Amanda::Utilc::RUNNING_AS_ANY;
 128 *RUNNING_AS_ROOT = *Amanda::Utilc::RUNNING_AS_ROOT;
 129 *RUNNING_AS_DUMPUSER = *Amanda::Utilc::RUNNING_AS_DUMPUSER;
 130 *RUNNING_AS_DUMPUSER_PREFERRED = *Amanda::Utilc::RUNNING_AS_DUMPUSER_PREFERRED;
 131 *RUNNING_AS_CLIENT_LOGIN = *Amanda::Utilc::RUNNING_AS_CLIENT_LOGIN;
 132 *RUNNING_AS_UID_ONLY = *Amanda::Utilc::RUNNING_AS_UID_ONLY;
 133 *CONTEXT_DEFAULT = *Amanda::Utilc::CONTEXT_DEFAULT;
 134 *CONTEXT_CMDLINE = *Amanda::Utilc::CONTEXT_CMDLINE;
 135 *CONTEXT_DAEMON = *Amanda::Utilc::CONTEXT_DAEMON;
 136 *CONTEXT_SCRIPTUTIL = *Amanda::Utilc::CONTEXT_SCRIPTUTIL;
 137 *AF_INET = *Amanda::Utilc::AF_INET;
 138 *STREAM_BUFSIZE = *Amanda::Utilc::STREAM_BUFSIZE;
 139
 140 @EXPORT_OK = ();
 141 %EXPORT_TAGS = ();
 142
 143
 144 =head1 NAME
 145
 146 Amanda::Util - Runtime support for Amanda applications
 147
 148 =head1 Application Initialization
 149
 150 Application initialization generally looks like this:
 151
 152   use Amanda::Config qw( :init );
 153   use Amanda::Util qw( :constants );
 154   use Amanda::Debug;
 155
 156   Amanda::Util::setup_application("myapp", "server", $CONTEXT_CMDLINE);
 157   # .. command-line processing ..
 158   Amanda::Config::config_init(...);
 159   Amanda::Util::finish_setup($RUNNING_AS_DUMPUSER);
 160   # ..
 161   Amanda::Util::finish_application();
 162
 163 =over
 164
 165 =item setup_application($name, $type, $context)
 166
 167 Set up the operating environment for an application, without requiring
 168 any configuration.
 169
 170 C<$name> is the name of the application, used in log messages, etc.
 171 C<$type> is usualy one of "server" or "client".  It specifies the
 172 subdirectory in which debug logfiles will be created.  C<$context>
 173 indicates the usual manner in which this application is invoked; one
 174 of C<$CONTEXT_CMDLINE> for a user-invoked command-line utility (e.g.,
 175 C<amadmin>) which should send human-readable error messages to stderr;
 176 C<$CONTEXT_DAEMON> for a program started by C<amandad>, e.g.,
 177 C<sendbackup>; or C<$CONTEXT_SCRIPTUTIL> for a small program used from
 178 shell scripts, e.g., C<amgetconf>
 179
 180 Based on C<$type> and C<$context>, this function does the following:
 181
 182 =over
 183
 184 =item *
 185
 186 sets up debug logging;
 187
 188 =item *
 189
 190 configures internationalization
 191
 192 =item *
 193
 194 sets the umask;
 195
 196 =item *
 197
 198 sets the current working directory to the debug or temporary
 199 directory;
 200
 201 =item *
 202
 203 closes any unnecessary file descriptors as a security meaasure;
 204
 205 =item *
 206
 207 ignores C<SIGPIPE>; and
 208
 209 =item *
 210
 211 sets the appropriate target for error messages.
 212
 213 =back
 214
 215 =item finish_setup($running_as_flags)
 216
 217 Perform final initialization tasks that require a loaded
 218 configuration.  Specifically, move the debug log into a
 219 configuration-specific subdirectory, and check that the current userid
 220 is appropriate for this applciation.
 221
 222 The user is specified by one of the following flags, which are
 223 available in export tag C<:check_running_as_flags>:
 224
 225   $RUNNING_AS_ANY                 # any user is OK
 226   $RUNNING_AS_ROOT                # root
 227   $RUNNING_AS_DUMPUSER            # dumpuser, from configuration
 228   $RUNNING_AS_DUMPUSER_PREFERRED  # dumpuser, but client_login is OK too
 229   $RUNNING_AS_CLIENT_LOGIN        # client_login (--with-user at build time)
 230
 231 If the flag C<$RUNNING_AS_UID_ONLY> is bit-or'd into
 232 C<$running_as_flags>, then the euid is ignored; this is used for
 233 programs that expect to be setuid-root.
 234
 235 =item finish_application()
 236
 237 Remove old debug files.
 238 All applications should call this before exiting.
 239
 240 =item get_original_cwd()
 241
 242 Return the original current directory with C<get_original_cwd>.
 243
 244 =item version_opt()
 245
 246 Print the version and exit.  This is intended to be used in C<GetOptions> invocations, e.g.,
 247
 248   GetOptions(
 249     # ...
 250     'version' => \&Amanda::Util::version_opt,
 251   );
 252
 253 =back
 254
 255 =head1 File Handling
 256
 257 These functions read and write the entire requested size to a file
 258 descriptor, even if the underlying syscall returns early.  Note that
 259 they do not operate on Perl file handles.
 260
 261 If fewer than C<$size> bytes are written, C<full_write> returns the
 262 number of bytes actually written and sets C<$!> appropriately.  When
 263 reading, if fewer than C<$size> bytes are read due to a normal EOF,
 264 then C<$!> is zero; otherwise, it contains the appropriate error
 265 message.
 266
 267 Unlike C<POSIX::read>, C<full_read> returns a scalar containing the
 268 bytes it read from the file descriptor.
 269
 270 =over
 271
 272 =item full_read($fd, $size)
 273
 274 =item full_write($fd, $buf, $size)
 275
 276 =back
 277
 278 =head1 Miscellaneous Utilities
 279
 280 =over
 281
 282 =item safe_env()
 283
 284 Return a "safe" environment hash.  For non-setuid programs, this means
 285 filtering out any localization variables.
 286
 287 =item get_fs_usage(file)
 288
 289 This is a wrapper around the Gnulib function of the same name.  On success, it returns
 290 a hash with keys:
 291
 292   blocksize           Size of a block
 293   blocks              Total blocks on disk
 294   bfree               Free blocks available to superuser
 295   bavail              Free blocks available to non-superuser
 296   bavail_top_bit_set  1 if fsu_bavail represents a value < 0
 297   files               Total file nodes
 298   ffree               Free file nodes
 299
 300 On failure, it returns nothing, and C<$!> should be set.  If C<$!> is 0, then
 301 this is a system which cannot measure usage without a C<disk> argument, which
 302 this wrapper does not support.
 303
 304 =item is_pid_alive(pid)
 305
 306 Return 1 is the process with that pid is still alive.
 307
 308 =item weaken_ref($ref)
 309
 310 This is exactly the same as C<Scalar::Util::weaken>, but available in all
 311 supported versions of perl.
 312
 313 =item gettimeofday()
 314
 315 Return the number of microseconds since the UNIX epoch.
 316
 317 =item fsync($fd)
 318
 319 Invoke the C<fsync> syscall.
 320
 321 =item set_blocking($fd, $blocking)
 322
 323 Set or clear the C<O_NONBLOCK> fd flag on $fd; returns a negative value on
 324 failure, or 0 on success.
 325
 326 =item openbsd_fd_inform()
 327
 328 Due to a particularly poor user-space implementation of threading on OpenBSD,
 329 executables that are run with nonstandard file descriptors open (fd > 2) find
 330 those descriptors to be in a nonblocking state.  This particularly affects
 331 amandad services, which begin with several file descriptors in the 50's open.
 332
 333 This function "informs" the C library about these descriptors by making an
 334 C<fcntl(fd, F_GETFL)> call.  This is otherwise harmless, and is only perfomed
 335 on OpenBSD.
 336
 337 =item built_with_component($comp)
 338
 339 Returns true if Amanda was built with the given component.  Component names are
 340 in C<config/amanda/components.m4>.
 341
 342 =back
 343
 344 =head1 TCP Utilities
 345
 346 These are thin wrappers over functions in C<common-src/stream.h> and other related
 347 functions.
 348
 349 =over
 350
 351 =item stream_server
 352
 353     my $family = $Amanda::Util::AF_INET;
 354     my $bufsize = $Amanda::Util::STREAM_BUFSIZE;
 355     my ($listensock, $port) = Amanda::Util::stream_server(
 356             $family, $bufsize, $bufsize, $priv);
 357
 358 This function creates a new socket and binds it to a port, returning both the
 359 socket and port.  If the socket is -1, then an error occurred and is available
 360 in C<$!>.  The constants C<$AF_INET> and C<$STREAM_BUFSIZE> are universally
 361 used when calling this function.  If the final argument, C<$priv>, is true,
 362 then a the function opens a privileged port (below 1024).
 363
 364 =item stream_accept
 365
 366     my $sock = Amanda::Util::stream_accept(
 367             $listen_sock, $timeout, $bufsize, $bufsize);
 368
 369 This function accepts a connection on a listening socket.  If the connection is
 370 not made within C<$timeout> seconds, or some other error occurs, then the
 371 function returns -1.  The bufsize arguments are applied to the new socket.
 372
 373 =item check_security
 374
 375     my $ok = Amanda::Util::check_security($socket, $userstr);
 376
 377 This function takes a socket descriptor and a string of the form C<"USER foo">
 378 and performs BSD-style checks on that descriptor.  These include verifying
 379 round-trip DNS sanity; check that the user is in C<.rhosts> or C<.amandahosts>,
 380 and checking that the remote port is reserved.  Returns an error string on
 381 error, or C<undef> on success.
 382
 383 =back
 384
 385 =head1 String Utilities
 386
 387 =over
 388
 389 =item quote_string($str)
 390
 391 Quote a string using Amanda's quoting algorithm.  Strings with no
 392 whitespace, control, or quote characters are returned unchanged.  An
 393 empty string is represented as the two-character string C<"">.
 394 Otherwise, tab, newline, carriage return, form-feed, backslash, and
 395 double-quote (C<">) characters are escaped with a backslash and the
 396 string is surrounded by double quotes.
 397
 398 =item unquote_string($str)
 399
 400 Unquote a string as quoted with C<quote_string>.
 401
 402 =item skip_quoted_string($str)
 403
 404 my($q, $remaider) = skip_quoted_string($str)
 405
 406 Return the first quoted string and the remainder of the string, as separated by
 407 any whitespace.  Note that the remainder of the string does not include the
 408 single separating whitespace character, but will include any subsequent
 409 whitespace.  The C<$q> is not unquoted.
 410
 411 =item C<split_quoted_strings($str)>
 412
 413 Split string on unquoted whitespace.  Multiple consecutive spaces are I<not>
 414 collapsed into a single space: C<"x  y"> (with two spaces) parses as C<( "x",
 415 "", "y")>.  The strings are unquoted before they are returned.  An empty string
 416 is split into C<( "" )>.  This method is generally used for parsing IPC messages,
 417 where blank space is significant and well-controlled.
 418
 419 =item C<split_quoted_strings_friendly($str)>
 420
 421 Similar to C<split_quoted_strings>, but intended for user-friendly uses.  In
 422 particular, this function treats any sequence of zero or more whitespace
 423 characters as a separator, rather than the more strict interpretation applied
 424 by C<split_quoted_strings>.  All of the strings are unquoted.
 425
 426 All of these quoting-related functions are available under the export
 427 tag C<:quoting>.
 428
 429 =item hexencode($str)
 430
 431 Encode a string using URI-style hexadecimal encoding.
 432 Non-alphanumeric characters will be replaced with "%xx"
 433 where "xx" is the two-digit hexadecimal representation of the character.
 434
 435 =item hexdecode($str)
 436
 437 Decode a string using URI-style hexadecimal encoding.
 438
 439 Both C<hexencode> and C<hexdecode> are available under the export tag C<:encoding>
 440
 441 =item expand_braced_alternates($str)
 442 =item collapse_braced_alternates(\@list)
 443
 444 These two functions handle "braced alternates", which is a syntax
 445 borrowed, partially, from shells.  Comma-separated strings enclosed in
 446 curly braces expand into multiple alternatives for the entire string.
 447 For example:
 448
 449   "{foo,bar,bat}"   [ "foo", "bar", "bat" ]
 450   "foo{1,2}bar"     [ "foo1bar", "foo2bar" ]
 451   "foo{1\,2,3}bar"  [ "foo1,2bar", "foo3bar" ]
 452   "{a,b}-{1,2}"     [ "a-1", "a-2", "b-1", "b-2" ]
 453
 454 Note that nested braces are not processed.  Braces, commas, and
 455 backslashes may be escaped with backslashes.
 456
 457 As a special case for numeric ranges, if the braces contain only digits
 458 followed by two dots followed by more digits, and the digits sort in the
 459 correct order, then they will be treated as a sequence.  If the first number in
 460 the sequence has leading zeroes, then all generated numbers will have that
 461 length, padded with leading zeroes.
 462
 463   "tape-{01..10}"   [ "tape-01", "tape-02", "tape-03", "tape-04",
 464                       "tape-05", "tape-06", "tape-07", "tape-08",
 465                       "tape-09", "tape-10" ]
 466
 467 On error, C<expand_braced_altnerates> returns undef.  These two functions are
 468 available in the export tag C<:alternates>.
 469
 470 =item generate_timestamp()
 471
 472 Generate a timestamp from the current time, obeying the
 473 'USETIMESTAMPS' config parameter.  The Amanda configuration must
 474 already be loaded.
 475
 476 =item sanitise_filename($fn)
 477
 478 "Santitises" a filename by replacing any characters that might have special
 479 meaning to a filesystem with underscores.  This operation is I<not> reversible,
 480 and distinct input filenames I<may> produce identical output filenames.
 481
 482 =item unmarshal_tapespec($tapespec)
 483 =item marshal_tapespec($filelist)
 484
 485 These functions convert between a tapespec -- formerly, and confusingly, called
 486 a "tapelist" -- and a perl data structure like
 487
 488     [   $label1 => [ $filenum1, $filenum2, .. ],
 489         $label2 => [ $filenum1, $filenum2, .. ],
 490     ]
 491
 492 Note that a non-tapespec C<$string> will be unmarshalled as C<[ $string, [] ]>.
 493
 494 =back
 495
 496 =head1 Locking Files
 497
 498 Amanda provides a basic mechanism to lock a file and read its contents.  This
 499 uses operating-system facilities to acquire an advisory lock, so non-Amanda
 500 applications are not prevented from modifying the file while it is locked.
 501
 502 To create a lock object, call the C<file_lock> constructor, passing the
 503 filename to lock:
 504
 505   my $fl = Amanda::Util::file_lock->new($filename)
 506
 507 then, three ways to lock the file:
 508
 509   $fl->lock_wr();       # take a write lock (exclusive)
 510   $fl->lock_rd();       # take a read lock
 511   $fl->lock();          # take a write lock and reads the contents of
 512                         # the file into memory.
 513
 514 they return -1 on failure, 0 if the lock is taken or 1 if the lock in not
 515 taken (you can retry later).
 516
 517 to access the data in memory
 518
 519   my $state = $fl->data();
 520
 521 to change the file contents, call C<write>:
 522
 523   $fl->write($new_contents);
 524
 525 and unlock the lock with
 526
 527   $fl->unlock();
 528
 529 Note that the file will be automatically unlocked if the C<file_lock> object is
 530 garbage-collected.
 531
 532 =head1 Simple File Reading & Writing
 533
 534 For reading small files directly into memory with little code
 535 overhead, we can use C<slurp>.
 536
 537   my $data = slurp $filename;
 538
 539 After processing the data, we can write it back to file with C<burp>.  This
 540 function always completely overwrites the file.
 541
 542   burp $filename, $header;
 543
 544 These functions can (and should) be exported to the main namespace
 545
 546 =cut
 547
 548
 549
 550 use Amanda::Debug qw(:init);
 551 use Amanda::Config qw(:getconf);
 552 use warnings;
 553 use Carp;
 554 use POSIX qw( :fcntl_h :errno_h );
 555 use POSIX qw( strftime );
 556 use Amanda::Constants;
 557 use Amanda::Process;
 558
 559 # private package variables
 560 my $_pname;
 561 my $_ptype;
 562 my $_pcontext;
 563
 564 sub setup_application {
 565     my ($name, $type, $context) = @_;
 566
 567     # sanity check
 568     croak("no name given") unless ($name);
 569     croak("no type given") unless ($type);
 570     croak("no context given") unless ($context);
 571
 572     # store these as perl values
 573     $_pname = $name;
 574     $_ptype = $type;
 575     $_pcontext = $context;
 576
 577     # and let the C side know about them too
 578     set_pname($name);
 579     set_ptype($type);
 580     set_pcontext($context);
 581
 582     safe_cd(); # (also sets umask)
 583     check_std_fds();
 584
 585     # set up debugging, now that we have a name, type, and context
 586     debug_init();
 587
 588     # ignore SIGPIPE
 589     $SIG{'PIPE'} = 'IGNORE';
 590 }
 591
 592 sub finish_setup {
 593     my ($running_as) = @_;
 594
 595     my $config_name = Amanda::Config::get_config_name();
 596
 597     if ($config_name) {
 598         dbrename($config_name, $_ptype);
 599     }
 600
 601     check_running_as($running_as);
 602 }
 603
 604 sub finish_application {
 605     dbclose();
 606 }
 607
 608 sub version_opt {
 609     print "$_pname-$Amanda::Constants::VERSION\n";
 610     exit 0;
 611 }
 612
 613
 614 push @EXPORT_OK, qw(get_original_cwd);
 615 push @{$EXPORT_TAGS{"util"}}, qw(get_original_cwd);
 616
 617 sub safe_env {
 618     my %rv = %ENV;
 619
 620     delete @rv{qw(IFS CDPATH ENV BASH_ENV LANG)};
 621
 622     # delete all LC_* variables
 623     for my $var (grep /^LC_/, keys %rv) {
 624         delete $rv{$var};
 625     }
 626
 627     return %rv;
 628 }
 629
 630
 631 push @EXPORT_OK, qw(running_as_flags_to_strings);
 632 push @{$EXPORT_TAGS{"running_as_flags"}}, qw(running_as_flags_to_strings);
 633
 634 my %_running_as_flags_VALUES;
 635 #Convert a flag value to a list of names for flags that are set.
 636 sub running_as_flags_to_strings {
 637     my ($flags) = @_;
 638     my @result = ();
 639
 640     for my $k (keys %_running_as_flags_VALUES) {
 641         my $v = $_running_as_flags_VALUES{$k};
 642
 643         #is this a matching flag?
 644         if (($v == 0 && $flags == 0) || ($v != 0 && ($flags & $v) == $v)) {
 645             push @result, $k;
 646         }
 647     }
 648
 649 #by default, just return the number as a 1-element list
 650     if (!@result) {
 651         return ($flags);
 652     }
 653
 654     return @result;
 655 }
 656
 657 push @EXPORT_OK, qw($RUNNING_AS_ANY);
 658 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ANY);
 659
 660 $_running_as_flags_VALUES{"RUNNING_AS_ANY"} = $RUNNING_AS_ANY;
 661
 662 push @EXPORT_OK, qw($RUNNING_AS_ROOT);
 663 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_ROOT);
 664
 665 $_running_as_flags_VALUES{"RUNNING_AS_ROOT"} = $RUNNING_AS_ROOT;
 666
 667 push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER);
 668 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER);
 669
 670 $_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER"} = $RUNNING_AS_DUMPUSER;
 671
 672 push @EXPORT_OK, qw($RUNNING_AS_DUMPUSER_PREFERRED);
 673 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_DUMPUSER_PREFERRED);
 674
 675 $_running_as_flags_VALUES{"RUNNING_AS_DUMPUSER_PREFERRED"} = $RUNNING_AS_DUMPUSER_PREFERRED;
 676
 677 push @EXPORT_OK, qw($RUNNING_AS_CLIENT_LOGIN);
 678 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_CLIENT_LOGIN);
 679
 680 $_running_as_flags_VALUES{"RUNNING_AS_CLIENT_LOGIN"} = $RUNNING_AS_CLIENT_LOGIN;
 681
 682 push @EXPORT_OK, qw($RUNNING_AS_UID_ONLY);
 683 push @{$EXPORT_TAGS{"running_as_flags"}}, qw($RUNNING_AS_UID_ONLY);
 684
 685 $_running_as_flags_VALUES{"RUNNING_AS_UID_ONLY"} = $RUNNING_AS_UID_ONLY;
 686
 687 #copy symbols in running_as_flags to constants
 688 push @{$EXPORT_TAGS{"constants"}},  @{$EXPORT_TAGS{"running_as_flags"}};
 689
 690 push @EXPORT_OK, qw(pcontext_t_to_string);
 691 push @{$EXPORT_TAGS{"pcontext_t"}}, qw(pcontext_t_to_string);
 692
 693 my %_pcontext_t_VALUES;
 694 #Convert an enum value to a single string
 695 sub pcontext_t_to_string {
 696     my ($enumval) = @_;
 697
 698     for my $k (keys %_pcontext_t_VALUES) {
 699         my $v = $_pcontext_t_VALUES{$k};
 700
 701         #is this a matching flag?
 702         if ($enumval == $v) {
 703             return $k;
 704         }
 705     }
 706
 707 #default, just return the number
 708     return $enumval;
 709 }
 710
 711 push @EXPORT_OK, qw($CONTEXT_DEFAULT);
 712 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DEFAULT);
 713
 714 $_pcontext_t_VALUES{"CONTEXT_DEFAULT"} = $CONTEXT_DEFAULT;
 715
 716 push @EXPORT_OK, qw($CONTEXT_CMDLINE);
 717 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_CMDLINE);
 718
 719 $_pcontext_t_VALUES{"CONTEXT_CMDLINE"} = $CONTEXT_CMDLINE;
 720
 721 push @EXPORT_OK, qw($CONTEXT_DAEMON);
 722 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_DAEMON);
 723
 724 $_pcontext_t_VALUES{"CONTEXT_DAEMON"} = $CONTEXT_DAEMON;
 725
 726 push @EXPORT_OK, qw($CONTEXT_SCRIPTUTIL);
 727 push @{$EXPORT_TAGS{"pcontext_t"}}, qw($CONTEXT_SCRIPTUTIL);
 728
 729 $_pcontext_t_VALUES{"CONTEXT_SCRIPTUTIL"} = $CONTEXT_SCRIPTUTIL;
 730
 731 #copy symbols in pcontext_t to constants
 732 push @{$EXPORT_TAGS{"constants"}},  @{$EXPORT_TAGS{"pcontext_t"}};
 733
 734 sub full_read {
 735     my ($fd, $count) = @_;
 736     my @bufs;
 737
 738     while ($count > 0) {
 739         my $b;
 740         my $n_read = POSIX::read($fd, $b, $count);
 741         if (!defined $n_read) {
 742             next if ($! == EINTR);
 743             return undef;
 744         } elsif ($n_read == 0) {
 745             last;
 746         }
 747         push @bufs, $b;
 748         $count -= $n_read;
 749     }
 750
 751     return join('', @bufs);
 752 }
 753
 754 sub full_write {
 755     my ($fd, $buf, $count) = @_;
 756     my $total = 0;
 757
 758     while ($count > 0) {
 759         my $n_written = POSIX::write($fd, $buf, $count);
 760         if (!defined $n_written) {
 761             next if ($! == EINTR);
 762             return undef;
 763         } elsif ($n_written == 0) {
 764             last;
 765         }
 766
 767         $count -= $n_written;
 768         $total += $n_written;
 769
 770         if ($count) {
 771             $buf = substr($buf, $n_written);
 772         }
 773     }
 774
 775     return $total;
 776 }
 777
 778 sub skip_quoted_string {
 779     my $str = shift;
 780
 781     chomp $str;
 782     my $iq = 0;
 783     my $i = 0;
 784     my $c = substr $str, $i, 1;
 785     while ($c ne "" && !($iq == 0 && $c =~ /\s/)) {
 786         if ($c eq '"') {
 787             $iq = !$iq;
 788         } elsif ($c eq '\\') {
 789             $i++;
 790         }
 791         $i++;
 792         $c = substr $str, $i, 1;
 793     }
 794     my $quoted_string = substr $str, 0, $i;
 795     my $remainder     = undef;
 796     if (length($str) > $i) {
 797         $remainder    = substr $str, $i+1;
 798     }
 799
 800     return ($quoted_string, $remainder);
 801 }
 802
 803 sub split_quoted_string_friendly {
 804     my $str = shift;
 805     my @result;
 806
 807     chomp $str;
 808     $str =~ s/^\s+//;
 809     while ($str) {
 810         (my $elt, $str) = skip_quoted_string($str);
 811         push @result, unquote_string($elt);
 812         $str =~ s/^\s+// if $str;
 813     }
 814
 815     return @result;
 816 }
 817
 818
 819 push @EXPORT_OK, qw(slurp);
 820
 821 push @EXPORT_OK, qw(burp);
 822
 823 push @EXPORT_OK, qw(safe_overwrite_file);
 824
 825
 826 sub slurp {
 827     my $file = shift @_;
 828     local $/;
 829
 830     open my $fh, "<", $file or croak "can't open $file: $!";
 831     my $data = <$fh>;
 832     close $fh;
 833
 834     return $data;
 835 }
 836
 837 sub burp {
 838     my $file = shift @_;
 839     open my $fh, ">", $file or croak "can't open $file: $!";
 840     print $fh @_;
 841 }
 842
 843 sub safe_overwrite_file {
 844     my ( $filename, $contents ) = @_;
 845
 846     my $tmpfname = "$filename." . time;
 847     open my $tmpfh, ">", $tmpfname or die "open: $!";
 848
 849     print $tmpfh $contents;
 850     (fsync($tmpfh) == 0) or die "fsync: $!";
 851     return rename $tmpfname, $filename;
 852 }
 853
 854
 855 push @EXPORT_OK, qw(hexencode hexdecode);
 856 push @{$EXPORT_TAGS{"encoding"}}, qw(hexencode hexdecode);
 857
 858 push @EXPORT_OK, qw(quote_string unquote_string skip_quoted_string
 859                 sanitise_filename split_quoted_strings split_quoted_strings_friendly);
 860 push @{$EXPORT_TAGS{"quoting"}}, qw(quote_string unquote_string skip_quoted_string
 861                 sanitise_filename split_quoted_strings split_quoted_strings_friendly);
 862
 863 push @EXPORT_OK, qw(expand_braced_alternates collapse_braced_alternates);
 864 push @{$EXPORT_TAGS{"alternates"}}, qw(expand_braced_alternates collapse_braced_alternates);
 865
 866
 867 sub generate_timestamp {
 868     # this corresponds to common-src/timestamp.c's get_proper_stamp_from_time
 869     if (getconf($CNF_USETIMESTAMPS)) {
 870         return strftime "%Y%m%d%H%M%S", localtime;
 871     } else {
 872         return strftime "%Y%m%d", localtime;
 873     }
 874 }
 875
 876 sub built_with_component {
 877     my ($component) = @_;
 878     my @components = split / +/, $Amanda::Constants::AMANDA_COMPONENTS;
 879     return grep { $_ eq $component } @components;
 880 }
 881
 882
 883
 884 sub is_pid_alive {
 885     my ($pid) = shift;
 886
 887     return 1 if $pid == $$;
 888
 889     my $Amanda_process = Amanda::Process->new(0);
 890
 891     $Amanda_process->load_ps_table();
 892     my $alive = $Amanda_process->process_alive($pid);
 893     return $alive;
 894
 895 }
 896
 897 push @EXPORT_OK, qw(weaken_ref);
 898
 899 push @EXPORT_OK, qw(stream_server stream_accept check_security);
 900
 901 push @EXPORT_OK, qw($AF_INET $STREAM_BUFSIZE);
 902 push @{$EXPORT_TAGS{"constants"}}, qw($AF_INET $STREAM_BUFSIZE);
 903
 904
 905 # these functions were verified to work similarly to those in
 906 # common-src/tapelist.c - they pass the same tests, at least.
 907
 908 sub marshal_tapespec {
 909     my ($filelist) = @_;
 910     my @filelist = @$filelist; # make a copy we can wreck
 911     my @specs;
 912
 913     while (@filelist) {
 914         my $label = shift @filelist;
 915         my $files = shift @filelist;
 916
 917         $label =~ s/([\\:;,])/\\$1/g;
 918         push @specs, "$label:" . join(",", @$files);
 919     }
 920     return join(";", @specs);
 921 }
 922
 923 sub unmarshal_tapespec {
 924     my ($tapespec) = @_;
 925     my @filelist;
 926
 927     # detect a non-tapespec string for special handling; in particular, a string
 928     # without an unquoted : followed by digits and commas at the end.  The easiest
 929     # way to do this is to replace every quoted character with a dummy, then look
 930     # for the colon and digits.
 931     my $tmp = $tapespec;
 932     $tmp =~ s/\\([\\:;,])/X/g;
 933     if ($tmp !~ /:[,\d]+$/) {
 934         # ok, it doesn't end with the right form, so unquote it and return it
 935         # with filenum 0
 936         $tapespec =~ s/\\([\\:;,])/$1/g;
 937         return [ $tapespec, [ 0 ] ];
 938     }
 939
 940     # use a lookbehind to mask out any quoted ;'s
 941     my @volumes = split(/(?<!\\);/, $tapespec);
 942     for my $vol (@volumes) {
 943         my ($label, $files) = ($vol =~ /(.+):([\d,]+)/);
 944
 945         $label =~ s/\\([\\:;,])/$1/g;
 946         push @filelist, $label;
 947
 948         my @files = split(/,/, $files);
 949         @files = map { $_+0 } @files;
 950         @files = sort { $a <=> $b } @files;
 951         push @filelist, \@files;
 952     }
 953
 954     return \@filelist;
 955 }
 956
 957
 958 sub check_std_fds {
 959     fcntl(STDIN, F_GETFD, 0) or critical("Standard input is not open");
 960     fcntl(STDOUT, F_GETFD, 0) or critical("Standard output is not open");
 961     fcntl(STDERR, F_GETFD, 0) or critical("Standard error is not open");
 962 }
 963
 964 1;