File Coverage

blib/lib/Bigtop/Backend/HttpdConf/Gantry.pm

Criterion	Covered	Total	%
statement	66	274	24.0
branch	0	62	0.0
condition	0	36	0.0
subroutine	22	42	52.3
pod	5	5	100.0
total	93	419	22.2

package Bigtop::Backend::HttpdConf::Gantry;

use strict;

use Bigtop::Backend::HttpdConf;
use Bigtop;
use Inline;

sub what_do_you_make {
    return [
        [ 'docs/httpd.conf' => 'Include file for mod_perl apache conf' ],
    ];
}

sub backend_block_keywords {
    return [
        { keyword => 'no_gen',
          label   => 'No Gen',
          descr   => 'Skip everything for this backend',
          type    => 'boolean' },

        { keyword => 'gantry_conf',
          label   => 'Use Gantry::Conf',
          descr   => 'check here if you use the Conf Gantry backend',
          type    => 'boolean', },

        { keyword => 'skip_config',
          label   => 'Skip Config',
          descr   => 'do not generate PerlSetVar statements ' .
                     '[checking gantry_conf makes this true]',
          type    => 'boolean' },

        { keyword => 'full_use',
          label   => 'Full Use Statement',
          descr   => 'use Gantry qw( -Engine=... ); [defaults to true]',
          type    => 'boolean',
          default => 'true'},

        { keyword => 'gen_root',
          label   => 'Generate Root Path',
          descr   => q!used to make a default root on request, !
                        .   q!now you get defaults by defaul!,
          type    => 'deprecated' },

        { keyword => 'template',
          label   => 'Alternate Template',
          descr   => 'A custom TT template.',
          type    => 'text' },
    ];
}

sub gen_HttpdConf {
    my $class         = shift;
    my $base_dir      = shift;
    my $tree          = shift;

    # write main file
    my $configs      = $tree->get_app_configs();
    my $controller_configs = $tree->get_controller_configs();
    my $conf_content = $class->output_httpd_conf( $tree, $configs, 'base' );

    my $docs_dir      = File::Spec->catdir( $base_dir, 'docs' );
    mkdir $docs_dir;

    my $conf_file     = File::Spec->catfile( $docs_dir, 'httpd.conf' );

    Bigtop::write_file( $conf_file, $conf_content );

    # write other files
    ALT_CONF:
    foreach my $alt_conf ( keys %{ $configs } ) {
        next ALT_CONF if $alt_conf eq 'base';
        next ALT_CONF if $alt_conf =~ /CGI/i;
        $conf_content = $class->output_httpd_conf(
                $tree, $configs, $alt_conf, $controller_configs
        );

        $conf_file = File::Spec->catfile( $docs_dir, "httpd.$alt_conf.conf" );

        Bigtop::write_file( $conf_file, $conf_content );
    }
}

