rt/lib/RT/Interface/Web/Request.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
   6 #                                          <jesse@bestpractical.com>
   7 #
   8 # (Except where explicitly superseded by other copyright notices)
   9 #
  10 #
  11 # LICENSE:
  12 #
  13 # This work is made available to you under the terms of Version 2 of
  14 # the GNU General Public License. A copy of that license should have
  15 # been provided with this software, but in any event can be snarfed
  16 # from www.gnu.org.
  17 #
  18 # This work is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26 # 02110-1301 or visit their web page on the internet at
  27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  28 #
  29 #
  30 # CONTRIBUTION SUBMISSION POLICY:
  31 #
  32 # (The following paragraph is not intended to limit the rights granted
  33 # to you to modify and distribute this software under the terms of
  34 # the GNU General Public License and is only of importance to you if
  35 # you choose to contribute your changes and enhancements to the
  36 # community by submitting them to Best Practical Solutions, LLC.)
  37 #
  38 # By intentionally submitting any modifications, corrections or
  39 # derivatives to this work, or any other work intended for use with
  40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  41 # you are the copyright holder for those contributions and you grant
  42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  43 # royalty-free, perpetual, license to use, copy, create derivative
  44 # works based on those contributions, and sublicense and distribute
  45 # those contributions and any derivatives thereof.
  46 #
  47 # END BPS TAGGED BLOCK }}}
  48
  49 package RT::Interface::Web::Request;
  50
  51 use strict;
  52 use warnings;
  53
  54 our $VERSION = '0.30';
  55 use base qw(HTML::Mason::Request);
  56
  57 sub new {
  58     my $class = shift;
  59
  60     my $new_class = $HTML::Mason::ApacheHandler::VERSION ?
  61         'HTML::Mason::Request::ApacheHandler' :
  62             $HTML::Mason::CGIHandler::VERSION ?
  63                 'HTML::Mason::Request::CGI' :
  64                     'HTML::Mason::Request';
  65
  66     $class->alter_superclass( $new_class );
  67     $class->valid_params( %{ $new_class->valid_params } );
  68     return $class->SUPER::new(@_);
  69 }
  70
  71 # XXX TODO: This alter_superclass replaces teh funcitonality in Mason 1.39
  72 # with code which doesn't trigger a bug in Perl 5.10.
  73 # (Perl 5.10.0 does NOT take kindly to having its @INC entries changed)
  74 # http://rt.perl.org/rt3/Public/Bug/Display.html?id=54566
  75 #
  76 # This routine can be removed when either:
  77 #   * RT depends on a version of mason which contains this fix
  78 #   * Perl 5.10.0 is not supported for running RT
  79 sub alter_superclass {
  80     my $class = shift;
  81     my $new_super = shift;
  82     my $isa_ref;
  83     { no strict 'refs'; my @entries = @{$class."::ISA"}; $isa_ref = \@entries; }
  84
  85     # handles multiple inheritance properly and preserve
  86     # inheritance order
  87     for ( my $x = 0; $x <= $#{$isa_ref} ; $x++ ) {
  88         if ( $isa_ref->[$x]->isa('HTML::Mason::Request') ) {
  89             my $old_super = $isa_ref->[$x];
  90                 $isa_ref->[$x] = $new_super
  91             if ( $old_super ne $new_super );
  92             last;
  93         }
  94     }
  95
  96     { no strict 'refs'; @{$class."::ISA"} = @$isa_ref; }
  97     $class->valid_params( %{ $class->valid_params } );
  98 }
  99
 100
 101 =head2 callback
 102
 103 Method replaces deprecated component C<Element/Callback>.
 104
 105 Takes hash with optional C<CallbackPage>, C<CallbackName>
 106 and C<CallbackOnce> arguments, other arguments are passed
 107 throught to callback components.
 108
 109 =over 4
 110
 111 =item CallbackPage
 112
 113 Page path relative to the root, leading slash is mandatory.
 114 By default is equal to path of the caller component.
 115
 116 =item CallbackName
 117
 118 Name of the callback. C<Default> is used unless specified.
 119
 120 =item CallbackOnce
 121
 122 By default is false, otherwise runs callbacks only once per
 123 process of the server. Such callbacks can be used to fill
 124 structures.
 125
 126 =back
 127
 128 Searches for callback components in
 129 F<< /Callbacks/<any dir>/CallbackPage/CallbackName >>, for
 130 example F</Callbacks/MyExtension/autohandler/Default> would
 131 be called as default callback for F</autohandler>.
 132
 133 =cut
 134
 135 {
 136 my %cache = ();
 137 my %called = ();
 138 sub callback {
 139     my ($self, %args) = @_;
 140
 141     my $name = delete $args{'CallbackName'} || 'Default';
 142     my $page = delete $args{'CallbackPage'} || $self->callers(0)->path;
 143     unless ( $page ) {
 144         $RT::Logger->error("Couldn't get a page name for callbacks");
 145         return;
 146     }
 147
 148     my $CacheKey = "$page--$name";
 149     return 1 if delete $args{'CallbackOnce'} && $called{ $CacheKey };
 150     $called{ $CacheKey } = 1;
 151
 152     my $callbacks = $cache{ $CacheKey };
 153     unless ( $callbacks ) {
 154         $callbacks = [];
 155         my $path  = "/Callbacks/*$page/$name";
 156         my @roots = map $_->[1],
 157                         $HTML::Mason::VERSION <= 1.28
 158                             ? $self->interp->resolver->comp_root_array
 159                             : $self->interp->comp_root_array;
 160
 161         my %seen;
 162         @$callbacks = (
 163             grep defined && length,
 164             # Skip backup files, files without a leading package name,
 165             # and files we've already seen
 166             grep !$seen{$_}++ && !m{/\.} && !m{~$} && m{^/Callbacks/[^/]+\Q$page/$name\E$},
 167             map { sort $self->interp->resolver->glob_path($path, $_) }
 168             @roots
 169         );
 170         foreach my $comp (keys %seen) {
 171             next unless $seen{$comp} > 1;
 172             $RT::Logger->error("Found more than one occurrence of the $comp callback.  This may cause only one of the callbacks to run.  Look for the duplicate Callback in your @roots");
 173         }
 174
 175         $cache{ $CacheKey } = $callbacks unless RT->Config->Get('DevelMode');
 176     }
 177
 178     my @rv;
 179     foreach my $cb ( @$callbacks ) {
 180         push @rv, scalar $self->comp( $cb, %args );
 181     }
 182     return @rv;
 183 }
 184 }
 185
 186 =head2 request_path
 187
 188 Returns path of the request.
 189
 190 Very close to C<< $m->request_comp->path >>, but if called in a dhandler returns
 191 path of the request without dhandler name, but with dhandler arguments instead.
 192
 193 =cut
 194
 195 sub request_path {
 196     my $self = shift;
 197
 198     my $path = $self->request_comp->path;
 199     # disabled dhandlers, not RT case, but anyway
 200     return $path unless my $dh_name = $self->dhandler_name;
 201     # not a dhandler
 202     return $path unless substr($path, -length("/$dh_name")) eq "/$dh_name";
 203     substr($path, -length $dh_name) = $self->dhandler_arg;
 204     return $path;
 205 }
 206
 207 1;