File Coverage

blib/lib/Perlbal/Plugin/Addheader.pm

Criterion	Covered	Total	%
statement	9	56	16.0
branch	0	12	0.0
condition			n/a
subroutine	3	10	30.0
pod	0	4	0.0
total	12	82	14.6

package Perlbal::Plugin::Addheader;

use warnings;
use strict;

=head1 NAME

Perlbal::Plugin::Addheader - Add Headers to Perlbal webserver/reverse_proxy responses

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.02';


=head1 Description

This module allows you to add/change headers to/from perlbal responses.

You can configure headers to be added/changed based on each service declared, although the service role has to be set to web_server or reverse_proxy.

For each header you want to add/change,  you have to specify the header content, this header content can be a set of characters or Perl code that will be evaluated for each response.




=head1 SYNOPSIS

This module provides a Perlbal plugin wich can be loaded and used as follows

    Load Addheader

    #ADDHEADER
    ADDHEADER static Server This is My Webserver

    CREATE SERVICE static
        SET ROLE = web_server
        SET docroot /server/static
        SET plugins = Addheader
    ENABLE static

In this case for each response served by the C, the header C will be changed to C.

In cases where you need a dynamic value to be server as header content, you can put Perl code as the header content, surrounding the header content with C<[%> and C<%]>.

    ADDHEADER static Expires [% {use HTTP::Date;HTTP::Date::time2str(time() + 2592000)} %]

In this case, for each response, the header C will be added, ant the content will be the time in exactly 30 days from the time the response has been sent .





=head1 AUTHOR

Bruno Martins, C<<  >>

=head1 BUGS

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 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Perlbal::Plugin::Addheader


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 TODO

Allow add/change response headers on all services (non role dependent)

Allow add/change response headers on all services at a time (one line configuration)



=head1 COPYRIGHT & LICENSE

Copyright 2009 Bruno Martins  C<<  >> and SAPO C, all rights reserved.

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


=cut

my $added_headers;

sub register {
    my ($class, $svc) = @_;
    use Data::Dumper;
    $svc->register_hook('Addheader','modify_response_headers', sub {

        my Perlbal::HTTPHeaders $res = $_[0]->{res_headers};
        my $service_name = $_[0]->{service}{'name'};
        if (defined $added_headers->{$service_name}) {
            foreach my $header (@{$added_headers->{$service_name}}) {
                my $header_content= $header->{'header_content'};
                if ($header_content =~/^\[\%.*\%]$/) {
                    $header_content =~s/^\[\%//;
                    $header_content =~s/\%\]$//;
                    $header_content = eval($header_content);
                    if ($@) {
                        print "Error on eval for header '$header->{'header_name'}'\n";
                        next;
                    }
                }
                $res->header($header->{'header_name'}, $header_content);
            }
        }
        return 0;
    });

	$svc->register_hook('Addheader','backend_response_received', sub {

        my Perlbal::HTTPHeaders $res = $_[0]->{res_headers};
        my $service_name = $_[0]->{service}{'name'};
        if (defined $added_headers->{$service_name}) {
            foreach my $header (@{$added_headers->{$service_name}}) {
                my $header_content= $header->{'header_content'};
                if ($header_content =~/^\[\%.*\%]$/) {
                    $header_content =~s/^\[\%//;
                    $header_content =~s/\%\]$//;
                    $header_content = eval($header_content);
                    if ($@) {
                        print "Error on eval for header '$header->{'header_name'}'\n";
                        next;
                    }
                }
                $res->header($header->{'header_name'}, $header_content);
            }
        }
        return 0;
    });


    return 0;
}

sub unregister {
    my ($class, $svc) = @_;
    $svc->unregister_hooks('Addheader');
    return 1;
}


sub load {

    Perlbal::register_global_hook('manage_command.addheader', sub {
        my $command_regexp = qr/^addheader\s+(\w+)\s+([^\s]+)\s+(.*?)$/i;
        my $mc = shift->parse($command_regexp,
                              "usage: ADDHEADER   ");
        my ($service, $header_name, $header_content) = $mc->args;

        # Get the original line, since perlbal puts everything to lower case before parsing
        my @args = ($mc->orig =~/$command_regexp/);
        $header_content = pop @args;

        push @{$added_headers->{$service}},{'header_name' => $header_name, 'header_content' => $header_content};
    });
    return 1;
}
sub unload { return 1; }



1; # End of Perlbal::Plugin::Addheader