sub output_httpd_conf {
    my $class       = shift;
    my $tree        = shift;
    my $configs     = shift;
    my $config_type = shift; # the name of the config we want
    my $controller_configs = shift;

    my $config      = $tree->get_config->{HttpdConf};

    my $skip_config = $config->{skip_config} || 0;
    my $gconf       = $config->{gantry_conf} || 0;

    my $instance;
    my $conffile;

    if ( $gconf ) {
        $skip_config      = 1;
        my $gantry_config = $tree->get_config->{Conf};
        $instance         = $gantry_config->{instance};
        $conffile         = $gantry_config->{conffile};
    }

    # let old timers go as before
    $instance    ||= $config->{instance   } || 0;
    $conffile    ||= $config->{conffile   } || 0;

    if ( $instance and defined $config_type and $config_type ne 'base' ) {
        $instance .= "_$config_type";
    }

    # first find the base location
    my $location_output = $tree->walk_postorder( 'output_location' );
    my $location        = $location_output->[0] || ''; # default to host root
    $location           =~ s{/+$}{};

    # then find out if we have a base controller
    my $base_handler    = $tree->walk_postorder( 'base_handler_anyone' );
    $base_handler       = ( $base_handler->[0] ) ? $tree->get_appname : 0;

    # now build the  and  blocks
    my $perl_block_lines = $tree->walk_postorder(
            'output_perl_block',
            $tree->get_config()
    );
    my $httpd_walk_output = $tree->walk_postorder(
            'output_httpd_conf_locations',
            {
                location     => $location,
                skip_config  => $skip_config,
                instance     => $instance,
                conffile     => $conffile,
                base_handler => $base_handler,
                configs      => $configs,
                config_type  => $config_type,
                controller_configs => $controller_configs,
            }
    );

    my %divided_output;
    foreach my $output_el ( @{ $httpd_walk_output } ) {
        my ( $type, $value ) = %{ $output_el };
        push @{ $divided_output{ $type } }, $value;
    }

    my $conf_file = Bigtop::Backend::HttpdConf::Gantry::conf_file(
        {
            perl_block_lines => $perl_block_lines,
            locations        => $divided_output{ locations },
        }
    );

    my %config_pairs;
    CONFIG_PAIR:
    foreach my $config_wrapper ( @{ $divided_output{ configs } } ) {
        if ( ref( $config_wrapper ) eq 'ARRAY' ) {
            foreach my $config_set ( @{ $config_wrapper } ) {
                foreach my $config_item ( split /\n/, $config_set ) {
                    my ( undef, undef, $name, $value ) =
                            split /\s+/, $config_item;
                    $config_pairs{ $name } = $value;
                }
            }
        }
        else {
            next CONFIG_PAIR unless defined $config_wrapper;
            foreach my $config_item ( split /\n/, $config_wrapper ) {
                my ( undef, undef, $name, $value ) =
                        split /\s+/, $config_item;
                $config_pairs{ $name } = $value;
            }
        }
    }

    return $conf_file;
}

