File Coverage

blib/lib/Maypole/Plugin/Config/Apache.pm

Criterion	Covered	Total	%
statement	32	54	59.2
branch	16	32	50.0
condition			n/a
subroutine	5	6	83.3
pod	1	1	100.0
total	54	93	58.0

package Maypole::Plugin::Config::Apache;

use warnings;
use strict;

use NEXT;

our $VERSION = '0.21';

=head1 NAME

Maypole::Plugin::Config::Apache - read config settings from httpd.conf

=head1 SYNOPSIS

    use Maypole::Application qw( Config::Apache -Setup );


    # in httpd.conf

    # same as $config->application_name( "The Beer Database" )
    PerlSetVar MaypoleApplicationName "The Beer Database"

    PerlSetVar MaypoleDsn   dbi:mysql:BeerDB
    PerlSetVar MaypoleUser  username
    PerlSetVar MaypolePass  password

    # same as $config->display_tables( [ qw( beer brewery pub style ) ] )
    PerlAddVar MaypoleDisplayTables  beer
    PerlAddVar MaypoleDisplayTables  brewery
    PerlAddVar MaypoleDisplayTables  pub
    PerlAddVar MaypoleDisplayTables  style

    # same as $config->masonx( { data_dir   => '/home/beerdb/www/beerdb/mdata',
    #                            in_package => 'BeerDB::TestApp',
    #                            comp_root  => [ [ factory => '/usr/local/www/maypole/factory' ] ],
    #                            } )
    PerlAddVar MaypoleMasonx "data_dir   => '/home/beerdb/www/beerdb/mdata'"
    PerlAddVar MaypoleMasonx "in_package => 'BeerDB::TestApp'"
    PerlAddVar MaypoleMasonx "comp_root => [ [ factory => '/usr/local/www/maypole/factory' ] ]"

    # set something from arbitrary Perl code
    PerlSetVar MaypoleEvalDisplayTables "[ qw( beer brewery pub style ) ]"

    # merging a hash of hashes -
    #           $config->session( { args => { Directory     => '/tmp/sessions/beerdb',
    #                                         LockDirectory => '/tmp/sessionlocks/beerdb',
    #                                         }
    #                               } )
    PerlAddVar MaypoleSession "args => { Directory     => '/tmp/sessions/beerdb' }"
    PerlAddVar MaypoleSession "args => { LockDirectory => '/tmp/sessionlocks/beerdb' }"


    # merging a hash of arrayrefs involves a nasty hack...
    #           $config->masonx->{comp_root} = [ [ factory => '/usr/local/www/maypole/factory' ],
    #                                            [ library => '/usr/local/www/mason/lib' ],
    #                                            ];
    PerlAddVar MaypoleMasonx "comp_root => [ [ factory => '/usr/local/www/maypole/factory' ] ]"
    PerlAddVar MaypoleMasonx "comp_root =>   [ library => '/usr/local/www/mason/lib' ]"

    # ...more clearly shown here. To build up a hash of arrayrefs, the first value must
    # be an array ref (to set up the value as an arrayref), while subsequent items are scalars
    # and are pushed onto the arrayref:
    #           $config->masonx->{plugins} = [ MasonX::Plugin::Foo->new,
    #                                          MasonX::Plugin::Bar->new,
    #                                          MasonX::Plugin::Baz->new,
    #                                          ];
    PerlAddVar MaypoleMasonx "plugins => [ MasonX::Plugin::Foo->new ]"
    PerlAddVar MaypoleMasonx "plugins =>   MasonX::Plugin::Bar->new"
    PerlAddVar MaypoleMasonx "plugins =>   MasonX::Plugin::Baz->new"



=head1 DESCRIPTION

Anything starting with C or C is taken to be a config setting for Maypole.
Everything after the C or C is the variable name, in StudlyCaps form.

Values from C variables are run through an C, allowing arbitrarily complex
data structures to be set, including coderefs, if anything needed that.

Any value from a C that contains a C<< => >> symbol is also run through an eval, so any
valid perl expression for a hash value can be used.

An attempt is made to intelligently merge hash entries in multiple PerlAddVar statements. Multiple
entries with the same key are merged into a single hashref or arrayref value.

Put C at the front of the Maypole::Application call, so that later plugins
have access to the configuration settings. If your httpd.conf contains all of your Maypole
settings, you can add the C<-Setup> flag, which calls C<< __PACKAGE__->setup >> for you.

=head1 METHODS

=over 4

=item setup

=back

=cut

