You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

89 lines
2.3 KiB

#!/usr/bin/perl
# Copyright René Wagner 2020
# licenced under BSD 3-Clause licence
# https://src.clttr.info/rwa/gemini-perl-cgi
use strict;
# define return codes
# only to enhance readabilty for the coder
our %RC = (
'INPUT', 10,
'SENSITIVE_INPUT', 11,
'SUCCESS', 20,
'TEMPORARY_REDIRECT', 30,
'PERMANENT_REDIRECT', 31,
'TEMPORARY_FAILURE', 40,
'SERVER_UNAVAILABLE', 41,
'CGI_ERROR', 42,
'PROXY_ERROR', 43,
'SLOW_DOWN', 44,
'PERMANENT_FAILURE', 50,
'NOT_FOUND', 51,
'GONE', 52,
'PROXY_REQUEST_REFUSE', 53,
'BAD_REQUEST', 59,
'CLIENT_CERT_REQUIRED', 60,
'CERT_NOT_AUTHORISED', 61,
'CERT_NOT_VALID', 62
);
# enable UTF-8 mode for everything
use utf8;
binmode STDOUT, ':utf8';
binmode STDERR, ':utf8';
# check if we run in a gemini cgi env
if (!defined($ENV{'SERVER_PROTOCOL'}) || $ENV{'SERVER_PROTOCOL'} ne 'GEMINI') {
write_response('CGI_ERROR', 'CGI execution error', undef);
}
write_response('SUCCESS', 'text/gemini', create_response());
exit;
sub create_response
{
my @body;
# create a array and add all lines to it
push @body, '# gmni Perl CGI demo';
push @body, '';
push @body, 'Welcome to the gmni Perl CGI Demo! 🖒 ';
push @body, 'The server successfully executed a perl script as a cgi ressource.';
push @body, '';
push @body, '## more demos on this capsule';
push @body, '=> gemini://gmndemo.clttr.info/faq/ gmnifaq demo';
push @body, '=> gemini://gmndemo.clttr.info/server.pl server stats';
push @body, '';
push @body, '=> https://src.clttr.info/rwa/gemini-perl-cgi The source of this demos can be found on src.clttr.info';
push @body, '';
push @body, '## CGI query info';
push @body, '```';
# write all known environment variables to stdout
my @keys = qw/GATEWAY_INTERFACE SERVER_PROTOCOL SERVER_SOFTWARE GEMINI_URL SCRIPT_NAME PATH_INFO QUERY_STRING SERVER_NAME SERVER_PORT REMOTE_HOST TLS_CIPHER TLS_VERSION/;
foreach (@keys)
{
push @body, "$_=$ENV{$_}";
}
push @body, '```';
return @body;
}
sub write_response
{
my ($returncode, $mime, @content) = @_;
if (!defined($RC{$returncode})) { die "Unknown response code!"; }
# send return message and page content to stdout
print("$RC{$returncode} $mime\r\n");
foreach (@content)
{
print("$_\r\n");
}
exit;
}