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