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