view release on metacpan or  search on metacpan

lib/Apache/PageKit/Config.pm  view on Meta::CPAN

}

# checks to see if we have config data and is up to date, otherwise, load/reload
sub reload {
  my ($config) = @_;
  my $config_dir = $config->{config_dir};
  my $mtime = (stat "$config_dir/Config.xml")[9];
  unless(exists $mtime_hashref->{$config_dir} &&
	$mtime < $mtime_hashref->{$config_dir}){
    $config->parse_xml;
    $mtime_hashref->{$config_dir} = $mtime;
  }
}

sub parse_xml {
  my ($config) = @_;

  # set global variable so that XML::Parser's handlers can see it
  $cur_config = $config;

  # delete current init
  my $config_dir  = $config->{config_dir};
  $section_attr->{$config_dir} = {};
  $server_attr->{$config_dir}  = {};
  $global_attr->{$config_dir}  = {};
  $page_attr->{$config_dir}    = {};
  $user_attr->{$config_dir}    = {};
  $view_attr->{$config_dir}    = {};
  $uri_match->{$config_dir}    = {};

  my $parser = XML::LibXML->new;

  # this open close hack is needed. oherwise XML::LibXML sometimes likes to open with the
  # handlers we set in Content.pm! So we use parse_fh instead of parse_file.
  open CFH, "<$config_dir/Config.xml" or die $!;
  binmode CFH;
  my $dom  = $parser->parse_fh(\*CFH);
  close CFH;

  my $root = $dom->getDocumentElement;

  #search for the following nodes ...
  my %subs = (
    GLOBAL             => \&GLOBAL,
    USER               => \&USER,
    'SERVERS/SERVER'   => \&SERVER,
    'VIEWS/VIEW'       => \&VIEW,
    'PAGES/PAGE'       => \&PAGE,
    'SECTIONS/SECTION' => \&SECTION
  );

  for my $tag ( keys %subs ) {
    for my $node ( $root->findnodes("/CONFIG/$tag") ) {
      $subs{$tag}($node);
    }
  }

  # allow login at least on these pages
  for my $page_id ( grep { $_ } ( $config->get_global_attr('default_page') || 'index',
                                  $config->get_global_attr('login_page'),
                                  $config->get_global_attr('verify_page'))) {
    $page_attr->{$config_dir}->{$page_id}->{require_login} = 'no';
  }

  # remove leading or trailing /'s (if any)
  for ( $global_attr->{$config_dir}->{'uri_prefix'} ) {
    next unless $_;
    s!/+$!!;
    s!^/+!!;
  }
}

sub get_global_attr {
  my ($config, $key) = @_;
  return $global_attr->{$config->{config_dir}}->{$key};
}

sub get_user_attr {
  my ($config, $key) = @_;
  return $user_attr->{$config->{config_dir}}->{$key};
}

sub get_server_attr {
  my ($config, $key) = @_;
  return $server_attr->{$config->{config_dir}}->{$config->{server}}->{$key};
}

sub get_view_attr {
  my ($config, $view_id, $key) = @_;
  return $view_attr->{$config->{config_dir}}->{$view_id}->{$key};
}

# required page_id paramater
sub get_page_attr {
  my ($config, $page_id, $key) = @_;
  my $config_dir = $config->{config_dir};

  if ( exists $page_attr->{$config_dir}->{$page_id} 
        && $page_attr->{$config_dir}->{$page_id}->{$key} ) {
    return $page_attr->{$config_dir}->{$page_id}->{$key};
  }

  # here page_id IS the section_id
  while ( $page_id =~ s!^(.*)/+[^/]*$!$1! ) {
    if ( exists $section_attr->{$config_dir}->{$page_id} ) {
      return $section_attr->{$config_dir}->{$page_id}->{$key};
    }
  }

  # test for a global default in the section '/' or ''
  return $section_attr->{$config_dir}->{''}->{$key};
}


# required section_id paramater
sub get_section_attr {
  my ($config, $section_id, $key) = @_;

  return unless exists $section_attr->{$config->{config_dir}}->{$section_id};
  return $section_attr->{$config->{config_dir}}->{$section_id}->{$key};
}