File Coverage

blib/lib/AxKit/XSP/WebUtils.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

# $Id: WebUtils.pm,v 1.9 2003/07/10 09:43:20 matt Exp $

# Original Code and comments from Steve Willer.

package AxKit::XSP::WebUtils;

$VERSION = "1.6";

# taglib stuff
use AxKit 1.4;
use Apache;
use Apache::Constants qw(OK);
use Apache::Util;
use Apache::Request;
use Apache::URI;
use Apache::AxKit::Language::XSP::TaglibHelper;
sub parse_char  { Apache::AxKit::Language::XSP::TaglibHelper::parse_char(@_); }
sub parse_start { Apache::AxKit::Language::XSP::TaglibHelper::parse_start(@_); }
sub parse_end   { Apache::AxKit::Language::XSP::TaglibHelper::parse_end(@_); }

$NS = 'http://axkit.org/NS/xsp/webutils/v1';

@EXPORT_TAGLIB = (
  'env_param($name)',
  'path_info()',
  'query_string()',
  'request_uri()',
  'request_host()',
  'server_root()',
  'redirect($uri;$host,$secure,$use_refresh)',
  'url_encode($string)',
  'url_decode($string)',
  'header($name;$value)',
  'return_code($code)',
  'username()',
  'password()',
  'request_parsed_uri(;$omit)',
  'request_prev_parsed_uri(;$omit)',
  'request_prev_uri()',
  'request_prev_query_string()',
  'request_prev_param($name)',
  'match_useragent($name)',
  'is_https()',
  'is_initial_req()',
  'variant_list():as_xml=true',
  'error_notes()',
  'server_admin()',
);

@ISA = qw(Apache::AxKit::Language::XSP);

use strict;

sub env_param ($) {
    my ($name) = @_;

    return $ENV{$name};
}

sub path_info () {
    my $Request = AxKit::Apache->request;
    return $Request->path_info;
}

sub query_string () {
    my $Request = AxKit::Apache->request;
    return $Request->query_string;
}

sub request_uri () {
    my $Request = AxKit::Apache->request;
    return $Request->uri;
}

sub server_root () {
    my $Request = AxKit::Apache->request;
    return $Request->document_root;
}

sub request_host () {
    my $hostname = Apache->header_in('Via');
    $hostname =~ s/^[0-9.]+ //g;
    $hostname =~ s/ .*//g;
    $hostname ||= $ENV{HTTP_HOST};
    $hostname ||= Apache->header_in('Host');
    return $hostname;
}

