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