💾 Archived View for h2903872.stratoserver.net › GGI › GGI.pm captured on 2022-04-28 at 17:33:28.
⬅️ Previous capture (2021-12-02)
-=-=-=-=-=-=-
package GGI;
#require Exporter;
#@ISA=qw(Exporter);
#@EXPORT=qw();
use strict;
use warnings;
no warnings qw(uninitialized); # avoid warnings for undefined/NULL values!
use utf8::all;
#use URL::Encode;
use Encode;
use URI::Escape;
=encoding utf8
=head1 GGI
GGI.pm - Gemini Gateway Interface: Support perl-programs on Gemini servers.
=head1 SUMMARY
GGI handles the accumulation of multiple parameters in the path-component of the URL through
automatic redirects and offers a simple method to access those parameters from the perl program.
GGI supports the generation of all Gemini line types: responses, headers, text, quotes, links
and pre-formatted, as well as some convenient methods to generate menus and to print tables with
and without ASCII or UniCode frames.
More about the Gemini protocol: L<https://gemini.circumlunar.space/>
=head1 VERSION
GGI.pm Version from 2021-03-26
=head1 AUTHORS
GGI by Frank Jüdes, L<http://www.linux4specialists.com>
This pod text by Frank Jüdes, Perl by Larry Wall and the C<perl5-porters>.
=head1 COPYRIGHT
The GGI module is Copyright (c) 2021 Frank Jüdes, West Virginia, U.S.A.
All rights reserved.
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl 5.10.0 README file.
=head1 SUPPORT and WARRANTY
The GGI is free Open Source software. IT COMES WITHOUT WARRANTY OF ANY KIND.
=head1 EXAMPLES
=head2 Make the output of the I<ps> utility available through a Gemini server
#!/bin/perl
use warnings;
use strict;
use utf8::all;
use GGI;
my $ggi = new GGI; # Create a new GGI object and print SUCCESS header
$ggi->H1('ps test'); # Print a header
my @output=`ps -fA`; # Run ps and catch all the output
chomp @output; # Remove EOLs
$ggi->Pre(@output); # Print the output as preformatted text
=head2 Collect Parameters into the PATH＿INFO variable
#!/bin/perl
use warnings;
use strict;
use utf8::all;
use GGI;
my $ggi = GGI->new(1); # New GGI object without writing any header
if (not defined $ggi->Param) { # No parameter present: Get the amount of parameters wanted
$ggi->ResponseHeader('INPUT',qq(GGI-Test, ParamTest: How many parameters do you want to test?));
} # END if
my $Current = $ggi->Param+1; # How many parameters are there
my $Wanted = $ggi->Param(0); # How many parameters are wanted?
if ($Current <= $Wanted) { # Get the next parameter
$ggi->ResponseHeader('INPUT',qq(GGI-Test, Paramtest: Please enter a value for Parameter $Current of $Wanted));
} # END if
# Done with parameters! - Main program
$ggi->H1("Hello World!");
if (defined $ggi->Param) {
$ggi->H2("The parameters");
$ggi->List(@{$ggi->Param('*')});
} else {
$ggi->H1("No Parameters.");
} # END if
$ggi->Link(qq(gemini://h2903872.stratoserver.net/ Go back to the server's home.));
=head2 Implemented methods
The following paragraphs explain the implemented methods of this package in great detail.
=cut
#----------------------------------------------------------------------------------------------------
=head3 new([NoPrintHeader]
Create a new GGI object:
=over 2
=item * A new object is created, some internal variables initialized.
=item * If there is a parameter at the end of the URL, the value is added as a path-component and
a re-direct to the new URL is sent to the client.
=item * If there is no parameter attached to the URL, all parameters are being copied
from the PATH_INFO into the internal PARAMS array.
=item * If called without any parameters an OK response-header will be printed automatically and the function
will return to the main program. If any TRUE value as parameter is passed, no header will be printed at
all and it is the duty of the calling program to print a Gemini response-header if other than SUCCESS
should be printed.
=back
=cut
sub new {
my ($Class,$NoPrintHeader) = @_;
my $self = {};
bless $self,$Class;
$self->{HeaderHasBeenSent} = 0;
$self->{ResponseStatus} = {'INPUT' => 10,
'SENSITIVE_INPUT' => 11,
'SUCCESS' => 20,
'REDIRECT_TEMPORARY' => 30,
'REDIRECT_PERMANENT' => 31,
'FAILURE_TEMPORARY' => 40,
'SERVER_UNAVAILABLE' => 41,
'CGI_ERROR' => 42,
'PROXY_ERROR' => 43,
'SLOW_DOWN' => 44,
'FAILURE_PERMANENT' => 50,
'NOT_FOUND' => 51,
'PROXY_REQUEST_REFUSED' => 52,
'BAD_REQUEST' => 53,
'CLIENT_CERTIFICATE_REQUIRED' => 60,
'CERTIFICATE_NOT_AUTHORIZED' => 61,
'CERTIFICATE_NOT_VALID' => 62
};
# ********** This is the gemini-server dependend HACKING SECTION **********
# First: Some servers store the PATH_INFO with a leading "/", some other's don't.
# So let's remove the leading "/" if it exists:
if ((length($ENV{PATH_INFO}) > 0) and (substr($ENV{PATH_INFO},0,1) eq '/')) {
$ENV{PATH_INFO} = substr($ENV{PATH_INFO},1);
} # END if
# Second: Some servers store the QUERY_STRING with a leading "?", some other's don't.
# So let's remove the leading "?" if it exists:
if ((length($ENV{QUERY_STRING}) > 0) and (substr($ENV{QUERY_STRING},0,1) eq '?')) {
$ENV{QUERY_STRING} = substr($ENV{QUERY_STRING},1);
} # END if
# Third: Missing CGI variables in the Molly-Brown server!
# The jetforce-server sets the variables SCRIPT_NAME and GEMINI_URL correctly, the Molly-Brown server does not.
# This makes the awful hack below necessary‼
# WARNING: This will only work if the CGI-program is located in /cgi-bin ‼
# Unless the CGI-variable SCRIPT_NAME is provided by the Molly-Brown-server, this is the only way to
# automate the parameter redirection and provide something like the GEMINI_URL
if ((not defined $ENV{SCRIPT_NAME}) and (defined $ENV{SCRIPT_PATH})) {
my ($ScriptName) = $ENV{SCRIPT_PATH} =~ m!(/cgi-bin/.*)!;
$ENV{SCRIPT_NAME} = $ScriptName;
$ENV{GEMINI_URL} = "gemini://$ENV{SERVER_NAME}${ScriptName}";
$ENV{GEMINI_URL} .= "/" . $ENV{PATH_INFO} if (length($ENV{PATH_INFO}) > 0);
$ENV{GEMINI_URL} .= "?" . $ENV{QUERY_STRING} if (length($ENV{QUERY_STRING}) > 0);
} # END if
# Handle parameters
if (length($ENV{QUERY_STRING}) > 0) {
# There is a parameter in the URL, so add parameter-value to the path, print redirect header and end the program
my $URL = $ENV{GEMINI_URL};
$URL =~ s/\?/\//;
$self->ResponseHeader('REDIRECT_TEMPORARY',$URL);
exit 0; # END program and let the clinet execute re-direct.
} else { # analyze PATH_INFO and extract parameters
if (length($ENV{PATH_INFO}) > 0) {
my $PathInfo = $ENV{PATH_INFO};
# $PathInfo =~ s/%([0-9,A-F]{2})/'chr(0x'. $1. ')'/eeg; # URL-Decoding
# $self->{PARAMS} = [split('/',$PathInfo)]; # split the parameters
# my $DecodedPathInfo = URL::Encode::url_decode_utf8($PathInfo);
# $self->{PARAMS} = [split('/',$DecodedPathInfo)]; # split the parameters
my $DecodedPathInfo = Encode::decode('utf8',uri_unescape($PathInfo));
$self->{PARAMS} = [split('/',$DecodedPathInfo)]; # split the parameters
} # END if
} # END if
$self->ResponseHeader('SUCCESS') unless (defined $NoPrintHeader); # print an OK header by default
return $self;
} # END new
#----------------------------------------------------------------------------------------------------
=head3 BaseURL
Returns the current request URL without the parameters
=cut
sub BaseURL {
return substr($ENV{GEMINI_URL},0,-length($ENV{PATH_INFO}));
} # END BaseURL
#----------------------------------------------------------------------------------------------------
=head3 MyURL
Returns the current request URL - Basically a shortcut for $ENV{GEMINI_URL}.
=cut
sub MyURL {
return $ENV{GEMINI_URL};
} # END MyURL
#----------------------------------------------------------------------------------------------------
=head3 ServerName
Returns the current request's servername - Basically a shortcut for $ENV{SERVER_NAME}.
=cut
sub ServerName {
return $ENV{SERVER_NAME};
} # END ServerName
#----------------------------------------------------------------------------------------------------
=head3 ScriptName
Returns the current request's script-name - Basically a shortcut for $ENV{SCRIPT_NAME}.
=cut
sub ScriptName {
return $ENV{SCRIPT_NAME};
} # END ScriptName
#----------------------------------------------------------------------------------------------------
=head3 WashParameter
Removes potentialy dangerous stuff from the parameters, currently for Linux
=over 2
=item * Everything attached with a ";" at the end, including the ";" is removed
=item * Everything between backticks "`", including the back-ticks themselves, is removed
=item * Everything in '$( )' is removed, including the $-sign and the parentheses
=back
=cut
sub WashParameter {
my $self = shift @_;
return unless (defined $self->{PARAMS});
map {
$_ =~ s/;.*$//; # no command attachment
$_ =~ s/\`.*\`//; # no command insertion
$_ =~ s/\$\(.*?\)//; # no bash exec
} @{$self->{PARAMS}};
} # END WashParameter
#----------------------------------------------------------------------------------------------------
=head3 param([Name])
Access to the GGI-parameters:
=over 2
=item * If there are no GGI parameters present, undef is returned.
=item * Called without an index-value in array-mode, a reference to the parameter-array is returned.
=item * Called without an index-value in scalar-mode the highes index into the parameter array is returned.
=item * Called with the index-value of "#", the numer of parameters is returned.
=item * Called with the index-value of "*", a reference to the parameter-array is returned.
=item * Called with an index-value the value of the indexed parameter is returned if it exists.
If no parameter with the given index exists, I<undef> is returned.
=back
=cut
sub Param {
my ($self,$Index) = @_;
return undef unless (defined $self->{PARAMS});
if (not defined $Index) {
return $self->{PARAMS} if (wantarray);
return $#{$self->{PARAMS}};
} # END if
return scalar @{$self->{PARAMS}} if ($Index eq '#');
return $self->{PARAMS} if ($Index eq '*');
return $self->{PARAMS}->[$Index];
} # END param
#----------------------------------------------------------------------------------------------------
# pr(@Lines) (internal)
#
# Print an array of lines with CR/LF at the end
#----------------------------------------------------------------------------------------------------
sub pr {
my ($self,@Lines) = @_;
map { print "$_\r\n"; } @Lines # causing double spacing in some clients
#map { print "$_\n"; } @Lines
} # END pr
#----------------------------------------------------------------------------------------------------
=head3 print(@Lines)
Print an array of lines with CR/LF at the end
=cut
sub print {
my ($self,@Lines) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
$self->pr(@Lines);
} # END print
#----------------------------------------------------------------------------------------------------
=head3 ResponseHeader(StatusCode[,Meta])
Print the response header with the meta-information, if present. The following response status-codes
are defined, according to the Gemini protocol documentation:
- INPUT, SENSITIVE_INPUT
- SUCCESS
- REDIRECT_TEMPORARY, REDIRECT_PERMANENT
- FAILURE_TEMPORARY, SERVER_UNAVAILABLE, CGI_ERROR, PROXY_ERROR, SLOW_DOWN
- FAILURE_PERMANENT, NOT_FOUND, PROXY_REQUEST_REFUSED, BAD_REQUEST
- CLIENT_CERTIFICATE_REQUIRED, CERTIFICATE_NOT_AUTHORIZED, CERTIFICATE_NOT_VALID
=cut
sub ResponseHeader {
my ($self,$StatusCode,$Message) = @_;
return if ($self->{HeaderHasBeenSent});
$StatusCode = 'SUCCESS' unless (defined $StatusCode);
if ($StatusCode eq 'SUCCESS') {
$self->pr("20 text/gemini");
$self->{HeaderHasBeenSent} = 1;
} else {
if (exists $self->{ResponseStatus}->{$StatusCode}) {
$self->pr($self->{ResponseStatus}->{$StatusCode} . " $Message");
} else {
$self->pr($self->{ResponseStatus}->{CGI_ERROR} . " Unknown Response code '$StatusCode'.");
} # END if
exit(0);
} # END if
} # END ResponseHeader
#----------------------------------------------------------------------------------------------------
=head3 Input(HeaderText)
Print an Input response header with prompt. This is basically a shortcut for I<ResponseHeader('INPUT',[Prompttext]);>
=cut
sub Input {
my ($self,$Prompt) = @_;
$self->ResponseHeader('INPUT',$Prompt);
} # END Input
#----------------------------------------------------------------------------------------------------
=head3 H[1-3](HeaderText)
Print headerline 1-3
=cut
sub H1 {
my ($self,$Line) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
$self->pr("# $Line");
} # END H1
sub H2 {
my ($self,$Line) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
$self->pr("## $Line");
} # END H2
sub H3 {
my ($self,$Line) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
$self->pr("### $Line");
} # END H3
#----------------------------------------------------------------------------------------------------
=head3 Pre(@Lines)
Print an array of lines as a preformatted block
=cut
sub Pre {
my ($self,@Lines) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
$self->pr('```');
map { print $_,"\n"; } @Lines;
$self->pr('```');
} # END Pre
#----------------------------------------------------------------------------------------------------
#----------------------------------------------------------------------------------------------------
=head3 LabeledPre(Label,@Lines)
Print an array of lines as a labeled preformatted block
=cut
sub LabeledPre {
my ($self,$Label,@Lines) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
$self->pr('``` ' . $Label);
map { print $_,"\n"; } @Lines;
$self->pr('```');
} # END Pre
#----------------------------------------------------------------------------------------------------
=head3 List(@Lines)
Print an array of lines as an unsorted list.
=cut
sub List {
my ($self,@Lines) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
map { $self->pr('* ' . $_) } @Lines;
} # END List
#----------------------------------------------------------------------------------------------------
=head3 Link(@Lines)
Print an array of lines as links
=cut
sub Link {
my ($self,@Lines) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
map { $self->pr('=> ' . $_) } @Lines;
} # END Link
#----------------------------------------------------------------------------------------------------
=head3 Quote(@Lines)
Print an array of lines as quotes
=cut
sub Quote {
my ($self,@Lines) = @_;
$self->ResponseHeader('SUCCESS') unless ($self->{HeaderHasBeenSent}); # send header if necessary
map { $self->pr('> ' . $_) } @Lines;
} # END Link
#----------------------------------------------------------------------------------------------------
=head3 PrintMenu(Menu,BaseURL,Title,Description)
Print the value of I<Title> as an H1-title if defined. Then print
the content of the I<Description> below if defined, followed by the link-menu itself.
I<Menu> is a simple perl-hash with the prompts as keys and the values as content.
These values will be appended to the I<BaseURL> as link-targets and the keys
will become the link d