sub setup
{
    my $r = shift;

    warn "Running " . __PACKAGE__ . " setup for $r" if $r->debug;

    # an Apache::Table object
    my $apache_cfg = Apache->server->dir_config;

    my $config = {};

    foreach my $k ( grep { /^Maypole/ } keys %$apache_cfg )
    {
        my @v = $apache_cfg->get( $k );

        # change from MaypoleVarName into var_name - stolen from HTML::Mason::ApacheHandler::studly_form()
        my $new_k = $k;
        $new_k =~ s/^Maypole//;
        $new_k =~ s/(^|.)([A-Z])/$1 ? "$1\L_$2" : "\L$2"/ge;

        if ( $k =~ /^MaypoleEval/ )
        {
            $config->{ $new_k } = eval $v[0];
            die "Error constructing config value for $k from code: $@" if $@;
        }
        else
        {
            #$config->{ $new_k } = @v > 1 ? _fixup_addvar( $k, @v ) : $v[0];
            $config->{ $new_k } = _fixup( $k, @v );
        }
    }

    if ( $r->debug > 1 )
    {
        Data::Dumper->require || die "Failed to load Data::Dumper for debug output: $@";
        warn "Maypole config from Apache config file: " . Data::Dumper::Dumper( $config );
    }

    Maypole::Config->mk_accessors( keys %$config );

    $r->config( Maypole::Config->new( $config ) );

    $r->NEXT::DISTINCT::setup(@_);
}

sub _fixup
{
    my ( $StudlyVarName, @strings ) = @_;

    # counting '=>' matches would be wrong, because each string could have > 1
    my @got_hash_sep = grep { /=>/ } @strings;

    return @strings == 1 ? $strings[0] : [ @strings ] unless @got_hash_sep;

    die "'=>' present in some but not all values of $StudlyVarName" if @got_hash_sep ne @strings;

    my %hash;

    my $merge = sub
    {
        my ( $str ) =  @_;
        my ( $k, @v ) = eval $str;
        die "Error extracting value for $StudlyVarName: $@" if $@;
        if ( exists $hash{ $k } )
        {
            if ( my $type = ref $hash{ $k } )
            {
                if ( $type eq 'ARRAY' )
                {
                    push @{ $hash{ $k } }, @v;
                }
                elsif ( $type eq 'HASH' )
                {
                    my %v = @v == 1 ? %{ $v[0] } : @v;
                    %{ $hash{ $k } } = ( %{ $hash{ $k } }, %v );
                }
            }
            else
            {
                # The key already holds a plain scalar value.
                # Convert it to an arrayref.
                $hash{ $k } = [ $hash{ $k }, @v ];
            }
        }
        else
        {
            #$hash{ $k } = [];
            #push @{ $hash{ $k } }, @v;
            $hash{ $k } = @v > 1 ? [ @v ] : $v[0];
        }
    };

    $merge->( $_ ) for @strings;

    return \%hash;
}

=head1 EXAMPLE

With all the config moved to C, the actual driver is reduced to a few lines of code.
Why not inline that in C too?



        ServerName beerdb.riverside-cms.co.uk
        ServerAdmin [e-mail]

        DocumentRoot /home/beerdb/www/beerdb/htdocs

        #
        # Set up Maypole via Maypole::Plugin::Config::Apache
        #
        PerlSetVar MaypoleApplicationName "The Beer Database"
        PerlSetVar MaypoleUriBase         /beerdb
        PerlSetVar MaypoleTemplateRoot    /home/beerdb/www/beerdb/htdocs
        PerlSetVar MaypoleRowsPerPage     10

        PerlSetVar MaypoleDsn             "dbi:mysql:BeerDB"
        PerlSetVar MaypoleUser            username
        PerlSetVar MaypolePass            password

        PerlAddVar MaypoleDisplayTables  beer
        PerlAddVar MaypoleDisplayTables  brewery
        PerlAddVar MaypoleDisplayTables  pub
        PerlAddVar MaypoleDisplayTables  style

        PerlAddVar MaypoleMasonx "comp_root  => [ [ factory => '/usr/local/www/maypole/factory' ] ]"
        PerlAddVar MaypoleMasonx "data_dir   => '/home/beerdb/www/beerdb/mdata'"
        PerlAddVar MaypoleMasonx "in_package => 'BeerDB::TestApp'"

        PerlAddVar MaypoleRelationships     "a brewery produces beers"
        PerlAddVar MaypoleRelationships     "a style defines beers"
        PerlAddVar MaypoleRelationships     "a pub has beers on handpumps"


            Allow from all
            AllowOverride none
            Order allow,deny


            {
                package BeerDB;
                use Maypole::Application qw( Config::Apache MasonX AutoUntaint Relationship -Setup -Debug2 );
                BeerDB->auto_untaint;
                BeerDB->init;
            }


            SetHandler perl-script
            PerlHandler BeerDB


        CustomLog /home/beerdb/www/beerdb/logs/access.log combined env=log
        ErrorLog  /home/beerdb/www/beerdb/logs/error.log



Watch out for the chicken and the egg. The C section defining the C package must
come after all the Maypole config settings (or else the settings won't yet exist when BeerDB
tries to read them), but before the C directive (because the package needs
to exist by then).

=head1 AUTHOR

David Baird, C<<  >>

=head1 BUGS

Won't work for config variables with capital letters in them.

Strange things will happen to anything containing '=>' that should not be interpreted as a hash entry.

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2005 David Baird, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Maypole::Plugin::Config::Apache