our $template_is_setup = 0;
our $default_template_text = <<'EO_TT_BLOCKS';
[% BLOCK conf_file %]
[% FOREACH line IN perl_block_lines %]
[% line %]
[% END %][%# end of foreach line in perl_block_lines %]

[% FOREACH line IN locations %]
[% line %]
[% END %][%# end of foreach line in locations %]
[% END %]

[% BLOCK perl_block %]

    #![% perl_path +%]

[% FOREACH line IN top_lines %]
[% line %]
[% END %]
[% IF full_base_use %]
    use [% base_module %] qw{
        -PluginNamespace=[% base_module +%][% IF engine %]

        -Engine=[% engine %][% END %][% IF template_engine %]

        -TemplateEngine=[% template_engine %][% END %][% IF plugins %]

        [% plugins %]
[% END %][%# end of IF plugins +%]
    };
[% ELSE %]
    use [% base_module %];
[% END %]
[% FOREACH line IN child_output %]
[% line %]
[% END %]

[% END %]

[% BLOCK all_locations %]

[% FOREACH config IN configs %][% config %][% END %]
[% FOREACH literal IN literals %][% literal %][% END %]
[% IF base_handler %]

    SetHandler  perl-script
    PerlHandler [% base_handler +%]

[% END %]


[% FOREACH child_piece IN child_output %][% child_piece %][% END %]
[% END %][%# all_locations %]

[% BLOCK config %]
    PerlSetVar [% var %] [% value %]

[% END %]

[% BLOCK sub_locations %]

    SetHandler  perl-script
    PerlHandler [% handler %]
[% FOREACH config IN loc_configs %]

[% config %]
[% END %]
[% IF literal %]

[% literal %]
[% END %]



[% END %]
EO_TT_BLOCKS

sub setup_template {
    my $class         = shift;
    my $template_text = shift || $default_template_text;

    return if ( $template_is_setup );

    Inline->bind(
            TT                  => $template_text,
            POST_CHOMP          => 1,
            TRIM_LEADING_SPACE  => 0,
            TRIM_TRAILING_SPACE => 0,
    );

    $template_is_setup = 1;
}

package # application
    application;
use strict; use warnings;

sub output_perl_block {
    my $self         = shift;
    my $child_output = shift;
    my $config       = shift;

    my $base_module  = $self->get_name();

    my @top_lines;
    my @regular_lines;

    foreach my $child_hash ( @{ $child_output } ) {
        my ( $key, $value ) = each %{ $child_hash };

        if ( $key eq 'PerlTop' ) { push @top_lines,     $value; }
        else                     { push @regular_lines, $value; }
    }

    my $backend_config      = $config->{HttpdConf};
    my $full_base_use       = 1;

    if ( defined $backend_config->{full_use}
            and
         not $backend_config->{full_use} )
    {
        $full_base_use      = 0;
    }

    my $perl_path           = $^X;

    my $output = Bigtop::Backend::HttpdConf::Gantry::perl_block(
        {
            base_module   => $base_module,
            child_output  => \@regular_lines,
            top_lines     => \@top_lines,
            full_base_use => $full_base_use,
            perl_path     => $perl_path,
            %{ $config }, # in case full use is true
        }
    );

    return [ $output ];
}

sub output_httpd_conf_locations {
    my $self          = shift;
    my $child_output  = shift;
    my $data          = shift;
    my $location      = $data->{location};
    my $skip_config   = $data->{skip_config};
    my $configs       = $data->{configs};
    my $config_type   = $data->{config_type};

    # handle configs at root location
    my $config_output;
    if ( $skip_config ) {
        if ( $data->{ instance } ) {
            $config_output .= Bigtop::Backend::HttpdConf::Gantry::config(
                {
                    var   => 'GantryConfInstance',
                    value => $data->{ instance },
                }
            );
            if ( $data->{ conffile } ) {
                $config_output .= Bigtop::Backend::HttpdConf::Gantry::config(
                    {
                        var   => 'GantryConfFile',
                        value => $data->{ conffile },
                    }
                );
            }
        }
    }
    else {
        $config_output  = $self->walk_postorder(
                'output_configs', {
                    configs     => $configs,
                    config_type => $config_type,
                }
        );
    }
    my $literals = $self->walk_postorder( 'output_root_literal' );

    my $output   = Bigtop::Backend::HttpdConf::Gantry::all_locations(
        {
            root_loc     => $location || '/',
            configs      => $config_output,
            literals     => $literals,
            child_output => $child_output,
            base_handler => $data->{base_handler},
        }
    );

    return [ { locations => $output, }, { configs => $config_output } ];
}

package # app_config_block
    app_config_block;
use strict; use warnings;

sub get_conf_names {
    my $self = shift;

    return unless defined $self->{__TYPE__};

    return [ $self->{__TYPE__} ];
}

sub output_configs {
    my $self         = shift;
    my $child_output = shift;
    my $data         = shift;
    my $configs      = $data->{ configs };
    my $desired_type = $data->{ config_type } || 'base';

    return unless $child_output;

    # you can stay if:
    # A. desired config_type is base and self type is undef or base
    # B. desired config_type is self type
    #my $own_type = ( defined $self->{__TYPE__} ) ? $self->{__TYPE__} : 'base';
    my $own_type = $self->{__TYPE__} || 'base';

    return unless ( $own_type eq $desired_type );

    my $output;

    my %configs_set;
    foreach my $config ( @{ $child_output } ) {
        $output .= Bigtop::Backend::HttpdConf::Gantry::config(
            {
                var   => $config->{__KEYWORD__},
                value => $config->{__ARGS__},
            }
        );
        $configs_set{ $config->{__KEYWORD__} }++;
    }

    # fill in missing values from base config
    my $gen_root = 1;

    BASE_KEY:
    foreach my $base_key ( keys %{ $configs->{ base } } ) {
        next BASE_KEY if $configs_set{ $base_key };

        $output .= Bigtop::Backend::HttpdConf::Gantry::config(
            {
                var   => $base_key,
                value => $configs->{ base }{ $base_key },
            }
        );

        $gen_root = 0 if ( $base_key eq 'root' );
    }

    if ( $gen_root ) {
        $output .= Bigtop::Backend::HttpdConf::Gantry::config(
            {
                var   => 'root',
                value => 'html:html/templates',
            }
        );
    }

    return [ $output ];
}

package # app_config_statement
    app_config_statement;
use strict; use warnings;

sub output_configs {
    my $self         = shift;
    shift;                      # no children => no child output
    my $data         = shift;
    my $output_vals = $self->{__ARGS__}->get_args();

    return [ {
            __KEYWORD__ => $self->{__KEYWORD__},
            __ARGS__    => $output_vals
    } ];
}

package # literal_block
    literal_block;
use strict; use warnings;

sub output_perl_block {
    my $self = shift;

    my $retval = $self->make_output( 'PerlBlock', 'I want a hash' );

    return $retval if $retval;

    return $self->make_output( 'PerlTop', 'I want a hash' );
}

sub output_root_literal {
    my $self = shift;

    return $self->make_output( 'Location' );
}

sub output_httpd_conf_locations {
    my $self = shift;

    return $self->make_output( 'HttpdConf' );
}

package # controller_block
    controller_block;
use strict; use warnings;

sub base_handler_anyone {
    my $self = shift;

    return unless $self->is_base_controller;

    return [ 1 ];
}

sub output_perl_block {
    my $self         = shift;
    my $app          = $self->{__PARENT__}{__PARENT__}{__PARENT__};
    my $full_name    = $app->get_name() . '::' . $self->get_name();

    return if ( $self->is_base_controller );

    return [ { PerlBlock => ' ' x 4 . "use $full_name;\n" } ];
}

sub output_httpd_conf_locations {
    my $self          = shift;
    my $child_output  = shift;
    my $data          = shift;
    my $location      = $data->{location};
    my $skip_config   = $data->{skip_config};
    my $base_config   = $data->{base_config};
    my $config_type   = $data->{config_type};

    return if ( $self->is_base_controller );

    my %child_loc    = @{ $child_output };

    if ( keys %child_loc != 1 ) {
        die "Error: controller '" . $self->get_name()
            . "' must have one location or rel_location statement.\n";
    }

    my $app          = $self->{__PARENT__}{__PARENT__}{__PARENT__};
    my $full_name    = $app->get_name() . '::' . $self->get_name();

    my $loc_configs  = $self->walk_postorder(
            'output_controller_configs', $data
    );

    my $literals     = $self->walk_postorder( 'output_location_literal' );

    my $child_location;

    if ( defined $child_loc{rel_location} ) {
        $child_location = "$location/$child_loc{rel_location}";
    }
    else { # must be location
        $child_location = $child_loc{location};
    }

    my $output = Bigtop::Backend::HttpdConf::Gantry::sub_locations(
        {
            loc          => $child_location,
            literal      => join( "\n", @{ $literals } ),
            handler      => $full_name,
            loc_configs  => $loc_configs,
        }
    );

    return [ $output ];
}

package # controller_statement
    controller_statement;
use strict; use warnings;

sub output_httpd_conf_locations {
    my $self         = shift;

    if ( $self->{__KEYWORD__} eq 'rel_location' ) {
        return [ rel_location => $self->{__ARGS__}->get_first_arg() ];
    }
    elsif ( $self->{__KEYWORD__} eq 'location' ) {
        return [ location => $self->{__ARGS__}->get_first_arg() ];
    }
    else {
        return;
    }
}

package # controller_config_block
    controller_config_block;
use strict; use warnings;

sub output_controller_configs {
    my $self          = shift;
    my $child_output  = shift;
    my $data          = shift;

    my $controller    = $self->get_controller_name();
    my $skip_config   = $data->{ skip_config };
    my $config_type   = $data->{ config_type };
    my $configs       = $data->{ controller_configs }{ $controller };
    my $own_type      = $self->{__TYPE__} || 'base';

    return unless $child_output;
    return if     $skip_config;
    return unless $own_type eq $config_type;

    my $output;
    my %config_set_for;

    foreach my $config ( @{ $child_output } ) {
        $output .= Bigtop::Backend::HttpdConf::Gantry::config(
            {
                var   => $config->{__KEYWORD__},
                value => $config->{__ARGS__},
            }
        );
        $config_set_for{ $config->{__KEYWORD__} }++;
    }

    # fill in omitted keys from the base block
    CONTROLLER_BASE_KEY:
    foreach my $base_key ( keys %{ $configs->{ base } } ) {
        next CONTROLLER_BASE_KEY if $config_set_for{ $base_key };

        $output .= Bigtop::Backend::HttpdConf::Gantry::config(
            {
                var   => $base_key,
                value => $configs->{ base }{ $base_key },
            }
        );
    }

    return [ $output ];
}

package # controller_config_statement
    controller_config_statement;
use strict; use warnings;

sub output_controller_configs {
    my $self         = shift;

    my $output_vals = $self->{__ARGS__}->get_args();

    return [ {
            __KEYWORD__ => $self->{__KEYWORD__},
            __ARGS__    => $output_vals
    } ];
}

package # controller_literal_block
    controller_literal_block;
use strict; use warnings;

sub output_location_literal {
    my $self = shift;

    return $self->make_output( 'Location' );
}

1;

=head1 NAME

Bigtop::Backend::HttpdConf::Gantry - httpd.conf generator for the Gantry framework

=head1 SYNOPSIS

If your bigtop file includes:

    config {
        HttpdConf Gantry {}
    }

and there are controllers in your app section, this module will generate
docs/httpd.conf when you type:

    bigtop app.bigtop HttpdConf

or

    bigtop app.bigtop all

You can then directly Include this conf in your system httpd.conf or in one
of its virtual hosts.

=head1 DESCRIPTION

This is a Bigtop backend which generates httpd.conf files.

By default, this module converts every statement in an app or controller
level config block into a PerlSetVar statement.  If you have a different
conf scheme in mind (like Gantry::Conf with flat files), you may not want
to define those set vars.  In that, case do this in the Bigtop config section:

    config {
        HttpdConf Gantry { skip_config 1; }
    }

Any PerlSetVar statements you put in literal Location statements will
still appear (remember: literal means literal).  But, no PerlSetVar statements
will be made by the module.

=head1 KEYWORDS

This module does not register any keywords.  See Bigtop::HttpdConf
for a list of allowed keywords (think app and controller level 'location'
and controller level 'rel_location' statements).

=head1 METHODS

To keep podcoverage tests happy.

=over 4

=item backend_block_keywords

Tells tentmaker that I understand these config section backend block keywords:

    no_gen
    gen_root
    full_use
    gantry_conf
    skip_config
    template

    instance
    conffile

Note that instance and conffile are deprecated.  You should use the single
gantry_conf instead.  Then the instance and conffile will be drawn from the
Conf Gantry backend's config block.  This save duplicating that data.

=item what_do_you_make

Tells tentmaker what this module makes.  Summary: docs/httpd.conf.

=item gen_HttpdConf

Called by Bigtop::Parser to get me to do my thing.

=item output_httpd_conf

What I call on the AST packages to do my thing.

=item setup_template

Called by Bigtop::Parser so the user can substitute an alternate template
for the hard coded one here.

=back

=head1 AUTHOR

Phil Crow

=head1 COPYRIGHT and LICENSE

Copyright (C) 2005 by Phil Crow

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.

=cut