From patchwork Sat Apr 6 04:29:30 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tim FitzGeorge X-Patchwork-Id: 2173 Return-Path: Received: from mail01.ipfire.org (mail01.i.ipfire.org [172.28.1.200]) (using TLSv1.2 with cipher ECDHE-ECDSA-AES256-GCM-SHA384 (256/256 bits)) (Client CN "mail01.ipfire.org", Issuer "Let's Encrypt Authority X3" (verified OK)) by web07.i.ipfire.org (Postfix) with ESMTPS id 54B94861F37 for ; Fri, 5 Apr 2019 18:30:17 +0100 (BST) Received: from mail01.i.ipfire.org (localhost [IPv6:::1]) by mail01.ipfire.org (Postfix) with ESMTP id 44bRfJ5MBCz5Lcxg; Fri, 5 Apr 2019 18:30:16 +0100 (BST) Received: from smtp.hosts.co.uk (smtp.hosts.co.uk [85.233.160.19]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (Client did not present a certificate) by mail01.ipfire.org (Postfix) with ESMTPS id 44bRf40gXjz5D0PJ for ; Fri, 5 Apr 2019 18:30:04 +0100 (BST) Received: from [31.127.205.161] (helo=aragorn.tfitzgeorge.me.uk) by smtp.hosts.co.uk with esmtpa (Exim) (envelope-from ) id 1hCSfB-0008Ml-54; Fri, 05 Apr 2019 18:30:03 +0100 From: Tim FitzGeorge To: development@lists.ipfire.org Subject: [PATCH 02/12] statusmail: Perl module for encrypted Encrypted Mail Date: Fri, 5 Apr 2019 18:29:30 +0100 Message-Id: <20190405172940.13168-3-ipfr@tfitzgeorge.me.uk> X-Mailer: git-send-email 2.16.4 In-Reply-To: <20190405172940.13168-1-ipfr@tfitzgeorge.me.uk> References: <20190405172940.13168-1-ipfr@tfitzgeorge.me.uk> X-Spamd-Result: default: False [-10.26 / 11.00]; ARC_NA(0.00)[]; RCVD_VIA_SMTP_AUTH(0.00)[]; RECEIVED_SPAMHAUS_PBL(0.00)[161.205.127.31.zen.spamhaus.org : 127.0.0.11]; FROM_HAS_DN(0.00)[]; TO_DN_SOME(0.00)[]; R_SPF_ALLOW(-0.20)[+ip4:85.233.160.19]; MIME_GOOD(-0.10)[text/plain]; RCVD_TLS_LAST(0.00)[]; REPLY(-4.00)[]; DMARC_NA(0.00)[tfitzgeorge.me.uk]; TO_MATCH_ENVRCPT_SOME(0.00)[]; MX_GOOD(-0.01)[cached: mx1.ukservers.net]; RCPT_COUNT_TWO(0.00)[2]; MID_CONTAINS_FROM(1.00)[]; NEURAL_HAM(-2.99)[-0.997,0]; IP_SCORE(-3.77)[ip: (-9.91), ipnet: 85.233.160.0/19(-4.96), asn: 8622(-3.96), country: GB(-0.04)]; RCVD_IN_DNSWL_LOW(-0.10)[19.160.233.85.list.dnswl.org : 127.0.5.1]; R_DKIM_NA(0.00)[]; MIME_TRACE(0.00)[0:+]; ASN(0.00)[asn:8622, ipnet:85.233.160.0/19, country:GB]; RCVD_COUNT_TWO(0.00)[2]; BAYES_HAM(-0.09)[64.31%]; FROM_EQ_ENVFROM(0.00)[] Authentication-Results: mail01.ipfire.org; dkim=none; dmarc=none; spf=pass (mail01.ipfire.org: domain of ipfr@tfitzgeorge.me.uk designates 85.233.160.19 as permitted sender) smtp.mailfrom=ipfr@tfitzgeorge.me.uk X-BeenThere: development@lists.ipfire.org X-Mailman-Version: 2.1.15 Precedence: list List-Id: IPFire development talk List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: development-bounces@lists.ipfire.org Sender: "Development" Contains functions for writing structured emails and then both signing and encrypting them using GPG. There is a module in CPAN that can sign and encrypt emails, but this conatins additionaly functionality that is not required (decryption etc) and also requires a number of other modules that are not currently used in IPFire. Signed-off-by: Tim FitzGeorge --- src/statusmail/EncryptedMail.pm | 1060 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 1060 insertions(+) create mode 100644 src/statusmail/EncryptedMail.pm diff --git a/src/statusmail/EncryptedMail.pm b/src/statusmail/EncryptedMail.pm new file mode 100644 index 000000000..22732cb9e --- /dev/null +++ b/src/statusmail/EncryptedMail.pm @@ -0,0 +1,1060 @@ +#!/usr/bin/perl + +############################################################################ +# # +# Send log and status emails for IPFire # +# # +# This is free software; you can redistribute it and/or modify # +# it under the terms of the GNU General Public License as published by # +# the Free Software Foundation; either version 3 of the License, or # +# (at your option) any later version. # +# # +# This is distributed in the hope that it will be useful, # +# but WITHOUT ANY WARRANTY; without even the implied warranty of # +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # +# GNU General Public License for more details. # +# # +# You should have received a copy of the GNU General Public License # +# along with IPFire; if not, write to the Free Software # +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # +# # +# Copyright (C) 2018 - 2019 The IPFire Team # +# # +############################################################################ + +use strict; +use warnings; + +use MIME::Lite; +use IPC::Open2; +use IO::Select; +use Socket; + +require "/var/ipfire/general-functions.pl"; +require "${General::swroot}/lang.pl"; + +package EncryptedMail; + +############################################################################ +# Configuration variables +############################################################################ + +my $gpg = "/usr/bin/gpg --homedir ${General::swroot}/statusmail/keys"; +my $contactsettings = "${General::swroot}/statusmail/contact_settings"; + + +############################################################################ +# Function prototypes +############################################################################ + +sub new( @ ); +sub send( $@ ); +sub add( $@ ); +sub add_text( $@ ); +sub add_table( $@ ); +sub _add_table_text( $@ ); +sub _add_table_html( $@ ); +sub add_section( $$ ); +sub add_subsection( $$ ); +sub add_title( $$ ); +sub is_html( $ ); +sub is_text( $ ); +sub get_max_lines_per_item( $ ); + +#------------------------------------------------------------------------------ +# sub new( params ) +# +# Creates a new mail message. +# +# Parameters: +# A hash which can contain the following fields: +# format format of the message: 'html' or 'text' +# to reference to a list of contact names. +# subject subject for email message +# sender email address of sender +#------------------------------------------------------------------------------ + +sub new( @ ) +{ + my $invocant = shift; + + my $class = ref($invocant) || $invocant; + + my $self = { 'message' => '', + 'format' => 'html', + 'in_section' => 0, + 'in_subsection' => 0, + 'in_item' => 0, + 'section' => '', + 'subsection' => '', + 'subject' => 'Encrypted email', + 'empty' => 1, + 'skip_blank_sections' => 0, + 'skip_blank_subsections' => 0, + 'image_file' => 'img0000', + 'max_lines_per_item' => 100, + @_ }; + + bless( $self, $class ); + + if ($self->{'format'} eq 'html') + { + # For an HTML message, put the head on the beginning. + + $self->{'message'} = "\n\n\n\n"; + + if ($self->{'stylesheet'}) + { + $self->{'message'} .= "\n"; + } + + $self->{'message'} .= "\n\n\n
\n"; + } + else + { + # For a text message, just put the subject + + $self->{'message'} .= "$self->{subject}\n\n" + } + + $self->{'to'} =~ s/\|/ /g if ($self->{'to'}); + + # Create an email message object + + $self->{'object'} = MIME::Lite->new( Type => 'multipart/related', + Encoding => '7bit' ); + + # Create the main part of the message + + if ($self->{format} eq 'html') + { + $self->{'text'} = $self->{'object'}->attach( Type => 'text/html', + Encoding => 'quoted-printable' ); + $self->{'text'}->attr('content-type.charset' => 'UTF-8'); + } + else + { + $self->{'text'} = $self->{'object'}->attach( Type => 'TEXT', + Encoding => 'quoted-printable' ); + } + + return $self; +} + + +#------------------------------------------------------------------------------ +# sub is_html() +# +# Returns true if the message format is HTML. +# Used by plugins. +#------------------------------------------------------------------------------ + +sub is_html( $ ) +{ + return shift->{'format'} eq 'html'; +} + + +#------------------------------------------------------------------------------ +# sub is_text() + +# Return true if the message format is text. +# Used by plugins. +#------------------------------------------------------------------------------ + +sub is_text( $ ) +{ + return not shift->{'format'} eq 'html'; +} + + +#------------------------------------------------------------------------------ +# sub get_max_lines_per_item() + +# Returns the maximum number of lines to include in an item. +# Used by plugins. +#------------------------------------------------------------------------------ + +sub get_max_lines_per_item( $ ) +{ + return shift->{'max_lines_per_item'}; +} + + +#------------------------------------------------------------------------------ +# sub send( subject ) +# +# Sends the message. A subject may be specified which overrides the one +# specified when creating the object. +#------------------------------------------------------------------------------ + +sub send( $@ ) +{ + use IPC::Open2; + + my $self = shift; + my ($subject) = @_; + my $contacts; + + # Don't do anything if there's no data + + return if ($self->{'empty'}); + + $subject ||= $self->{'subject'}; + + # Get the list of recipients, dividing it into signed and encrypted. + + return unless (-r $contactsettings); + eval qx|/bin/cat $contactsettings|; + + my @signed_recipients; + my @encrypted_recipients; + + foreach my $recipient ( @{ $self->{'to'} } ) + { + if ($$contacts{$recipient}{'fingerprint'}) + { + # Signed and encrypted + + push @encrypted_recipients, $$contacts{$recipient}{'email'}; + } + else + { + # Signed only + + push @signed_recipients, $$contacts{$recipient}{'email'}; + } + } + + return unless (@encrypted_recipients or @signed_recipients); + + # Build the data that's going to be signed + + if ($self->{format} eq 'html') + { + $self->{message} .= "
\n" if ($self->{in_item}); + $self->{message} .= "\n" if ($self->{in_subsection}); + $self->{message} .= "\n" if ($self->{in_section}); + + $self->{message} .= "\n\n\n"; + } + $self->{in_section} = 0; + + $self->{text}->data( $self->{message} ); + + #---------------------------------------------------------------------------- + # Sign message + + # Prepare to sign the data + + my ($from_gpg, $to_gpg); + + my $body = $self->{'object'}->as_string; + + # Sign the data + # Create a process running GPG + + my $cmd = "$gpg --batch --detach-sign --digest-algo sha256 --armour --local-user \"<$self->{'sender'}>\" --passphrase-fd 0"; + + my $childpid = open2( $from_gpg, $to_gpg, $cmd ); + + print $to_gpg "ipfirestatusemail\n"; + + # Pipe the data to be signed to GPG + # The signature is fairly short so we don't need to worry about buffering. + + foreach my $line (split /[\n]/, $body) + { + chomp $line; + $line =~ s/\s*$/\r\n/; + + print $to_gpg $line; + } + + print $to_gpg "\r\n"; + + close $to_gpg; + + # Get the signature + + my $signature = ''; + + $signature .= $_ while <$from_gpg>; + + waitpid( $childpid, 0 ); + + # Create the message that will contain the data and its signature + + my $signed_message = new MIME::Lite(Type => 'multipart/mixed' ); + + $signed_message->attr( 'content-type' => 'multipart/signed' ); + $signed_message->attr( 'content-type.protocol' => 'application/pgp-signature' ); + $signed_message->attr( 'content-type.micalg' => 'pgp-sha256' ); + + # Attach the signed data to the message + + $signed_message->attach( $self->{'object'} ); + + delete $self->{object}; + + # Attach the signature to the message + + $signed_message->attach( Type => 'application/pgp-signature', + Encoding => '7bit', + Data => $signature ); + + # Send the message to signed only recipients + + if (@signed_recipients) + { + $signed_message->add( From => $self->{'sender'} ); + $signed_message->add( To => [ @signed_recipients ] ); + $signed_message->add( Subject => $self->{'subject'} ); + + $signed_message->send(); + + # Delete tags that are not needed when the message is encrypted. + + $signed_message->delete( 'From' ); + $signed_message->delete( 'To' ); + $signed_message->delete( 'Subject' ); + } + + #---------------------------------------------------------------------------- + # Encrypt message + + # Encrypt and send the message to signed and encrypted recipients + + if (@encrypted_recipients) + { + # Find the keys of the recipients and build the GPG command + + $cmd = "$gpg --batch --encrypt --armour --always-trust --charset UTF8"; + + foreach my $recipient ( @{ $self->{'to'} } ) + { + if ($$contacts{$recipient}{'fingerprint'}) + { + my $fingerprint = $$contacts{$recipient}{'fingerprint'}; + $fingerprint =~ s/\s+//g; + + $cmd .= " --recipient $fingerprint"; + } + } + + # Build a mask to check if there's any output from GPG later + + my $reader = IO::Select->new; + + my $encrypted = ''; + + # Start GPG and pipe the signed message to it + # The encrypted message is longer than the IO buffer so we need to arrange + # to read and write asynchronously. + + $childpid = open2( $from_gpg, $to_gpg, $cmd ) or die "Can't fork GPG child: $!"; + + $reader->add( $from_gpg ); + + my $signed_data = $signed_message->as_string; + my $read; + + foreach my $line (split /[\n]/, $signed_data) + { + chomp $line; + $line =~ s/\s*$/\r\n/; + print $to_gpg $line; + + while ($reader->can_read( 0 )) + { + $encrypted .= <$from_gpg>; + } + } + + close $to_gpg; + + $encrypted .= $_ while (<$from_gpg>); + + close $from_gpg; + + # Create the message that will contain the data and its signature + + my $encrypted_message = new MIME::Lite( From => $self->{'sender'}, + To => [ @encrypted_recipients ], + Subject => $self->{'subject'}, + Type => 'multipart/mixed' ); + + $encrypted_message->attr( 'content-type' => 'multipart/encrypted' ); + $encrypted_message->attr( 'content-type.protocol' => 'application/pgp-encrypted' ); + + # Attach the control information to the message + + $encrypted_message->attach( Type => 'application/pgp-encrypted', + Encoding => '7bit', + Data => 'Version 1' ); + + # Attach the encrypted data + + $encrypted_message->attach( Type => 'application/octet-stream', + Encoding => '7bit', + Data => $encrypted ); + + $encrypted_message->send(); + } +} + + +#------------------------------------------------------------------------------ +# add_section( name ) +# +# Starts a new section in the message. Nothing is actually added to the +# message until the contents of an item are added. This allows empty sections +# to be omitted. +#------------------------------------------------------------------------------ + +sub add_section( $$ ) +{ + my ($self, $name) = @_; + + if ($self->{format} eq 'html') + { + # Terminate old items/subsections/sections + + $self->{message} .= "\n" if ($self->{in_item}); + $self->{message} .= "\n" if ($self->{in_subsection}); + $self->{message} .= "\n" if ($self->{in_section}); + + # Start new section + + $self->{section} = "

$name

\n"; + } + else + { + # Start new section + + $self->{section} = "\n$name\n"; + $self->{section} .= '-' x length($name); + $self->{section} .= "\n"; + } + + $self->{subsection} = ''; + $self->{item} = ''; + + $self->{in_section} = 0; + $self->{in_subsection} = 0; + $self->{in_item} = 0 +} + + +#------------------------------------------------------------------------------ +# sub add_subsection( name ) +# +# Starts a new subsection in the message. Nothing is actually added to the +# message until the contents of an item are added. This allows empty +# subsections to be omitted. +#------------------------------------------------------------------------------ + +sub add_subsection( $$ ) +{ + my ($self, $name) = @_; + + if ($self->{format} eq 'html') + { + # Terminate old items/subsections + + $self->{message} .= "
\n" if ($self->{in_item}); + $self->{message} .= "\n" if ($self->{in_subsection}); + + # Start new subsection + + $self->{subsection} = "

$name

\n"; + } + else + { + # Start new subsection + + $self->{subsection} = "\n $name\n"; + } + + $self->{item} = ''; + + $self->{in_subsection} = 0; + $self->{in_item} = 0 +} + + +#------------------------------------------------------------------------------ +# sub title( name ) +# +# Adds a new item title to the message. Nothing is actually added to the +# message until the contents of an item are added. This allows empty items to +# be omitted. +#------------------------------------------------------------------------------ + +sub add_title( $$ ) +{ + my ($self, $string) = @_; + + if ($self->{format} eq 'html') + { + # Terminate old item + + $self->{message} .= "
\n" if ($self->{in_item}); + + # Start new item + + $self->{item} = "

$string

\n"; + } + else + { + # Start new item + + $self->{item} = "\n $string\n\n"; + } + + $self->{in_item} = 0; +} + + +#------------------------------------------------------------------------------ +# sub add( lines ) +# +# Adds an item (or part of an item) to the message. If there are section, +# subsection or item titles outstanding, they are added, and then the contents +# of the parameter array is added. No formatting is carried out. This +# function should generally only be used by a plugin to add pre-formatted +# HTML to the message. +#------------------------------------------------------------------------------ + +sub add( $@ ) +{ + my ($self, @lines) = @_; + + # Add section/subsection/item titles, if they haven't already been added. + + if ($self->{section}) + { + $self->{message} .= $self->{section}; + $self->{section} = ''; + $self->{in_section} = 1; + $self->{in_subsection} = 0; + $self->{in_item} = 0; + } + + if ($self->{subsection}) + { + $self->{message} .= $self->{subsection}; + $self->{subsection} = ''; + $self->{in_subsection} = 1; + $self->{in_item} = 0; + } + + if ($self->{item}) + { + $self->{message} .= $self->{item}; + $self->{item} = ''; + $self->{in_item} = 1; + } + + # Add the lines + + foreach my $line (@lines) + { + $self->{message} .= $line; + } + + $self->{empty} = 0; +} + + +#------------------------------------------------------------------------------ +# sub add_text( lines ) +# +# Adds the textual lines to the message. If there are section, subsection or +# item titles outstanding, they are added, and then the contents of the +# parameter array is added. The lines are formatted as plain text with HTML +# breaks inserted if necessary. +#------------------------------------------------------------------------------ + +sub add_text( $@ ) +{ + my ($self, @lines) = @_; + + my $message = ''; + + foreach my $string (@lines) + { + if ($self->{format} eq 'html') + { + $string =~ s/[\n\r]+/
\n/g; + $message .= $string; + } + else + { + foreach my $string ( split /[\n\r]+/, $string ) + { + $message .= ' ' . $string . "\n"; + } + } + } + + $self->add( $message ); + + $self->{empty} = 0; +} + + +#------------------------------------------------------------------------------ +# sub add_image( params ) +# +# Adds an image to the message. +#------------------------------------------------------------------------------ + +sub add_image( $@ ) +{ + my ($self, %params) = @_; + + # Add section/subsection/item titles, if they haven't already been added. + + if ($self->{section}) + { + $self->{message} .= $self->{section}; + $self->{section} = ''; + $self->{in_section} = 1; + $self->{in_subsection} = 0; + $self->{in_item} = 0; + } + + if ($self->{subsection}) + { + $self->{message} .= $self->{subsection}; + $self->{subsection} = ''; + $self->{in_subsection} = 1; + $self->{in_item} = 0; + } + + if ($self->{item}) + { + $self->{message} .= $self->{item}; + $self->{item} = ''; + $self->{in_item} = 1; + } + + # Work out the name of the embedded file + + $self->{'image_file'}++; + + my $image_name = $self->{'image_file'}; + + if ($params{'type'} eq 'image/jpeg') + { + $image_name .= '.jpg'; + } + elsif ($params{'type'} eq 'image/gif') + { + $image_name .= '.gif'; + } + elsif ($params{'type'} eq 'image/png') + { + $image_name .= '.png'; + } + else + { + return; + } + + # Get the image + + my $data; + + if (exists $params{fh}) + { + my $buffer; + binmode $params{fh}; + + while (read $params{fh}, $buffer, 1024) + { + $data .= $buffer; + } + } + elsif (exists $params{data}) + { + $data = $params{data}; + } + + # Embed the file + + my $name = $params{'name'} || $image_name; + + $self->{object}->attach( Type => $params{'type'}, + Data => $data, + Id => $image_name ); + + $self->{message} .= "{message} .= " alt='$params{alt}'" if (exists $params{alt}); + $self->{message} .= ">\n"; + + $self->{empty} = 0; +} + +#------------------------------------------------------------------------------ +# sub add_table( contents ) +# +# Adds a table to the message. If there are section, subsection or item titles +# outstanding, they are added, and then the contents of the parameter array are +# added. +# +# The parameters passed should be an array of references to arrays. Each entry +# in the parameter array is a reference to an array representing a row of the +# table. The first row is taken to be the header. +# +# The entire table is scanned to work out the size and alignment of each column +# and then the table is formatted and added to the message. Columns are right +# aligned if they only contain numeric data (which may be suffixed to indicate +# units), otherwise columns are left aligned. The header row is centered. +# +# The alignment algorithm may be overridden by inserting a row consisting only +# of entries containing the following characters: '<', '|', '#' and '>', for +# left centre, numeric and right alignment. This line will override the +# alignment for subsequent columns. This also works for the header row, by +# inserting the alignment information before the header row; in this case the +# entire body of the table must also be manually aligned. +#------------------------------------------------------------------------------ + +sub add_table( $@ ) +{ + my ($self, @lines) = @_; + + if ($self->{format} eq 'html') + { + _add_table_html( $self, @lines ); + } + else + { + _add_table_text( $self, @lines ); + } + + $self->{empty} = 0; +} + + +#------------------------------------------------------------------------------ +# _add_table_html( contents ) +# +# Internal subroutine called by add_table to format a table in HTML. +#------------------------------------------------------------------------------ + +sub _add_table_html( $@ ) +{ + my ($self, @lines) = @_; + my @align; + my $header_row = 1; + my $text = ''; + my $number_lines = 0; + my $centre_header = 1; + + # Scan through the table entries to work out the alignment of each column. + # Note that the header row is always centre aligned, unless the alignment of + # entire table is set manually. + + foreach my $line ( @lines ) + { + my @fields = @{ $line }; + + unless ($align[0]) + { + for (my $column = 0 ; $column < @fields ; $column++) + { + # Initialise to right aligned. + + $align[$column] = '>'; + } + } + + # Check for manually defined alignment. + + last if ((join '', @fields) !~ m/[^<>|#]/); + + for (my $column = 0 ; $column < @fields ; $column++) + { + # Handle multiple lines in a single table cell. + + foreach my $item (split /[\n\r]+/, $fields[$column]) + { + if (not $header_row and $align[$column] ne '<') + { + if ($align[$column] eq '>' and ($fields[$column] =~ m/^\d*\.\d*(?:\s*[-\w\/%]+)?$/)) + { + # Decimal number - number align. + # Note that a number may be followed by a suffix (e.g. unit). + + $align[$column] = '#'; + } + elsif ($align[$column] ne '<' and $fields[$column] !~ m/^(?:\d*\.)?\d+(?:\s*[-\w\/%]+)?$/) + { + # Alphanumeric - left align. + + $align[$column] = '<'; + } + } + } + } + + $header_row = 0; + } + + # Now scan the table again, outputting the information. + + $header_row = 1; + + $text = "\n"; + + foreach my $line ( @lines ) + { + my @fields = @{ $line }; + + $text .= ""; + + if ((join '', @fields) !~ m/[^<>|#]/) + { + # Explicit alignment. + + for (my $column = 0 ; $column < @fields ; $column++) + { + $align[$column] = $fields[$column] if ($fields[$column]); + } + + # Override the centre justification of the header. + + $centre_header = 0; + + next; + } + + for (my $column = 0 ; $column < @fields ; $column++) + { + my $item = $fields[$column]; + my $tag = 'td'; + my $align = ' style="text-align: right"'; + + $item =~ s/[\n\r]+/
/g; + $align = ' style="text-align: center"' if ($align[$column] eq '|'); + $align = '' if ($align[$column] eq '<'); + + if ($header_row) + { + $tag = 'th'; + $align = '' if ($centre_header); + } + + $text .= "<$tag$align>$item"; + } + + $text .= "\n"; + $header_row = 0; + last if (++$number_lines > $self->{'max_lines_per_item'}); + } + + $text .= "
\n"; + + $self->add( $text ); + $self->{empty} = 0; +} + +#------------------------------------------------------------------------------ +# sub _add_table_text( contents ) +# +# Internal subroutine called by add_table to format a table in text. +#------------------------------------------------------------------------------ + +sub _add_table_text( $@ ) +{ + my ($self, @lines) = @_; + my @width; + my @align; + my $header_row = 1; + my $ignore_align = 0; + my $text = ''; + my $number_lines = 0; + my $centre_header = 1; + + # Scan through the table entries to work out the width and alignment of each + # column. + # Note that the header row is always centre aligned, unless the alignment of + # entire table is set manually. + + foreach my $line ( @lines ) + { + my @fields = @{ $line }; + + unless ($align[0]) + { + for (my $column = 0 ; $column < @fields ; $column++) + { + # Initialise to zero width and right aligned. + + $width[$column] = 0; + $align[$column] = '>'; + } + } + + # Check for manually defined alignment. + + if ((join '', @fields) !~ m/[^<>|#]/) + { + $ignore_align = 1; + next; + } + + for (my $column = 0 ; $column < @fields ; $column++) + { + next unless ($fields[$column]); + + # Handle multiple lines in a single table cell. + + foreach my $item (split /[\n\r]+/, $fields[$column]) + { + next unless ($item); + + if (length $item > $width[$column]) + { + $width[$column] = length $item; + } + + if (not $header_row and $align[$column] ne '<' and not $ignore_align) + { + if ($align[$column] eq '>' and ($item =~ m/^\d*\.\d*(?:\s*[-\w\/%]+)?$/)) + { + # Decimal number - number align. + # Note that a number may be followed by a suffix (e.g. unit). + + $align[$column] = '#'; + } + elsif ($align[$column] ne '<' and $item !~ m/^(?:\d*\.)?\d+(?:\s*[-\w\/%]+)?$/) + { + # Alphanumeric - left align. + + $align[$column] = '<'; + } + } + } + } + + last if (++$number_lines > $self->{'max_lines_per_item'}); + $header_row = 0; + } + + # Now scan the table again, outputting the information. + + $header_row = 1; + $number_lines = 0; + + foreach my $line ( @lines ) + { + my @fields = @{ $line }; + my @next_fields = (); + my $more_lines = 0; + + if ((join '', @fields) !~ m/[^<>|#]/) + { + # Explicit alignment. + + for (my $column = 0 ; $column < @fields ; $column++) + { + $align[$column] = $fields[$column] if ($fields[$column]); + } + + # Override the centre justification of the header. + + $centre_header = 0; + + next; + } + + $text .= ' '; + + for (my $column = 0 ; $column < @fields ; $column++) + { + my $item = ''; + $next_fields[$column] = ''; + + # Try to split the cell into multiple lines. + + ($item, $next_fields[$column]) = split /[\n\r]+/, $fields[$column], 2; + + if ($next_fields[$column]) + { + $more_lines = 1 ; + } + else + { + $next_fields[$column] = ' '; + } + + $item = '' unless ($item); + + my $width = length $item; + + if ($centre_header or $align[$column] eq '|') + { + # Centre justified pre-spacing. + $text .= ' ' x (($width[$column] - $width) / 2 ); + } + elsif ($align[$column] eq '>' or $align[$column] eq '#') + { + # Right justified pre-spacing. + $text .= ' ' x ($width[$column] - $width); + } + + $text .= $item; + + if ($column != $#fields) + { + if ($centre_header or $align[$column] eq '|') + { + # Centre justified post spacing. + $text .= ' ' x (($width[$column] - $width + 1) / 2 ); + } + elsif ($align[$column] eq '<') + { + # Left justified post spacing. + $text .= ' ' x ($width[$column] - $width); + } + + # Inter column spacing + $text .= " "; + } + } + + $text =~ s/\s+$//; + $text .= "\n"; + $header_row = 0; + $centre_header = 0; + + if ($more_lines) + { + # One or more of the cells in this row has multiple lines outstanding. + # Go back to output the next line. + $line = [ @next_fields ]; + redo; + } + + last if (++$number_lines > $self->{'max_lines_per_item'}); + } + + $self->add( $text ); + $self->{empty} = 0; +} + + +1;