Revision ad9563c8
Von Moritz Bunkus vor mehr als 14 Jahren hinzugefügt
| SL/Form.pm | ||
|---|---|---|
| 54 | 54 |
use SL::Template; |
| 55 | 55 |
use SL::User; |
| 56 | 56 |
use Template; |
| 57 |
use URI; |
|
| 57 | 58 |
use List::Util qw(first max min sum); |
| 58 | 59 |
use List::MoreUtils qw(any); |
| 59 | 60 |
|
| ... | ... | |
| 534 | 535 |
$main::lxdebug->leave_sub(); |
| 535 | 536 |
} |
| 536 | 537 |
|
| 538 |
sub _get_request_uri {
|
|
| 539 |
my $self = shift; |
|
| 540 |
|
|
| 541 |
return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
|
|
| 542 |
|
|
| 543 |
my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
|
|
| 544 |
my $port = $ENV{SERVER_PORT} || '';
|
|
| 545 |
$port = undef if (($scheme eq 'http' ) && ($port == 80)) |
|
| 546 |
|| (($scheme eq 'https') && ($port == 443)); |
|
| 547 |
|
|
| 548 |
my $uri = URI->new("${scheme}://");
|
|
| 549 |
$uri->scheme($scheme); |
|
| 550 |
$uri->port($port); |
|
| 551 |
$uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
|
|
| 552 |
$uri->path_query($ENV{REQUEST_URI});
|
|
| 553 |
$uri->query('');
|
|
| 554 |
|
|
| 555 |
return $uri; |
|
| 556 |
} |
|
| 557 |
|
|
| 537 | 558 |
sub create_http_response {
|
| 538 | 559 |
$main::lxdebug->enter_sub(); |
| 539 | 560 |
|
| ... | ... | |
| 543 | 564 |
my $cgi = $main::cgi; |
| 544 | 565 |
$cgi ||= CGI->new('');
|
| 545 | 566 |
|
| 546 |
my $base_path; |
|
| 547 |
|
|
| 548 |
if ($ENV{HTTP_X_FORWARDED_FOR}) {
|
|
| 549 |
$base_path = $ENV{HTTP_REFERER};
|
|
| 550 |
$base_path =~ s|^.*?://.*?/|/|; |
|
| 551 |
} else {
|
|
| 552 |
$base_path = $ENV{REQUEST_URI};
|
|
| 553 |
} |
|
| 554 |
$base_path =~ s|[^/]+$||; |
|
| 555 |
$base_path =~ s|/$||; |
|
| 556 |
|
|
| 557 | 567 |
my $session_cookie; |
| 558 | 568 |
if (defined $main::auth) {
|
| 559 | 569 |
my $session_cookie_value = $main::auth->get_session_id(); |
| ... | ... | |
| 561 | 571 |
|
| 562 | 572 |
$session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
|
| 563 | 573 |
'-value' => $session_cookie_value, |
| 564 |
'-path' => $base_path,
|
|
| 574 |
'-path' => $self->_get_request_uri->path,
|
|
| 565 | 575 |
'-secure' => $ENV{HTTPS});
|
| 566 | 576 |
} |
| 567 | 577 |
|
| ... | ... | |
| 714 | 724 |
return $output; |
| 715 | 725 |
} |
| 716 | 726 |
|
| 727 |
sub redirect_header {
|
|
| 728 |
my $self = shift; |
|
| 729 |
my $new_url = shift; |
|
| 730 |
|
|
| 731 |
my $base_uri = $self->_get_request_uri; |
|
| 732 |
my $new_uri = URI->new_abs($new_url, $base_uri); |
|
| 733 |
|
|
| 734 |
die "Headers already sent" if $::self->{header};
|
|
| 735 |
$self->{header} = 1;
|
|
| 736 |
|
|
| 737 |
my $cgi = $main::cgi || CGI->new('');
|
|
| 738 |
return $cgi->redirect($new_uri); |
|
| 739 |
} |
|
| 740 |
|
|
| 717 | 741 |
sub _prepare_html_template {
|
| 718 | 742 |
$main::lxdebug->enter_sub(); |
| 719 | 743 |
|
| ... | ... | |
| 3549 | 3573 |
special behaviour for empty strings in customerinitnumber field: |
| 3550 | 3574 |
will in this case not increase the value, and return undef. |
| 3551 | 3575 |
|
| 3576 |
=item redirect_header $url |
|
| 3577 |
|
|
| 3578 |
Generates a HTTP redirection header for the new C<$url>. Constructs an |
|
| 3579 |
absolute URL including scheme, host name and port. If C<$url> is a |
|
| 3580 |
relative URL then it is considered relative to Lx-Office base URL. |
|
| 3581 |
|
|
| 3582 |
This function C<die>s if headers have already been created with |
|
| 3583 |
C<$::form-E<gt>header>. |
|
| 3584 |
|
|
| 3585 |
Examples: |
|
| 3586 |
|
|
| 3587 |
print $::form->redirect_header('oe.pl?action=edit&id=1234');
|
|
| 3588 |
print $::form->redirect_header('http://www.lx-office.org/');
|
|
| 3589 |
|
|
| 3552 | 3590 |
=back |
| 3553 | 3591 |
|
| 3554 | 3592 |
=cut |
Auch abrufbar als: Unified diff
Eine Funktion zum Erzeugen von HTTP-Redirect-Headern implementiert.