sub redirect ($;$$$) {
    my ($uri, $host, $secure, $use_refresh) = @_;

    if (lc($secure) eq 'yes') { $secure = 1 }
    elsif (lc($secure) eq 'no') { $secure = 0 }
    if (lc($use_refresh) eq 'yes') { $use_refresh = 1 }
    elsif (lc($use_refresh) eq 'no') { $use_refresh = 0 }

    my $myhost = $host;

    my $Request = AxKit::Apache->request;

    if ($uri !~ m|^https?://|oi) {
        if ($uri !~ m#^/#) {
            $uri = "./$uri" if $uri =~ /^\./;

            # relative path, so let's resolve the path ourselves
        my $base = $Request->uri;
            $base =~ s{[^/]*$}{};
        $uri = "$base$uri";
        $uri =~ s{//+}{/}g;
        $uri =~ s{/.(/|$)}{/}g;                     # embedded ./
        1 while ($uri =~ s{[^/]+/\.\.(/|$)}{}g);   # embedded ../
        $uri =~ s{^(/\.\.)+(/|$)}{/}g;              # ../ off of "root"
    }

        if (not defined $host) {
            $myhost = $Request->header_in("Host");

            # if we're going through a proxy, the virtual host is rewritten; yuck
            if ($myhost !~ /[a-zA-Z]/) {
                my $Server = $Request->server;
                $myhost = $Server->server_hostname;
                my $port = $Server->port;
                $myhost .= ":$port" if $port != 80;
            }
        }

        my $scheme = 'http';
        $scheme = 'https' if $secure; # Hmm, might break if $port was set above...
        if ($use_refresh) {
            $Request->header_out("Refresh" => "0; url=${scheme}://${myhost}${uri}");
            $Request->content_type("text/html");
            $Request->status(200);
        }
        else {
            $Request->header_out("Location" => "${scheme}://${myhost}${uri}");
            $Request->status(302);
        }
    }
    else {
        if ($use_refresh) {
            $Request->header_out("Refresh" => "0; url=$uri");
            $Request->content_type("text/html");
            $Request->status(200);
        }
        else {
            $Request->header_out("Location" => $uri);
            $Request->status(302);
        }
    }

    $Request->send_http_header;

    Apache::exit();
}

sub header ($;$) {
    my $name = shift;
    my $r = AxKit::Apache->request;

    if (@_) {
        return $r->header_out($name, $_[0]);
    }
    else {
        return $r->header_in($name);
    }
}

sub url_encode ($) {
    return Apache::Util::escape_uri(shift);
}

sub url_decode ($) {
    return Apache::Util::unescape_uri(shift);
}

sub return_code ($) {
    my $code = shift;

    my $Request = AxKit::Apache->request;

    $Request->status($code);

    $Request->send_http_header;

    Apache::exit();
}

sub username () {
    my $r = AxKit::Apache->request;

    return $r->connection->user;
}

sub password () {
    my $r = AxKit::Apache->request;

    my ($res, $pwd) = $r->get_basic_auth_pw;
    if ($res == OK) {
        return $pwd;
    }
    return;
}

sub request_parsed_uri ($) {
    my $omit = shift;
    my $r = AxKit::Apache->request;
    my $uri = Apache::URI->parse($r);

    if ($omit eq 'path') {
        $uri->path(undef);
        $uri->query(undef); # we don't want a query without a path
    }
    elsif ($omit eq 'path_info' or $omit eq 'query') {
        $uri->$omit(undef);
    }

    return $uri->unparse;
}

sub request_prev_parsed_uri ($) {
    my $omit = shift;
    my $r = AxKit::Apache->request;
    my $uri = Apache::URI->parse($r->prev||$r);

    if ($omit eq 'path') {
        $uri->path(undef);
        $uri->query(undef); # we don't want a query without a path
    }
    elsif ($omit eq 'path_info' or $omit eq 'query') {
        $uri->$omit(undef);
    }

    return $uri->unparse;
}

sub request_prev_uri () {
    my $r = AxKit::Apache->request;
    return ($r->prev||$r)->uri;
}

sub request_prev_query_string () {
    my $r = AxKit::Apache->request;
    return ($r->prev||$r)->query_string;
}

sub request_prev_param ($) {
    my $name = shift;
    my $apr = Apache::Request->instance((AxKit::Apache->request->prev||AxKit::Apache->request));

    return $apr->param($name);
}

sub match_useragent ($) {
    my $name = shift;
    my $r = AxKit::Apache->request;

    return $r->header_in('User-Agent') =~ $name;
}

sub is_https () {
    my $r = AxKit::Apache->request;
    return 1 if $r->subprocess_env('https');
}

sub is_initial_req () {
    my $r = AxKit::Apache->request;
    return $r->is_initial_req;
}

sub variant_list () {
    my $r = AxKit::Apache->request;
    my $variant_list = ($r->prev||$r)->notes('variant-list');

    $variant_list =~ s/([^:>])\n/$1<\/li>\n/g; # tidy up single li-tags because
                                               # mod_negotiation's list is not
                                               # well-balanced up to Apache 1.3.28

    return $variant_list;
}

sub error_notes () {
    my $r = AxKit::Apache->request;
    return ($r->prev||$r)->notes('error-notes');
}

sub server_admin () {
    my $r = AxKit::Apache->request;
    return $r->server->server_admin;
}


1;

__END__