File Coverage

blib/lib/Plack/Handler/Stomp/PathInfoMunger.pm
Criterion Covered Total %
statement 24 25 96.0
branch 5 6 83.3
condition n/a
subroutine 5 5 100.0
pod 1 1 100.0
total 35 37 94.5


line stmt bran cond sub pod time code
1             package Plack::Handler::Stomp::PathInfoMunger;
2             $Plack::Handler::Stomp::PathInfoMunger::VERSION = '1.14';
3             {
4             $Plack::Handler::Stomp::PathInfoMunger::DIST = 'Plack-Handler-Stomp';
5             }
6 13     13   89 use strict;use warnings;
  13     13   32  
  13         411  
  13         69  
  13         29  
  13         720  
7 13         153 use Sub::Exporter -setup => {
8             exports => ['munge_path_info'],
9             groups => { default => ['munge_path_info'] },
10 13     13   89 };
  13         29  
11              
12             # ABSTRACT: printf-style interpolations for PATH_INFO
13              
14             my $regex = qr{
15             (?:%\{
16             (.*?)
17             \})
18             }x;
19              
20              
21             sub munge_path_info {
22 15     15 1 519 my ($fmt,$server,$frame) = @_;
23              
24             my $lookup = sub {
25 10     10   16 my $key = shift;
26 10 100       22 if ($key eq 'broker.hostname') {
27             return $server->{hostname}
28 2         10 }
29 8 50       16 if ($key eq 'broker.port') {
30             return $server->{port}
31 0         0 }
32 8         18 $key =~ s{^header\.}{};
33 8         16 my $val = $frame->headers->{$key};
34 8 100       39 if (defined $val) {
35 7         27 return $val;
36             }
37 1         5 return '';
38 15         107 };
39              
40 15         32 my $str = $fmt;
41 15         270 $str =~ s{\G(.*?)$regex}{$1 . $lookup->($2)}ge;
  10         23  
42 15         115 return $str;
43             }
44              
45             1;
46              
47             __END__
48              
49             =pod
50              
51             =encoding UTF-8
52              
53             =head1 NAME
54              
55             Plack::Handler::Stomp::PathInfoMunger - printf-style interpolations for PATH_INFO
56              
57             =head1 VERSION
58              
59             version 1.14
60              
61             =head1 FUNCTIONS
62              
63             =head2 C<munge_path_info>
64              
65             my $str = munge_path_info($format_string,$server_config,$stomp_frame);
66              
67             Interprets the C<$format_string> in a C<printf>-like way: every C<
68             %{something} > is replaced with a value from the C<$server_config> or
69             the C<$stomp_frame>. In particular:
70              
71             =over 4
72              
73             =item C<%{broker.hostname}>
74              
75             is replaced by the value of C<< $server_config->{hostname} >>
76              
77             =item C<%{broker.port}>
78              
79             is replaced by the value of C<< $server_config->{port} >>
80              
81             =item C<%{header.something}>
82              
83             is replaced by the value of C<< $stomp_frame->headers->{something} >>
84             (of course C<something> in this example can be replaced by whatever
85             string you want).
86              
87             =item anything else
88              
89             is replaced by an empty string (i.e. it's removed).
90              
91             =back
92              
93             =head1 AUTHOR
94              
95             Gianni Ceccarelli <gianni.ceccarelli@net-a-porter.com>
96              
97             =head1 COPYRIGHT AND LICENSE
98              
99             This software is copyright (c) 2012 by Net-a-porter.com.
100              
101             This is free software; you can redistribute it and/or modify it under
102             the same terms as the Perl 5 programming language system itself.
103              
104             =cut