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 =head1 VERSION GGI.pm Version from 2021-03-26 =head1 AUTHORS GGI by Frank Jüdes, L This pod text by Frank Jüdes, Perl by Larry Wall and the C. =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 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 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 =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 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;