Темы

1

Perl / REDIRECT

« : 02 Марта 2007, 16:52:34 »

Есть сайт, который у хостера стоит на Microsoft-IIS/5.0 сервере. Сайт написан на CGI. мне нужно сделать, что бы при попадании в определённый раздел сайта, который генерится из базы происходил редирект на другой сайт. .htaccess не работает.

Нашёл в каталоге сайта следующий файл: Response.pm, может в нём как то добавить? Ссылка: http://www.xxx.ru/?p=text&set=16, с неё нужно сделать редирект на xx1.xxx.ru

Содержимое файла Response.pm:

package Core::Response;

use strict;

# ------------------------------------------------------------------------------------------------
#
# STATUS constants
#

use constant STATUS_OK => \'200 OK\';
use constant STATUS_MOVED => \'302 Moved\';
use constant STATUS_BAD_REQUEST => \'400 Bad request\';
use constant STATUS_FORBIDDEN => \'403 Forbidden\';
use constant STATUS_NOT_FOUND => \'404 Not Found\';
use constant STATUS_POST_TOO_LARGE => \'413 Request entity too large\';

# ------------------------------------------------------------------------------------------------

sub new
{
my ($class, $cfg) = @_;
my $self = {};
bless $self, ref $class || $class;

$self->{charset} = $cfg->{charset};
$self->{status} = STATUS_OK;
$self->{*******Type} = \'text/html\';
$self->{noCache} = $cfg->{noCache};
$self->{cookie} = undef;

return $self;
}

sub charset
{
my $self = shift;
if (@_) {
$self->{charset} = shift;
}
return $self->{charset};
}

sub status
{
my $self = shift;
if (@_) {
$self->{status} = shift;
}
return $self->{status};
}

sub *******Type
{
my $self = shift;
if (@_) {
$self->{*******Type} = shift;
}
return $self->{*******Type};
}

sub cookie
{
my $self = shift;
if (@_) {
$self->{cookie} = shift;
}
return $self->{cookie};
}

sub _getDate
{
my $time = shift;

my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;

my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
$WDAY[$wday],$mday,$MON[$mon],$year+1900,$hour,$min,$sec);
}

sub headerOut
{
my ($self, $status, @other) = @_;
$status ||= $self->{status};

my @header = ();
my $date = _getDate(time());

if ($ENV{PERLXS} eq \'PerlIS\')
{
my $protocol = \'HTTP/1.1\';
push @header, "$protocol $status";
push @header, "Date: $date";
push @header, "Server: $ENV{SERVER_SOFTWARE}";
}
else
{
push @header, "Status: $status";
}

if ($self->{noCache}) {
push @header, "Pragma: no-cache";
push @header, "Cache-control: no-cache";
push @header, "Expires: $date";
}

push @header, "Set-Cookie: ".$self->{cookie} if $self->{cookie};

if (scalar @other) {
push @header, @other;
}
push @header, "*******-Type: ".$self->{*******Type}.
($self->{charset} ? "; charset=".$self->{charset} : \'\');
print join("\\r\\n", @header, "\\r\\n");
}



sub redirect
{
my ($self, $********) = @_;
$self->headerOut(STATUS_MOVED, "********: ".$********);
print "

Document Moved

";
}

1;