File Coverage

blib/lib/XAO/DO/Web/Redirect.pm
Criterion Covered Total %
statement 21 33 63.6
branch 4 14 28.5
condition n/a
subroutine 4 4 100.0
pod 1 1 100.0
total 30 52 57.6


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             XAO::DO::Web::Redirect - browser redirection object
4              
5             =head1 SYNOPSIS
6              
7             <%Redirect url="/login.html"%>
8              
9             =head1 DESCRIPTION
10              
11             Redirector object.
12             Can set cookies on the redirect.
13              
14             =cut
15              
16             ###############################################################################
17             package XAO::DO::Web::Redirect;
18 1     1   727 use strict;
  1         3  
  1         32  
19 1     1   5 use XAO::Utils;
  1         2  
  1         72  
20 1     1   5 use base XAO::Objects->load(objname => 'Web::Page');
  1         2  
  1         6  
21              
22             our $VERSION='2.002';
23              
24             ###############################################################################
25              
26             =pod
27              
28             Arguments are:
29              
30             url => new url or short path.
31             target => target frame (optional, only works with Netscape)
32             base => if set uses base site name (optional)
33             secure => if set uses secure protocol (optional)
34             permanent => use status 301 (default is 302)
35              
36             =cut
37              
38             sub display {
39 1     1 1 3 my $self=shift;
40 1         4 my $args=get_args(\@_);
41 1         13 my $config=$self->siteconfig;
42              
43             ##
44             # Checking parameters.
45             #
46 1 50       5 if(! $args->{'url'}) {
47 0         0 eprint "No URL or path in Redirect";
48 0         0 return;
49             }
50              
51             ##
52             # Additional fields into standard header.
53             #
54             my %qa=(
55 1 50       4 -Status => $args->{'permanent'} ? '301 Permanently Moved' : '302 Moved'
56             );
57              
58             ##
59             # Target window works only with Netscape, but we do not care here and
60             # do our best.
61             #
62 1 50       4 if($args->{'target'}) {
63 0         0 dprint ref($self),"::display - 'target=$args->{target}' does not work with MSIE!";
64 0         0 $qa{'-Target'}=$args->{'target'};
65             }
66              
67             ##
68             # Getting redirection URL
69             #
70 1         1 my $url;
71 1 50       7 if($args->{'url'} =~ /^\w+:\/\//) {
72 1         3 $url=$args->{'url'};
73             }
74             else {
75 0         0 my $base=$args->{'base'};
76 0         0 my $secure=$args->{'secure'};
77 0         0 my $url_path=$args->{'url'};
78 0 0       0 if(substr($url_path,0,1) eq '/') {
79 0 0       0 my $base_url=$self->base_url(
80             active => $base ? 0 : 1,
81             secure => $secure,
82             );
83 0         0 $url=$base_url . $url_path;
84             }
85             else {
86 0 0       0 $url=$self->pageurl(
87             active => $base ? 0 : 1,
88             secure => $secure,
89             );
90 0         0 $url=~s/^(.*\/)(.*?)$/$1$url_path/;
91             }
92             }
93              
94             ##
95             # Redirecting
96             #
97 1         2 $qa{-Location}=$url;
98 1         27 $config->header_args(\%qa);
99 1         9 $self->finaltextout(<
100             The document is moved here.
101             EOT
102             }
103              
104             ###############################################################################
105             1;
106             __END__