View | Details | Raw Unified | Return to bug 39980
Collapse All | Expand All

(-)a/Koha/App/Controller/CGI.pm (+96 lines)
Line 0 Link Here
1
package Koha::App::Controller::CGI;
2
3
use Mojo::Base 'Mojolicious::Controller';
4
5
use CGI::Compile;
6
use CGI::Emulate::PSGI;
7
use CGI;
8
9
# CGI::Compile calls CGI::initialize_globals before each request, which resets PARAM_UTF8 to 0
10
# We need to set it back to the correct value
11
{
12
    no warnings 'redefine';
13
    my $old_new = \&CGI::new;
14
    *CGI::new = sub {
15
        $CGI::PARAM_UTF8 = 1;
16
        return $old_new->(@_);
17
    };
18
}
19
20
sub intranet {
21
    my ($c) = @_;
22
23
    my $script = $c->stash('script');
24
25
    # Special case for installer which can takes a long time
26
    $c->inactivity_timeout(300) if $script eq 'installer/install.pl';
27
28
    $c->_render_script($script);
29
}
30
31
sub opac {
32
    my ($c) = @_;
33
34
    my $script = $c->stash('script');
35
    $script = "opac/$script";
36
37
    $c->_render_script($script);
38
}
39
40
sub _render_script {
41
    my ($c, $script) = @_;
42
43
    # Remove trailing slash, if any (e.g. .../svc/config/systempreferences/)
44
    $script =~ s|/$||;
45
46
    unless ( -e $c->app->home->rel_file($script) ) {
47
        return $c->reply->not_found;
48
    }
49
50
    my $sub      = CGI::Compile->compile($script);
51
    my $app      = CGI::Emulate::PSGI->handler($sub);
52
    my $response = $app->( $c->_psgi_env() );
53
54
    $c->res->code( $response->[0] );
55
    $c->res->headers->from_hash( { @{ $response->[1] } } );
56
    $c->res->body( join( '', @{ $response->[2] } ) );
57
    $c->rendered;
58
}
59
60
sub _psgi_env {
61
    my ($c) = @_;
62
63
    my $env = $c->req->env;
64
65
    my $body = $c->req->build_body;
66
    open my $input, '<', \$body or die "Can't open in-memory scalar: $!";
67
    $env = {
68
        %$env,
69
        'psgi.input'    => $input,
70
        'psgi.errors'   => *STDERR,
71
        REQUEST_METHOD  => $c->req->method,
72
        QUERY_STRING    => $c->req->url->query->to_string,
73
        SERVER_NAME     => $c->req->url->to_abs->host,
74
        SERVER_PORT     => $c->req->url->to_abs->port,
75
        SERVER_PROTOCOL => 'HTTP/1.1',
76
        CONTENT_LENGTH  => $c->req->headers->content_length,
77
        CONTENT_TYPE    => $c->req->headers->content_type,
78
        REMOTE_ADDR     => $c->tx->remote_address,
79
        SCRIPT_NAME     => $c->req->url->path->to_string,
80
    };
81
82
    # Starman sets PATH_INFO to the same value of SCRIPT_NAME, which confuses
83
    # CGI and causes the redirect after OPAC login to fail
84
    delete $env->{PATH_INFO} if ( $env->{PATH_INFO} && $env->{PATH_INFO} eq $env->{SCRIPT_NAME} );
85
86
    for my $name ( @{ $c->req->headers->names } ) {
87
        my $value = $c->req->headers->header($name);
88
        $name =~ s/-/_/g;
89
        $name = 'HTTP_' . uc($name);
90
        $env->{$name} = $value;
91
    }
92
93
    return $env;
94
}
95
96
1;
(-)a/Koha/App/Intranet.pm (-4 / +7 lines)
Lines 21-26 use Modern::Perl; Link Here
21
21
22
use Mojo::Base 'Mojolicious';
22
use Mojo::Base 'Mojolicious';
23
23
24
use CGI::Compile; # This module needs to be loaded early; do not remove
25
24
use Koha::Caches;
26
use Koha::Caches;
25
use Koha::Cache::Memory::Lite;
27
use Koha::Cache::Memory::Lite;
26
28
Lines 29-38 sub startup { Link Here
29
31
30
    push @{ $self->plugins->namespaces }, 'Koha::App::Plugin';
32
    push @{ $self->plugins->namespaces }, 'Koha::App::Plugin';
31
    push @{ $self->static->paths },       $self->home->rel_file('koha-tmpl');
33
    push @{ $self->static->paths },       $self->home->rel_file('koha-tmpl');
32
34
    $self->routes->namespaces( ['Koha::App::Controller'] );
33
    # Create route for all CGI scripts, need to be loaded first because of
34
    # CGI::Compile
35
    $self->plugin('CGIBinKoha');
36
35
37
    # Create routes for API
36
    # Create routes for API
38
    $self->plugin('RESTV1');
37
    $self->plugin('RESTV1');
Lines 45-50 sub startup { Link Here
45
44
46
    my $r = $self->routes;
45
    my $r = $self->routes;
47
46
47
    $r->any('/cgi-bin/koha/acquisition/vendors')->to('CGI#intranet', { script => 'acqui/vendors.pl' });
48
    $r->any('/cgi-bin/koha/acquisition/vendors/*')->to('CGI#intranet', { script => 'acqui/vendors.pl' });
49
    $r->any('/cgi-bin/koha/*script')->to('CGI#intranet')->name('cgi');
50
48
    $r->any('/')->to( cb => sub { shift->redirect_to('/cgi-bin/koha/mainpage.pl') } );
51
    $r->any('/')->to( cb => sub { shift->redirect_to('/cgi-bin/koha/mainpage.pl') } );
49
}
52
}
50
53
(-)a/Koha/App/Opac.pm (-4 / +5 lines)
Lines 21-26 use Modern::Perl; Link Here
21
21
22
use Mojo::Base 'Mojolicious';
22
use Mojo::Base 'Mojolicious';
23
23
24
use CGI::Compile; # This module needs to be loaded early; do not remove
25
24
use Koha::Caches;
26
use Koha::Caches;
25
use Koha::Cache::Memory::Lite;
27
use Koha::Cache::Memory::Lite;
26
28
Lines 29-38 sub startup { Link Here
29
31
30
    push @{ $self->plugins->namespaces }, 'Koha::App::Plugin';
32
    push @{ $self->plugins->namespaces }, 'Koha::App::Plugin';
31
    push @{ $self->static->paths },       $self->home->rel_file('koha-tmpl');
33
    push @{ $self->static->paths },       $self->home->rel_file('koha-tmpl');
32
34
    $self->routes->namespaces( ['Koha::App::Controller'] );
33
    # Create route for all CGI scripts, need to be loaded first because of
34
    # CGI::Compile
35
    $self->plugin( 'CGIBinKoha', opac => 1 );
36
35
37
    # Create routes for API
36
    # Create routes for API
38
    $self->plugin('RESTV1');
37
    $self->plugin('RESTV1');
Lines 45-50 sub startup { Link Here
45
44
46
    my $r = $self->routes;
45
    my $r = $self->routes;
47
46
47
    $r->any('/cgi-bin/koha/*script')->to('CGI#opac')->name('cgi');
48
48
    $r->any('/')->to( cb => sub { shift->redirect_to('/cgi-bin/koha/opac-main.pl') } );
49
    $r->any('/')->to( cb => sub { shift->redirect_to('/cgi-bin/koha/opac-main.pl') } );
49
}
50
}
50
51
(-)a/Koha/App/Plugin/CGIBinKoha.pm (-133 lines)
Lines 1-132 Link Here
1
package Koha::App::Plugin::CGIBinKoha;
2
3
# Copyright 2020 BibLibre
4
#
5
# This file is part of Koha.
6
#
7
# Koha is free software; you can redistribute it and/or modify it
8
# under the terms of the GNU General Public License as published by
9
# the Free Software Foundation; either version 3 of the License, or
10
# (at your option) any later version.
11
#
12
# Koha is distributed in the hope that it will be useful, but
13
# WITHOUT ANY WARRANTY; without even the implied warranty of
14
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15
# GNU General Public License for more details.
16
#
17
# You should have received a copy of the GNU General Public License
18
# along with Koha; if not, see <http://www.gnu.org/licenses>.
19
20
use Modern::Perl;
21
22
use Mojo::Base 'Mojolicious::Plugin';
23
24
use CGI;
25
use CGI::Compile;
26
use CGI::Emulate::PSGI;
27
28
sub register {
29
    my ( $self, $app, $conf ) = @_;
30
31
    # CGI::Compile calls CGI::initialize_globals before each request, which resets PARAM_UTF8 to 0
32
    # We need to set it back to the correct value
33
    {
34
        no warnings 'redefine';
35
        my $old_new = \&CGI::new;
36
        *CGI::new = sub {
37
            $CGI::PARAM_UTF8 = 1;
38
            return $old_new->(@_);
39
        };
40
    }
41
42
    my $opac = $conf->{opac};
43
44
    my $r = $app->routes;
45
46
    $r->any(
47
        '/cgi-bin/koha/*script' => sub {
48
            my ($c) = @_;
49
50
            my $script = $c->stash('script');
51
52
            # Special case for installer which can takes a long time
53
            $c->inactivity_timeout(300) if $script eq 'installer/install.pl';
54
55
            # Remove trailing slash, if any (e.g. .../svc/config/systempreferences/)
56
            $script =~ s|/$||;
57
58
            if ($opac) {
59
                $script = "opac/$script";
60
            }
61
62
            unless ( -e $c->app->home->rel_file($script) ) {
63
                return $c->reply->not_found;
64
            }
65
66
            my $sub      = CGI::Compile->compile($script);
67
            my $app      = CGI::Emulate::PSGI->handler($sub);
68
            my $response = $app->( $self->_psgi_env($c) );
69
70
            $c->res->code( $response->[0] );
71
            $c->res->headers->from_hash( { @{ $response->[1] } } );
72
            $c->res->body( join( '', @{ $response->[2] } ) );
73
            $c->rendered;
74
        }
75
    )->name('cgi');
76
}
77
78
sub _psgi_env {
79
    my ( $self, $c ) = @_;
80
81
    my $env = $c->req->env;
82
83
    my $body = $c->req->build_body;
84
    open my $input, '<', \$body or die "Can't open in-memory scalar: $!";
85
    $env = {
86
        %$env,
87
        'psgi.input'    => $input,
88
        'psgi.errors'   => *STDERR,
89
        REQUEST_METHOD  => $c->req->method,
90
        QUERY_STRING    => $c->req->url->query->to_string,
91
        SERVER_NAME     => $c->req->url->to_abs->host,
92
        SERVER_PORT     => $c->req->url->to_abs->port,
93
        SERVER_PROTOCOL => 'HTTP/1.1',
94
        CONTENT_LENGTH  => $c->req->headers->content_length,
95
        CONTENT_TYPE    => $c->req->headers->content_type,
96
        REMOTE_ADDR     => $c->tx->remote_address,
97
        SCRIPT_NAME     => $c->req->url->path->to_string,
98
    };
99
100
    # Starman sets PATH_INFO to the same value of SCRIPT_NAME, which confuses
101
    # CGI and causes the redirect after OPAC login to fail
102
    delete $env->{PATH_INFO} if ( $env->{PATH_INFO} && $env->{PATH_INFO} eq $env->{SCRIPT_NAME} );
103
104
    for my $name ( @{ $c->req->headers->names } ) {
105
        my $value = $c->req->headers->header($name);
106
        $name =~ s/-/_/g;
107
        $name = 'HTTP_' . uc($name);
108
        $env->{$name} = $value;
109
    }
110
111
    return $env;
112
}
113
114
1;
115
116
=encoding utf8
117
118
=head1 NAME
119
120
Koha::App::Plugin::CGIBinKoha
121
122
=head1 DESCRIPTION
123
124
Koha App Plugin used to wrap Koha CGI scripts for backwards compatibility whilst we migrate from CGI to using the Mojolicious Web Application Framework.
125
126
=head1 METHODS
127
128
=head2 register
129
130
Called at application startup; Sets up a catch-all router to identify CGI scripts and loads the found script using CGI::Compile before running it under CGI::Emulate::PSGI.
131
132
=cut
133
- 

Return to bug 39980