1# Apache::ConfigParser: Load Apache configuration file. 2# 3# Copyright (C) 2001-2005 Blair Zajac. All rights reserved. 4 5package Apache::ConfigParser; 6 7require 5.004_05; 8 9use strict; 10 11=head1 NAME 12 13Apache::ConfigParser - Load Apache configuration files 14 15=head1 SYNOPSIS 16 17 use Apache::ConfigParser; 18 19 # Create a new empty parser. 20 my $c1 = Apache::ConfigParser->new; 21 22 # Load an Apache configuration file. 23 my $rc = $c1->parse_file('/etc/httpd/conf/httpd.conf'); 24 25 # If there is an error in parsing the configuration file, then $rc 26 # will be false and an error string will be available. 27 if (not $rc) { 28 print $c1->errstr, "\n"; 29 } 30 31 # Get the root of a tree that represents the configuration file. 32 # This is an Apache::ConfigParser::Directive object. 33 my $root = $c1->root; 34 35 # Get all of the directives and starting of context's. 36 my @directives = $root->daughters; 37 38 # Get the first directive's name. 39 my $d_name = $directives[0]->name; 40 41 # This directive appeared in this file, which may be in an Include'd 42 # or IncludeOptional'd file. 43 my $d_filename = $directives[0]->filename; 44 45 # And it begins on this line number. 46 my $d_line_number = $directives[0]->line_number; 47 48 # Find all the CustomLog entries, regardless of context. 49 my @custom_logs = $c1->find_down_directive_names('CustomLog'); 50 51 # Get the first CustomLog. 52 my $custom_log = $custom_logs[0]; 53 54 # Get the value in string form. 55 $custom_log_args = $custom_log->value; 56 57 # Get the value in array form already split. 58 my @custom_log_args = $custom_log->get_value_array; 59 60 # Get the same array but a reference to it. 61 my $customer_log_args = $custom_log->value_array_ref; 62 63 # The first value in a CustomLog is the filename of the log. 64 my $custom_log_file = $custom_log_args->[0]; 65 66 # Get the original value before the path has been made absolute. 67 @custom_log_args = $custom_log->get_orig_value_array; 68 $customer_log_file = $custom_log_args[0]; 69 70 # Here is a more complete example to load an httpd.conf file and add 71 # a new VirtualHost directive to it. 72 # 73 # The Apache::ConfigParser object contains a reference to a 74 # Apache::ConfigParser::Directive object, which can be obtained by 75 # using Apache::ConfigParser->root. The root node is a 76 # Apache::ConfigParser::Directive which ISA Tree::DAG_Node (that is 77 # Apache::ConfigParser::Directive's @ISA contains Tree::DAG_Node). 78 # So to get the root node and add a new directive to it, it could be 79 # done like this: 80 81 my $c = Apache::ConfigParser->new; 82 my $rc = $c->parse_file('/etc/httpd.conf'); 83 my $root = $c->root; 84 my $new_virtual_host = $root->new_daughter; 85 $new_virtual_host->name('VirtualHost'); 86 $new_virtual_host->value('*'); 87 88 # The VirtualHost is called a "context" that contains other 89 # Apache::ConfigParser::Directive's: 90 91 my $server_name = $new_virtual_host->new_daughter; 92 $server_name->name('ServerName'); 93 $server_name->value('my.hostname.com'); 94 95=head1 DESCRIPTION 96 97The C<Apache::ConfigParser> module is used to load an Apache 98configuration file to allow programs to determine Apache's 99configuration directives and contexts. The resulting object contains 100a tree based structure using the C<Apache::ConfigParser::Directive> 101class, which is a subclass of C<Tree::DAG_node>, so all of the methods 102that enable tree based searches and modifications from 103C<Tree::DAG_Node> are also available. The tree structure is used to 104represent the ability to nest sections, such as <VirtualHost>, 105<Directory>, etc. 106 107Apache does a great job of checking Apache configuration files for 108errors and this modules leaves most of that to Apache. This module 109does minimal configuration file checking. The module currently checks 110for: 111 112=over 4 113 114=item Start and end context names match 115 116The module checks if the start and end context names match. If the 117end context name does not match the start context name, then it is 118ignored. The module does not even check if the configuration contexts 119have valid names. 120 121=back 122 123=head1 PARSING 124 125Notes regarding parsing of configuration files. 126 127Line continuation is treated exactly as Apache 1.3.20. Line 128continuation occurs only when the line ends in [^\\]\\\r?\n. If the 129line ends in two \'s, then it will replace the two \'s with one \ and 130not continue the line. 131 132=cut 133 134use Exporter; 135use Carp; 136use Symbol; 137use File::FnMatch 0.01 qw(fnmatch); 138use File::Spec 0.82; 139use Apache::ConfigParser::Directive qw(DEV_NULL 140 %directive_value_path_element_pos); 141 142use vars qw(@ISA $VERSION); 143@ISA = qw(Exporter); 144$VERSION = '1.02'; 145 146# This constant is used throughout the module. 147my $INCORRECT_NUMBER_OF_ARGS = "passed incorrect number of arguments.\n"; 148 149# Determine if the filenames are case sensitive. 150use constant CASE_SENSITIVE_PATH => (! File::Spec->case_tolerant); 151 152=head1 METHODS 153 154The following methods are available: 155 156=over 4 157 158=item $c = Apache::ConfigParser->new 159 160=item $c = Apache::ConfigParser->new({options}) 161 162Create a new C<Apache::ConfigParser> object that stores the content of 163an Apache configuration file. The first optional argument is a 164reference to a hash that contains options to new. 165 166The currently recognized options are: 167 168=over 4 169 170=item pre_transform_path_sub => sub { } 171 172=item pre_transform_path_sub => [sub { }, @args] 173 174This allows the file or directory name for any directive that takes 175either a filename or directory name to be transformed by an arbitrary 176subroutine before it is made absolute with ServerRoot. This 177transformation is applied to any of the directives that appear in 178C<%Apache::ConfigParser::Directive::directive_value_takes_path> that 179have a filename or directory value instead of a pipe or syslog value, 180i.e. "| cronolog" or "syslog:warning". 181 182If the second form of C<pre_transform_path_sub> is used with an array 183reference, then the first element of the array reference must be a 184subroutine reference followed by zero or more arbitrary arguments. 185Any array elements following the subroutine reference are passed to 186the specified subroutine. 187 188The subroutine is passed the following arguments: 189 190 Apache::ConfigParser object 191 lowercase string of the configuration directive 192 the file or directory name to transform 193 @args 194 195NOTE: Be careful, because this subroutine will be applied to 196ServerRoot and DocumentRoot, among other directives. See 197L<Apache::ConfigParser::Directive> for the complete list of directives 198that C<pre_transform_path_sub> is applied to. If you do not want the 199transformation applied to any specific directives, make sure to check 200the directive name and if you do not want to modify the filename, 201return the subroutine's third argument. 202 203If the subroutine returns an undefined value or a value with 0 length, 204then it is replaced with C<< File::Spec->devnull >> which is the 205appropriate 0 length file for the operating system. This is done to 206keep a value in the directive name since otherwise the directive may 207not work properly. For example, with the input 208 209 CustomLog logs/access_log combined 210 211and if C<pre_transform_path_sub> were to replace 'logs/access_log' 212with '', then 213 214 CustomLog combined 215 216would no longer be a valid directive. Instead, 217 218 CustomLog C<File::Spec->devnull> combined 219 220would be appropriate for all systems. 221 222=item post_transform_path_sub => sub { } 223 224=item post_transform_path_sub => [sub { }, @args] 225 226This allows the file or directory name for any directive that takes 227either a filename or directory name to be transformed by this 228subroutine after it is made absolute with ServerRoot. This 229transformation is applied to any of the directives that appear in 230C<%Apache::ConfigParser::Directive::directive_value_takes_path> that 231have a filename or directory value instead of a pipe or syslog value, 232i.e. "| cronolog" or "syslog:warning". 233 234If the second form of C<post_transform_path_sub> is used with an array 235reference, then the first element of the array reference must be a 236subroutine reference followed by zero or more arbitrary arguments. 237Any array elements following the subroutine reference are passed to 238the specified subroutine. 239 240The subroutine is passed the following arguments: 241 242 Apache::ConfigParser object 243 lowercase version of the configuration directive 244 the file or directory name to transform 245 @args 246 247NOTE: Be careful, because this subroutine will be applied to 248ServerRoot and DocumentRoot, among other directives. See 249L<Apache::ConfigParser::Directive> for the complete list of directives 250that C<post_transform_path_sub> is applied to. If you do not want the 251transformation applied to any specific directives, make sure to check 252the directive name and if you do not want to modify the filename, 253return the subroutine's third argument. 254 255If the subroutine returns an undefined value or a value with 0 length, 256then it is replaced with C<< File::Spec->devnull >> which is the 257appropriate 0 length file for the operating system. This is done to 258keep a value in the directive name since otherwise the directive may 259not work properly. For example, with the input 260 261 CustomLog logs/access_log combined 262 263and if C<post_transform_path_sub> were to replace 'logs/access_log' 264with '', then 265 266 CustomLog combined 267 268would no longer be a valid directive. Instead, 269 270 CustomLog C<File::Spec->devnull> combined 271 272would be appropriate for all systems. 273 274=back 275 276One example of where the transformations is useful is when the Apache 277configuration directory on one host is NFS exported to another host 278and the remote host parses the configuration file using 279C<Apache::ConfigParser> and the paths to the access logs must be 280transformed so that the remote host can properly find them. 281 282=cut 283 284sub new { 285 unless (@_ < 3) { 286 confess "$0: Apache::ConfigParser::new $INCORRECT_NUMBER_OF_ARGS"; 287 } 288 289 my $class = shift; 290 $class = ref($class) || $class; 291 292 # This is the root of the tree that holds all of the directives and 293 # contexts in the Apache configuration file. Also keep track of the 294 # current node in the tree so that when options are parsed the code 295 # knows the context to insert them. 296 my $root = Apache::ConfigParser::Directive->new; 297 $root->name('root'); 298 299 my $self = bless { 300 current_node => $root, 301 root => $root, 302 server_root => '', 303 post_transform_path_sub => '', 304 pre_transform_path_sub => '', 305 errstr => '', 306 }, $class; 307 308 return $self unless @_; 309 310 my $options = shift; 311 unless (defined $options and UNIVERSAL::isa($options, 'HASH')) { 312 confess "$0: Apache::ConfigParser::new not passed a HASH reference as ", 313 "its first argument.\n"; 314 } 315 316 foreach my $opt_name (qw(pre_transform_path_sub post_transform_path_sub)) { 317 if (my $opt_value = $options->{$opt_name}) { 318 if (UNIVERSAL::isa($opt_value, 'CODE')) { 319 $self->{$opt_name} = [$opt_value]; 320 } elsif (UNIVERSAL::isa($opt_value, 'ARRAY')) { 321 if (@$opt_value and UNIVERSAL::isa($opt_value->[0], 'CODE')) { 322 $self->{$opt_name} = $opt_value; 323 } else { 324 confess "$0: Apache::ConfigParser::new passed an ARRAY reference ", 325 "whose first element is not a CODE ref for '$opt_name'.\n"; 326 } 327 } else { 328 warn "$0: Apache::ConfigParser::new not passed an ARRAY or CODE ", 329 "reference for '$opt_name'.\n"; 330 } 331 } 332 } 333 334 return $self; 335} 336 337=item $c->DESTROY 338 339There is an explicit DESTROY method for this class to destroy the 340tree, since it has cyclical references. 341 342=cut 343 344sub DESTROY { 345 $_[0]->{root}->delete_tree; 346} 347 348# Apache 1.3.27 and 2.0.41 check if the AccessConfig, Include or 349# ResourceConfig directives' value contains a glob. Duplicate the 350# exact same check here. 351sub path_has_apache_style_glob { 352 unless (@_ == 1) { 353 confess "$0: Apache::ConfigParser::path_has_apache_style_glob ", 354 $INCORRECT_NUMBER_OF_ARGS; 355 } 356 357 my $path = shift; 358 359 # Apache 2.0.53 skips any \ protected characters in the path and 360 # then tests if the path is a glob by looking for ? or * characters 361 # or a [ ] pair. 362 $path =~ s/\\.//g; 363 364 return $path =~ /[?*]/ || $path =~ /\[.*\]/; 365} 366 367# Handle the AccessConfig, Include, IncludeOptional or ResourceConfig 368# directives. Support the Apache 1.3.13 behavior where if the path is 369# a directory then Apache will recursively load all of the files in 370# that directory. Support the Apache 1.3.27 and 2.0.41 behavior where 371# if the path contains any glob characters, then load the files and 372# directories recursively that match the glob. 373sub _handle_include_directive { 374 unless (@_ == 5) { 375 confess "$0: Apache::ConfigParser::_handle_include_directive ", 376 $INCORRECT_NUMBER_OF_ARGS; 377 } 378 379 my ($self, $file_or_dir_name, $line_number, $directive, $path) = @_; 380 381 # Apache 2.0.53 tests if the path is a glob and does a glob search 382 # if it is. Otherwise, it treats the path as a file or directory 383 # and opens it directly. 384 my @paths; 385 if (path_has_apache_style_glob($path)) { 386 # Apache splits the path into the dirname and basename portions 387 # and then checks that the dirname is not a glob and the basename 388 # is. It then matches the files in the dirname against the glob 389 # in the basename and generates a list from that. Duplicate this 390 # code here. 391 my ($dirname, 392 $separator, 393 $basename) = $path =~ m#(.*)([/\\])+([^\2]*)$#; 394 unless (defined $separator and length $separator) { 395 $self->{errstr} = "'$file_or_dir_name' line $line_number " . 396 "'$directive $path': cannot split path into " . 397 "dirname and basename"; 398 return; 399 } 400 if (path_has_apache_style_glob($dirname)) { 401 $self->{errstr} = "'$file_or_dir_name' line $line_number " . 402 "'$directive $path': dirname '$dirname' is a glob"; 403 return; 404 } 405 unless (path_has_apache_style_glob($basename)) { 406 $self->{errstr} = "'$file_or_dir_name' line $line_number " . 407 "'$directive $path': basename '$basename' is " . 408 "not a glob"; 409 return; 410 } 411 unless (opendir(DIR, $dirname)) { 412 $self->{errstr} = "'$file_or_dir_name' line $line_number " . 413 "'$directive $path': opendir '$dirname' " . 414 "failed: $!"; 415 # Check if missing file or directory errors should be ignored. 416 # This checks an undocumented object variable which is normally 417 # only used by the test suite to test the normal aspects of all 418 # the directives without worrying about a missing file or 419 # directory halting the tests early. 420 if ($self->{_include_file_ignore_missing_file}) { 421 # If the directory cannot be opened, then there are no 422 # configuration files that could be opened for the directive, 423 # so leave the method now, but with a successful return code. 424 return 1; 425 } else { 426 return; 427 } 428 } 429 430 # The glob code Apache uses is fnmatch(3). 431 foreach my $n (sort readdir(DIR)) { 432 next if $n eq '.'; 433 next if $n eq '..'; 434 if (fnmatch($basename, $n)) { 435 push(@paths, "$dirname/$n"); 436 } 437 } 438 unless (closedir(DIR)) { 439 $self->{errstr} = "'$file_or_dir_name' line $line_number " . 440 "'$directive $path': closedir '$dirname' " . 441 "failed: $!"; 442 return; 443 } 444 } else { 445 @paths = ($path); 446 } 447 448 foreach my $p (@paths) { 449 my @stat = stat($p); 450 unless (@stat) { 451 $self->{errstr} = "'$file_or_dir_name' line $line_number " . 452 "'$directive $path': stat of '$path' failed: $!"; 453 # Check if missing file or directory errors should be ignored. 454 # This checks an undocumented object variable which is normally 455 # only used by the test suite to test the normal aspects of all 456 # the directives without worrying about a missing file or 457 # directory halting the tests early. 458 if ($self->{_include_file_ignore_missing_file}) { 459 next; 460 } else { 461 return; 462 } 463 } 464 465 # Parse this if it is a directory or points to a file. 466 if (-d _ or -f _) { 467 unless ($self->parse_file($p)) { 468 return; 469 } 470 } else { 471 $self->{errstr} = "'$file_or_dir_name' line $line_number " . 472 "'$directive $path': cannot open non-file and " . 473 "non-directory '$p'"; 474 return; 475 } 476 } 477 478 return 1; 479} 480 481=item $c->parse_file($filename) 482 483This method takes a filename and adds it to the already loaded 484configuration file inside the object. If a previous Apache 485configuration file was loaded either with new or parse_file and the 486configuration file did not close all of its contexts, such as 487<VirtualHost>, then the new configuration directives and contexts in 488C<$filename> will be added to the existing context. 489 490If there is a failure in parsing any portion of the configuration 491file, then this method returns undef and C<< $c->errstr >> will contain a 492string explaining the error. 493 494=cut 495 496sub parse_file { 497 unless (@_ == 2) { 498 confess "$0: Apache::ConfigParser::parse_file $INCORRECT_NUMBER_OF_ARGS"; 499 } 500 501 my ($self, $file_or_dir_name) = @_; 502 503 my @stat = stat($file_or_dir_name); 504 unless (@stat) { 505 $self->{errstr} = "cannot stat '$file_or_dir_name': $!"; 506 return; 507 } 508 509 # If this is a real directory, than descend into it now. 510 if (-d _) { 511 unless (opendir(DIR, $file_or_dir_name)) { 512 $self->{errstr} = "cannot opendir '$file_or_dir_name': $!"; 513 return; 514 } 515 my @entries = sort grep { $_ !~ /^\.{1,2}$/ } readdir(DIR); 516 unless (closedir(DIR)) { 517 $self->{errstr} = "closedir '$file_or_dir_name' failed: $!"; 518 return; 519 } 520 521 my $ok = 1; 522 foreach my $entry (@entries) { 523 $ok = $self->parse_file("$file_or_dir_name/$entry") && $ok; 524 next; 525 } 526 527 if ($ok) { 528 return $self; 529 } else { 530 return; 531 } 532 } 533 534 # Create a new file handle to open this file and open it. 535 my $fd = gensym; 536 unless (open($fd, $file_or_dir_name)) { 537 $self->{errstr} = "cannot open '$file_or_dir_name' for reading: $!"; 538 return; 539 } 540 541 # Change the mode to binary to mode to handle the line continuation 542 # match [^\\]\\[\r]\n. Since binary files may be copied from 543 # Windows to Unix, look for this exact match instead of relying upon 544 # the operating system to convert \r\n to \n. 545 binmode($fd); 546 547 # This holds the contents of any previous lines that are continued 548 # using \ at the end of the line. Also keep track of the line 549 # number starting a continued line for warnings. 550 my $continued_line = ''; 551 my $line_number = undef; 552 553 # Scan the configuration file. Use the file format specified at 554 # 555 # http://httpd.apache.org/docs/configuring.html#syntax 556 # 557 # In addition, use the semantics from the function ap_cfg_getline 558 # in util.c 559 # 1) Leading whitespace is first skipped. 560 # 2) Configuration files are then parsed for line continuation. The 561 # line continuation is [^\\]\\[\r]\n. 562 # 3) If a line continues onto the next line then the line is not 563 # scanned for comments, the comment becomes part of the 564 # continuation. 565 # 4) Leading and trailing whitespace is compressed to a single 566 # space, but internal space is preserved. 567 while (<$fd>) { 568 # Apache is not consistent in removing leading whitespace 569 # depending upon the particular method in getting characters from 570 # the configuration file. Remove all leading whitespace. 571 s/^\s+//; 572 573 next unless length $_; 574 575 # Handle line continuation. In the case where there is only one \ 576 # character followed by the end of line character(s), then the \ 577 # needs to be removed. In the case where there are two \ 578 # characters followed by the end of line character(s), then the 579 # two \'s need to be replaced by one. 580 if (s#(\\)?\\\r?\n$##) { 581 if ($1) { 582 $_ .= $1; 583 } else { 584 # The line is being continued. If this is the first line to 585 # be continued, then note the starting line number. 586 unless (length $continued_line) { 587 $line_number = $.; 588 } 589 $continued_line .= $_; 590 next; 591 } 592 } else { 593 # Remove the end of line characters. 594 s#\r?\n$##; 595 } 596 597 # Concatenate the continuation lines with this line. Only update 598 # the line number if the lines are not continued. 599 if (length $continued_line) { 600 $_ = "$continued_line $_"; 601 $continued_line = ''; 602 } else { 603 $line_number = $.; 604 } 605 606 # Collapse any ending whitespace to a single space. 607 s#\s+$# #; 608 609 # If the line begins with a #, then skip the line. 610 if (substr($_, 0, 1) eq '#') { 611 next; 612 } 613 614 # If there is nothing on the line, then skip it. 615 next unless length $_; 616 617 # If the line begins with </, then it is ending a context. 618 if (my ($context) = $_ =~ m#^<\s*/\s*([^\s>]+)\s*>\s*$#) { 619 # Check if an end context was seen with no start context in the 620 # configuration file. 621 my $mother = $self->{current_node}->mother; 622 unless (defined $mother) { 623 $self->{errstr} = "'$file_or_dir_name' line $line_number closes " . 624 "context '$context' which was never started"; 625 return; 626 } 627 628 # Check that the start and end contexts have the same name. 629 $context = lc($context); 630 my $start_context_name = $self->{current_node}->name; 631 unless ($start_context_name eq $context) { 632 $self->{errstr} = "'$file_or_dir_name' line $line_number closes " . 633 "context '$context' that should close context " . 634 "'$start_context_name'"; 635 return; 636 } 637 638 # Move the current node up to the mother node. 639 $self->{current_node} = $mother; 640 641 next; 642 } 643 644 # At this point a new directive or context node will be created. 645 my $new_node = $self->{current_node}->new_daughter; 646 $new_node->filename($file_or_dir_name); 647 $new_node->line_number($line_number); 648 649 # If the line begins with <, then it is starting a context. 650 if (my ($context, $value) = $_ =~ m#^<\s*(\S+)\s+(.*)>\s*$#) { 651 $context = lc($context); 652 653 # Remove any trailing whitespace in the context's value as the 654 # above regular expression will match all after the context's 655 # name to the >. Do not modify any internal whitespace. 656 $value =~ s/\s+$//; 657 658 $new_node->name($context); 659 $new_node->value($value); 660 $new_node->orig_value($value); 661 662 # Set the current node to the new context. 663 $self->{current_node} = $new_node; 664 665 next; 666 } 667 668 # Anything else at this point is a normal directive. Split the 669 # line into the directive name and a value. Make sure not to 670 # collapse any whitespace in the value. 671 my ($directive, $value) = $_ =~ /^(\S+)(?:\s+(.*))?$/; 672 $directive = lc($directive); 673 674 $new_node->name($directive); 675 $new_node->value($value); 676 $new_node->orig_value($value); 677 678 # If there is no value for the directive, then move on. 679 unless (defined $value and length $value) { 680 next; 681 } 682 683 my @values = $new_node->get_value_array; 684 685 # Go through all of the value array elements for those elements 686 # that are paths that need to be optionally pre-transformed, then 687 # made absolute using ServerRoot and then optionally 688 # post-transformed. 689 my $value_path_index = $directive_value_path_element_pos{$directive}; 690 my @value_path_indexes; 691 if (defined $value_path_index and $value_path_index =~ /^-?\d+$/) { 692 if (substr($value_path_index, 0, 1) eq '-') { 693 @value_path_indexes = (abs($value_path_index) .. $#values); 694 } else { 695 @value_path_indexes = ($value_path_index); 696 } 697 } 698 699 for my $i (@value_path_indexes) { 700 # If this directive takes a path argument, then make sure the path 701 # is absolute. 702 if ($new_node->value_is_path($i)) { 703 # If the path needs to be pre transformed, then do that now. 704 if (my $pre_transform_path_sub = $self->{pre_transform_path_sub}) { 705 my ($sub, @args) = @$pre_transform_path_sub; 706 my $new_path = &$sub($self, $directive, $values[$i], @args); 707 if (defined $new_path and length $new_path) { 708 $values[$i] = $new_path; 709 } else { 710 $values[$i] = DEV_NULL; 711 } 712 $new_node->set_value_array(@values); 713 } 714 715 # Determine if the file or directory path needs to have the 716 # ServerRoot prepended to it. First check if the ServerRoot 717 # has been set then check if the file or directory path is 718 # relative for this operating system. 719 my $server_root = $self->{server_root}; 720 if (defined $server_root and 721 length $server_root and 722 $new_node->value_is_rel_path) { 723 $values[$i] = "$server_root/$values[$i]"; 724 $new_node->set_value_array(@values); 725 } 726 727 # If the path needs to be post transformed, then do that now. 728 if (my $post_transform_path_sub = $self->{post_transform_path_sub}) { 729 my ($sub, @args) = @$post_transform_path_sub; 730 my $new_path = &$sub($self, $directive, $values[$i], @args); 731 if (defined $new_path and length $new_path) { 732 $values[$i] = $new_path; 733 } else { 734 $values[$i] = DEV_NULL; 735 } 736 $new_node->set_value_array(@values); 737 } 738 } 739 } 740 741 # Always set the string value using the value array. This will 742 # normalize all string values by collapsing any whitespace, 743 # protect \'s, etc. 744 $new_node->set_value_array(@values); 745 746 # If this directive is ServerRoot and node is the parent node, 747 # then record it now because it is used to make other relative 748 # pathnames absolute. 749 if ($directive eq 'serverroot' and !$self->{current_node}->mother) { 750 $self->{server_root} = $values[0]; 751 next; 752 } 753 754 # If this directive is AccessConfig, Include, IncludeOptional or 755 # ResourceConfig, then include the indicated file(s) given by the 756 # path. 757 if ($directive eq 'accessconfig' or 758 $directive eq 'include' or 759 $directive eq 'includeoptional' or 760 $directive eq 'resourceconfig') { 761 unless ($new_node->value_is_path) { 762 next; 763 } 764 unless ($self->_handle_include_directive($file_or_dir_name, 765 $line_number, 766 $directive, 767 $values[0])) { 768 return; 769 } 770 } 771 772 next; 773 } 774 775 unless (close($fd)) { 776 $self->{errstr} = "cannot close '$file_or_dir_name' for reading: $!"; 777 return; 778 } 779 780 return $self; 781 782 # At this point check if all of the context have been closed. The 783 # filename that started the context may not be the current file, so 784 # get the filename from the context. 785 my $root = $self->{root}; 786 while ($self->{current_node} != $root) { 787 my $context_name = $self->{current_node}->name; 788 my $attrs = $self->{current_node}->attributes; 789 my $context_filename = $attrs->{filename}; 790 my $line_number = $attrs->{line_number}; 791 warn "$0: '$context_filename' line $line_number context '$context_name' ", 792 "was never closed.\n"; 793 $self->{current_node} = $self->{current_node}->mother; 794 } 795 796 $self; 797} 798 799=item $c->root 800 801Returns the root of the tree that represents the Apache configuration 802file. Each object here is a C<Apache::ConfigParser::Directive>. 803 804=cut 805 806sub root { 807 $_[0]->{root} 808} 809 810=item $c->find_down_directive_names('directive', ...) 811 812=item $c->find_down_directive_names($node, 'directive', ...) 813 814In list context, returns the list all of C<$c>'s directives that match 815the directive names in C<$node> and C<$node>'s children. In scalar 816context, returns the number of such directives. The level here is in 817a tree sense, not in the sense that some directives appear before or 818after C<$node> in the configuration file. If C<$node> is given, then 819the search searches C<$node> and C<$node>'s children. If C<$node> is 820not passed as an argument, then the search starts at the top of the 821tree and searches the whole configuration file. 822 823The search for matching directive names is done without regards to 824case. 825 826This is useful if you want to find all of the CustomLog's in the 827configuration file: 828 829 my @logs = $c->find_down_directive_names('CustomLog'); 830 831=cut 832 833sub find_down_directive_names { 834 unless (@_ > 1) { 835 confess "$0: Apache::ConfigParser::find_down_directive_names ", 836 $INCORRECT_NUMBER_OF_ARGS; 837 } 838 839 my $self = shift; 840 841 my $start; 842 if (@_ and $_[0] and ref $_[0]) { 843 $start = shift; 844 } else { 845 $start = $self->{root}; 846 } 847 848 return () unless @_; 849 850 my @found; 851 my %names = map { (lc($_), 1) } @_; 852 853 my $callback = sub { 854 my $node = shift; 855 push(@found, $node) if $names{$node->name}; 856 return 1; 857 }; 858 859 $start->walk_down({callback => $callback}); 860 861 @found; 862} 863 864=item $c->find_siblings_directive_names('directive', ...) 865 866=item $c->find_siblings_directive_names($node, 'directive', ...) 867 868In list context, returns the list of all C<$c>'s directives that match 869the directive names at the same level of C<$node>, that is siblings of 870C<$node>. In scalar context, returns the number of such directives. 871The level here is in a tree sense, not in the sense that some 872directives appear above or below C<$node> in the configuration file. 873If C<$node> is passed to the method and it is equal to C<$c-E<gt>tree> 874or if C<$node> is not given, then the method will search through 875root's children. 876 877This method will return C<$node> as one of the matches if C<$node>'s 878directive name is one of the directive names passed to the method. 879 880The search for matching directive names is done without regards to 881case. 882 883=cut 884 885sub find_siblings_directive_names { 886 unless (@_ > 1) { 887 confess "$0: Apache::ConfigParser::find_siblings_directive_names ", 888 $INCORRECT_NUMBER_OF_ARGS; 889 } 890 891 my $self = shift; 892 893 my $start; 894 if (@_ and $_[0] and ref $_[0]) { 895 $start = shift; 896 } else { 897 $start = $self->{root}; 898 } 899 900 return () unless @_; 901 902 # Special case for the root node. If the root node is given, then 903 # search its children. 904 my @siblings; 905 if ($start == $self->{root}) { 906 @siblings = $start->daughters; 907 } else { 908 @siblings = $start->mother->daughters; 909 } 910 911 return @siblings unless @siblings; 912 913 my %names = map { (lc($_), 1) } @_; 914 915 grep { $names{$_->name} } @siblings; 916} 917 918=item $c->find_siblings_and_up_directive_names($node, 'directive', ...) 919 920In list context, returns the list of all C<$c>'s directives that match 921the directive names at the same level of C<$node>, that is siblings of 922C<$node> and above C<$node>. In scalar context, returns the number of 923such directives. The level here is in a tree sense, not in the sense 924that some directives appear before or after C<$node> in the 925configuration file. In this method C<$node> is a required argument 926because it does not make sense to check the root node. If C<$node> 927does not have a parent node, then no siblings will be found. This 928method will return C<$node> as one of the matches if C<$node>'s 929directive name is one of the directive names passed to the method. 930 931The search for matching directive names is done without regards to 932case. 933 934This is useful when you find an directive and you want to find an 935associated directive. For example, find all of the CustomLog's and 936find the associated ServerName. 937 938 foreach my $log_node ($c->find_down_directive_names('CustomLog')) { 939 my $log_filename = $log_node->name; 940 my @server_names = $c->find_siblings_and_up_directive_names($log_node); 941 my $server_name = $server_names[0]; 942 print "ServerName for $log_filename is $server_name\n"; 943 } 944 945=cut 946 947sub find_siblings_and_up_directive_names { 948 unless (@_ > 1) { 949 confess "$0: Apache::ConfigParser::find_siblings_and_up_directive_names ", 950 $INCORRECT_NUMBER_OF_ARGS; 951 } 952 953 my $self = shift; 954 my $node = shift; 955 956 return @_ unless @_; 957 958 my %names = map { (lc($_), 1) } @_; 959 960 my @found; 961 962 # Recursively go through this node's siblings and all of the 963 # siblings of this node's parents. 964 while (my $mother = $node->mother) { 965 push(@found, grep { $names{$_->name} } $mother->daughters); 966 $node = $mother; 967 } 968 969 @found; 970} 971 972=item $c->errstr 973 974Return the error string associated with the last failure of any 975C<Apache::ConfigParser> method. The string returned is not emptied 976when any method calls succeed, so a non-zero length string returned 977does not necessarily mean that the last method call failed. 978 979=cut 980 981sub errstr { 982 unless (@_ == 1) { 983 confess "$0: Apache::ConfigParser::errstr $INCORRECT_NUMBER_OF_ARGS"; 984 } 985 986 my $self = shift; 987 return $self->{errstr}; 988} 989 990=item $c->dump 991 992Return an array of lines that represents the internal state of the 993tree. 994 995=cut 996 997my @dump_ref_count_stack; 998sub dump { 999 @dump_ref_count_stack = (0); 1000 _dump(shift); 1001} 1002 1003sub _dump { 1004 my ($object, $seen_ref, $depth) = @_; 1005 1006 $seen_ref ||= {}; 1007 if (defined $depth) { 1008 ++$depth; 1009 } else { 1010 $depth = 0; 1011 } 1012 1013 my $spaces = ' ' x $depth; 1014 1015 unless (ref $object) { 1016 if (defined $object) { 1017 return ("$spaces '$object'"); 1018 } else { 1019 return ("$spaces UNDEFINED"); 1020 } 1021 } 1022 1023 if (my $r = $seen_ref->{$object}) { 1024 return ("$spaces SEEN $r"); 1025 } 1026 1027 my $type = "$object"; 1028 $type =~ s/\(\w+\)$//; 1029 my $comment = "reference " . 1030 join('-', @dump_ref_count_stack) . 1031 " $type"; 1032 $spaces .= $comment; 1033 $seen_ref->{$object} = $comment; 1034 $dump_ref_count_stack[-1] += 1; 1035 1036 if (UNIVERSAL::isa($object, 'SCALAR')) { 1037 return ("$spaces $$object"); 1038 } elsif (UNIVERSAL::isa($object, 'ARRAY')) { 1039 push(@dump_ref_count_stack, 0); 1040 my @result = ("$spaces with " . scalar @$object . " elements"); 1041 for (my $i=0; $i<@$object; ++$i) { 1042 push(@result, "$spaces index $i", 1043 _dump($object->[$i], $seen_ref, $depth)); 1044 } 1045 pop(@dump_ref_count_stack); 1046 return @result; 1047 } elsif (UNIVERSAL::isa($object, 'HASH')) { 1048 push(@dump_ref_count_stack, 0); 1049 my @result = ("$spaces with " . scalar keys(%$object) . " keys"); 1050 foreach my $key (sort keys %$object) { 1051 push(@result, "$spaces key '$key'", 1052 _dump($object->{$key}, $seen_ref, $depth)); 1053 } 1054 pop(@dump_ref_count_stack); 1055 return @result; 1056 } elsif (UNIVERSAL::isa($object, 'CODE')) { 1057 return ($spaces); 1058 } else { 1059 die "$0: internal error: object of type ", ref($object), " not handled.\n"; 1060 } 1061} 1062 10631; 1064 1065=back 1066 1067=head1 SEE ALSO 1068 1069L<Apache::ConfigParser::Directive> and L<Tree::DAG_Node>. 1070 1071=head1 AUTHOR 1072 1073Blair Zajac <blair@orcaware.com>. 1074 1075=head1 COPYRIGHT 1076 1077Copyright (C) 2001-2005 Blair Zajac. All rights reserved. This 1078program is free software; you can redistribute it and/or modify it 1079under the same terms as Perl itself. 1080