๐พ Archived View for h2903872.stratoserver.net โบ GGI โบ GGI.pm captured on 2021-12-02 at 18:33:58.
โก๏ธ Next capture (2022-04-28)
-=-=-=-=-=-=-
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 description-texts.
=cut
sub PrintMenu {
my ($self,$Menu,$BaseURL,$Title,$Description) = @_;
$self->H1($Title) if (defined $Title);
$self->pr($Description) if (defined $Description);
my @Links;
map { push (@Links,"$BaseURL/$Menu{$_} $_") } sort keys %$Menu;
$self->Link(@Links);
} # END PrintMenu
#----------------------------------------------------------------------------------------------------
=head3 PrintTable(Table,FrameType,Header,Summary,Compact)
Print the content of a two-dimensional table into a pre-formatted block. The I<Table> parameter
is a reference to a two-dimensional array.
It is vital that all cells of the table are defined and that there are no holes in the table structure!
This code will center the column headers and pad all other table-cells to equal length in their column
with the content left aligned. If you want other formatting, you need to pre-format the content of your table.
Valid values for the FrameType are I<ASCII>, I<SINGLE>, I<DOUBLE>, I<SHADOW>, I<FLOAT> and I<NONE>. Invalid
values will default to I<NONE> and no frames will be printed.
The I<Header> and I<Summary> parameters define weather the first line of the table contains column-headers
and the last line contains a summary and should be separated from the rest of the table with a horizontal line.
With the I<Compact> parameter the output of horizontal lines between the table data-rows can be supressed.
(Compact design).
=cut
sub PrintTable {
my ($self,$Table,$FrameType,$Header,$Summary,$Compact) = @_;
$FrameType = 'NONE' unless (defined $FrameType);
$Header = 'N' unless (defined $Header);
$Summary = 'N' unless (defined $Summary);
$Compact = 'N' unless (defined $Compact);
# Determine the table's dimensions
my $TableRows = @$Table;
my $LastRow = ($TableRows-1);
my $TableCols = @{$Table->[0]};
my @ColumnWidths;
for (my $Row=0; $Row < $TableRows; $Row++) {
for (my $Column=0; $Column < $TableCols; $Column++) {
if (!(defined $ColumnWidths[$Column]) or ($ColumnWidths[$Column] < length($Table->[$Row]->[$Column]))) {
$ColumnWidths[$Column] = length($Table->[$Row]->[$Column]);
} # END if
} # END $Columns
} # END for $row
#DEBUG $self->pr("Rows: $TableRows, Column's: $TableCols");
#DEBUG $self->pr("Colum-Widths: [" . join(",",@ColumnWidths) . "]");
# Format all cells to equal column width, center header-columns
for (my $Row=0; $Row < $TableRows; $Row++) {
for (my $Column=0; $Column < $TableCols; $Column++) {
my $CellWidth = length($Table->[$Row]->[$Column]);
if ($CellWidth < $ColumnWidths[$Column]) {
if (($Row == 0) and ($Header eq 'Y')) {
$Table->[$Row]->[$Column] = substr(' ' x (($ColumnWidths[$Column] - $CellWidth)/2) .
$Table->[$Row]->[$Column] .
' ' x (($ColumnWidths[$Column] - $CellWidth)/2) . ' ',
0,$ColumnWidths[$Column]);
} else {
$Table->[$Row]->[$Column] .= ' ' x ($ColumnWidths[$Column] - $CellWidth);
} # END if
} # END if
} # END $Columns
} # END for $row
# Create the building blocks for the table frames
my ($TopLine,$HeaderLine,$HorizontalLine,$SummaryLine,$BottomLine,$Left,$Middle,$Right);
if ($FrameType eq 'ASCII') {
($Left,$Middle,$Right) = ('|','|','|');
($TopLine,$HeaderLine,$HorizontalLine,$SummaryLine,$BottomLine) = ('+','+','+','+','+');
for (my $Column=0; $Column<$TableCols; $Column++) {
$TopLine .= '-' x $ColumnWidths[$Column] . '+';
$HeaderLine .= '=' x $ColumnWidths[$Column] . '+';
$HorizontalLine .= '-' x $ColumnWidths[$Column] . '+';
$SummaryLine .= '=' x $ColumnWidths[$Column] . '+';
$BottomLine .= '-' x $ColumnWidths[$Column] . '+';
} # END for $Column
} elsif ($FrameType eq 'SINGLE') {
($Left,$Middle,$Right) = ('โ','โ','โ');
($TopLine,$HeaderLine,$HorizontalLine,$SummaryLine,$BottomLine) = ('โญ','โ','โ','โ','โฐ');
for (my $Column=0; $Column<$TableCols; $Column++) {
if ($Column == ($TableCols-1)) {
$TopLine .= 'โ' x $ColumnWidths[$Column] . 'โฎ';
$HeaderLine .= 'โ' x $ColumnWidths[$Column] . 'โค';
$HorizontalLine .= 'โ' x $ColumnWidths[$Column] . 'โค';
$SummaryLine .= 'โ' x $ColumnWidths[$Column] . 'โค';
$BottomLine .= 'โ' x $ColumnWidths[$Column] . 'โฏ';
} else {
$TopLine .= 'โ' x $ColumnWidths[$Column] . 'โฌ';
$HeaderLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$HorizontalLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$SummaryLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$BottomLine .= 'โ' x $ColumnWidths[$Column] . 'โด';
} # END if
} # END for $Column
} elsif ($FrameType eq 'DOUBLE') {
($Left,$Middle,$Right) = ('โ','โ','โ');
($TopLine,$HeaderLine,$HorizontalLine,$SummaryLine,$BottomLine) = ('โ','โ ','โ','โ ','โ');
for (my $Column=0; $Column<$TableCols; $Column++) {
if ($Column == ($TableCols-1)) {
$TopLine .= 'โ' x $ColumnWidths[$Column] . 'โ';
$HeaderLine .= 'โ' x $ColumnWidths[$Column] . 'โฃ';
$HorizontalLine .= 'โ' x $ColumnWidths[$Column] . 'โข';
$SummaryLine .= 'โ' x $ColumnWidths[$Column] . 'โฃ';
$BottomLine .= 'โ' x $ColumnWidths[$Column] . 'โ';
} else {
$TopLine .= 'โ' x $ColumnWidths[$Column] . 'โค';
$HeaderLine .= 'โ' x $ColumnWidths[$Column] . 'โช';
$HorizontalLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$SummaryLine .= 'โ' x $ColumnWidths[$Column] . 'โช';
$BottomLine .= 'โ' x $ColumnWidths[$Column] . 'โง';
} # END if
} # END for $Column
} elsif ($FrameType eq 'SHADOW') {
($Left,$Middle,$Right) = ('โ','โ','โ');
($TopLine,$HeaderLine,$HorizontalLine,$SummaryLine,$BottomLine) = ('โญ','โ','โ','โ','โ');
for (my $Column=0; $Column<$TableCols; $Column++) {
if ($Column == ($TableCols-1)) {
$TopLine .= 'โ' x $ColumnWidths[$Column] . 'โ';
$HeaderLine .= 'โ' x $ColumnWidths[$Column] . 'โข';
$HorizontalLine .= 'โ' x $ColumnWidths[$Column] . 'โข';
$SummaryLine .= 'โ' x $ColumnWidths[$Column] . 'โข';
$BottomLine .= 'โ' x $ColumnWidths[$Column] . 'โ';
} else {
$TopLine .= 'โ' x $ColumnWidths[$Column] . 'โฌ';
$HeaderLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$HorizontalLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$SummaryLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$BottomLine .= 'โ' x $ColumnWidths[$Column] . 'โง';
} # END if
} # END for $Column
} elsif ($FrameType eq 'FLOAT') {
($Left,$Middle,$Right) = ('โ','โ','โ');
($TopLine,$HeaderLine,$HorizontalLine,$SummaryLine,$BottomLine) = ('โ','โ','โ','โ','โ');
for (my $Column=0; $Column<$TableCols; $Column++) {
if ($Column == ($TableCols-1)) {
$TopLine .= 'โ' x $ColumnWidths[$Column] . 'โ';
$HeaderLine .= 'โ' x $ColumnWidths[$Column] . 'โค';
$HorizontalLine .= 'โ' x $ColumnWidths[$Column] . 'โค';
$SummaryLine .= 'โ' x $ColumnWidths[$Column] . 'โค';
$BottomLine .= 'โ' x $ColumnWidths[$Column] . 'โฏ';
} else {
$TopLine .= 'โ' x $ColumnWidths[$Column] . 'โค';
$HeaderLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$HorizontalLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$SummaryLine .= 'โ' x $ColumnWidths[$Column] . 'โผ';
$BottomLine .= 'โ' x $ColumnWidths[$Column] . 'โด';
} # END if
} # END for $Column
} else { # Everything else is equivalent to 'NONE'
$Left = ' ';
$Middle = ' ';
} # END if
my @Output;
push (@Output,$TopLine) if ($FrameType ne 'NONE');
for (my $Row=0; $Row < $TableRows; $Row++) {
push (@Output,$HeaderLine) if (($Row == 1) and ($FrameType ne 'NONE') and ($Header eq 'Y'));
push (@Output,$SummaryLine) if (($Row == $LastRow) and ($FrameType ne 'NONE') and ($Summary eq 'Y'));
push (@Output,$Left . join ($Middle,@{$Table->[$Row]}) . $Right);
push (@Output,$HorizontalLine) if (($FrameType ne 'NONE') and ($Compact eq 'N') and ($Row != $LastRow) and
!(($Header eq 'Y') and ($Row == 0)) and
!(($Summary eq 'Y') and ($Row == $LastRow-1)));
} # END for $row
push (@Output,$BottomLine) if ($FrameType ne 'NONE');
$self->Pre(@Output);
} # END PrintTable
#----------------------------------------------------------------------------------------------------
=head3 PrintHash(Hash,Filler,Colon,Quote)
Print the content of a simple perl-hash or a perl-hash of arrays into a pre-formatted block.
The I<Hash> parameter is a reference to a simple pearl-hash or a pearl-has of one-dimensional arrays.
The hash-keys will be printed, filled to equal length with the value of the I<Filler> character,
followed by the value of the I<Colon> parameter, followed by either the hash-value or a list of values
should the content of the hash be an array.
If the I<Quote> parameter is given, values will be encapulated in this quout character.
=cut
sub PrintHash {
my ($self,$Hash,$Filler,$Colon,$Quote) = @_;
$Filler = '.' unless (defined $Filler);
$Colon = ':' unless (defined $Colon);
$Quote = '"' unless (defined $Quote);
my @Result;
my $MaxKeyLength = 0;
map { $MaxKeyLength = length($_) if ($MaxKeyLength < length($_)) } keys %$Hash;
map {
if (ref($Hash->{$_}) eq 'ARRAY') {
push @Result, $_ . ($Filler x ($MaxKeyLength - length($_))) . $Colon . $Quote . join("$Quote, $Quote",@{$Hash->{$_}}) . $Quote;
} else {
push @Result, $_ . ($Filler x ($MaxKeyLength - length($_))) . $Colon . $Quote . $Hash->{$_} . $Quote;
} # END if
} sort keys %$Hash;
$self->Pre(@Result);
} # END FormatHash
#----------------------------------------------------------------------------------------------------
=head2 Unicode Trickeries
Unicode contains the code-block `Mathematical Alphanumeric Symbols' [U+1D400..U+1D7FF],
containing styled letters and digits that look like normal characters from the latin alphabet,
just styled in bold, italic, script, outline or gothic.
However those characters will not be recognized as ordinary text by most computer programs,
like search engine crawlers for example.
Note that the digits are only available in bold-style.
B<Warning:> This might not be supported by all Gemini clients! Especially terminal-clients
might not have the necessary Unicode characterset installed, it will definitely screw up the
terminal window of the I<amphora> client on windows.
=head3 UC_Bold(String)
Transform the passed string into pseudo-bold Unicode characters.
=cut
sub UC_Bold {
my ($self,$Result) = @_;
$Result =~ tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/๐๐๐๐๐๐๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐ง๐จ๐ฉ๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฏ๐ฐ๐ฑ๐ฒ๐ณ๐๐๐๐๐๐
๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐/;
return $Result;
} # END UC_Bold
#----------------------------------------------------------------------------------------------------
=head3 UC_Italic(String)
Transform the passed string into pseudo-italic Unicode characters.
=cut
sub UC_Italic {
my ($self,$Result) = @_;
$Result =~ tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ/๐ข๐ฃ๐ค๐ฅ๐ฆ๐ง๐จ๐ฉ๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฏ๐ฐ๐ฑ๐ฒ๐ณ๐ด๐ต๐ถ๐ท๐ธ๐น๐บ๐ป๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐ ๐ก/;
return $Result;
} # END UC_Italic
#----------------------------------------------------------------------------------------------------
=head3 UC_BoldItalic(String)
Transform the passed string into pseudo-bold-italic Unicode characters.
=cut
sub UC_BoldItalic {
my ($self,$Result) = @_;
$Result =~ tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ/๐๐๐๐๐๐๐๐๐๐๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐ง๐จ๐ฉ๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฏ๐ผ๐ฝ๐พ๐ฟ๐๐๐๐๐๐
๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐/;
return $Result;
} # END UC_BoldItalic
#----------------------------------------------------------------------------------------------------
=head3 UC_Script(String)
Transform the passed string into pseudo-script Unicode characters.
=cut
sub UC_Script {
my ($self,$Result) = @_;
$Result =~ tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ/๐ถ๐ท๐ธ๐นโฏ๐ปโ๐ฝ๐พ๐ฟ๐๐๐๐โด๐
๐๐๐๐๐๐๐๐๐๐๐โฌ๐๐โฐโฑ๐ขโโ๐ฅ๐ฆโโณ๐ฉ๐ช๐ซ๐ฌโ๐ฎ๐ฏ๐ฐ๐ฑ๐ฒ๐ณ๐ด๐ต/;
return $Result;
} # END UC_Script
#----------------------------------------------------------------------------------------------------
=head3 UC_BoldScript(String)
Transform the passed string into pseudo-bold-script Unicode characters.
=cut
sub UC_BoldScript {
my ($self,$Result) = @_;
$Result =~ tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ/๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฏ๐ฐ๐ฑ๐ฒ๐ณ๐ด๐ต๐ถ๐ท๐ธ๐น๐บ๐ป๐ผ๐ฝ๐พ๐ฟ๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐ง๐จ๐ฉ/;
return $Result;
} # END UC_BoldScript
#----------------------------------------------------------------------------------------------------
=head3 UC_Outline(String)
Transform the passed string into pseudo-outline Unicode characters.
=cut
sub UC_Outline {
my ($self,$Result) = @_;
$Result =~ tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789/๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐ง๐จ๐ฉ๐ช๐ซ๐ธ๐นโ๐ป๐ผ๐ฝ๐พโ๐๐๐๐๐โ๐โโโ๐๐๐๐๐๐๐โค๐๐๐๐๐๐๐๐๐ ๐ก/;
return $Result;
} # END UC_Outline
#----------------------------------------------------------------------------------------------------
=head3 UC_Gothic(String)
Transform the passed string into pseudo-gothic Unicode characters.
=cut
sub UC_Gothic {
my ($self,$Result) = @_;
$Result =~ tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ/๐๐๐ ๐ก๐ข๐ฃ๐ค๐ฅ๐ฆ๐ง๐จ๐ฉ๐ช๐ซ๐ฌ๐ญ๐ฎ๐ฏ๐ฐ๐ฑ๐ฒ๐ณ๐ด๐ต๐ถ๐ท๐๐
โญ๐๐๐๐โโ๐๐๐๐๐๐๐๐โ๐๐๐๐๐๐๐/;
return $Result;
} # END UC_Gothic
#----------------------------------------------------------------------------------------------------
=head3 UC_BoldGothic(String)
Transform the passed string into pseudo-bold-gothic Unicode characters.
=cut
sub UC_BoldGothic {
my ($self,$Result) = @_;
$Result =~ tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ/๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐๐ฌ๐ญ๐ฎ๐ฏ๐ฐ๐ฑ๐ฒ๐ณ๐ด๐ต๐ถ๐ท๐ธ๐น๐บ๐ป๐ผ๐ฝ๐พ๐ฟ๐๐๐๐๐๐
/;
return $Result;
} # END UC_BoldGothic
# ---------------------------------------------------------------------------------
# End of package
1;