567 lines
13 KiB
Perl
567 lines
13 KiB
Perl
#----------------------------------------------------------------------
|
||
package UVformats;
|
||
#----------------------------------------------------------------------
|
||
|
||
=head1 NAME
|
||
|
||
UVformats - Methoden zur Stringformatierung
|
||
|
||
=head1 SYNOPSIS
|
||
|
||
value <name-of-key>
|
||
append <name-of-key>
|
||
|
||
fill-left <width> <character>
|
||
fill-right <width> <character>
|
||
fill-center <width> <character>
|
||
|
||
justify <name-of-key> <width>
|
||
justify-before <name-of-key> <width>
|
||
justify-behind <name-of-key> <width>
|
||
|
||
first-words <width>
|
||
drop-words <width>
|
||
create-lines <width>
|
||
|
||
multi-graph <width> <position> <count>
|
||
multi-line <width> <count>
|
||
|
||
quote <string>
|
||
replace <original-string> <replacement-string>
|
||
sprintf <format-string>
|
||
|
||
generate_date_header
|
||
|
||
=head1 DESCRIPTION
|
||
|
||
Dieses Modul stellt verschiedenste Methoden bereit, um die Strings in
|
||
den Templates auf die unterschiedlichste Art zu formatieren.
|
||
|
||
Dieses Modul beschraenkt sich auf die Beschreibung der Funktionen. Ihre
|
||
Einbindung wird in UVtemplates beschrieben.
|
||
|
||
=head1 FUNCTIONS
|
||
|
||
=over 3
|
||
|
||
=cut
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
use strict;
|
||
use vars qw(@ISA @EXPORT $VERSION $functions);
|
||
|
||
use Exporter;
|
||
$VERSION = 0.01;
|
||
|
||
@ISA = qw(Exporter);
|
||
@EXPORT = qw( getFunctions );
|
||
|
||
use Text::Wrap;
|
||
#use POSIX qw(strftime);
|
||
use Email::Date;
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
sub getFunctions{
|
||
return $functions;
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
=item value
|
||
|
||
Gibt den Wert eines Schluessel zurueck.
|
||
|
||
new-key := value 'old-key' | <other-functions> ...
|
||
|
||
Diese Funktion sollte dann eingesetzt werden, wenn man einen virtuellen
|
||
Schluessel erzeugen will. D.h. der Bezeichner nicht im Template als
|
||
Schluessel vorhanden ist. Durch den Einsatz von value wird der Wert eines
|
||
anderen Schluessel kopiert und kann dann weiter formatiert werden.
|
||
|
||
=cut
|
||
|
||
sub value{
|
||
my ($data, $value, $key) = @_;
|
||
return $data->getKey($key);
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item append
|
||
|
||
Den Wert eines anderen Schluessels an den bisherigen String anhaengen.
|
||
|
||
... | append 'other-key' | ...
|
||
|
||
Per default wird als Trenner der beiden String ein Leerzeichen verwendet.
|
||
Soll dieses entfallen oder ein anderes Zeichen benutzt werden, so kann
|
||
ein dementsprechender drittere Parameter angegeben werden.
|
||
|
||
... | append 'other-key' '' | ...
|
||
... | append 'other-key' '_' | ...
|
||
|
||
Im ersten Beispiel wird der Wert von C<other-key> nahtlos hinzugefuegt.
|
||
Im zweiten statt des Leerzeichens '_' benutzt.
|
||
|
||
=cut
|
||
|
||
sub append{
|
||
my ($data, $value, $key, $sep) = @_;
|
||
|
||
$sep = ' ' unless defined($sep);
|
||
|
||
return $value. $sep. $data->getConvKey($key);
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item fill-left, fill-right, fill-center
|
||
|
||
Fuellt den String entsprechend mit Zeichen auf bis die gewuenschte
|
||
Laenge erreicht ist. Bei C<fill-left> werden die Zeichen vorranggestellt,
|
||
bei C<fill-right> angehaengt. C<fill-center> verteilt die Zeichen
|
||
gleichmaessig vor und nach dem String.
|
||
|
||
... | fill-left 72 '.' | ...
|
||
|
||
Wird kein zweiter Parameter angegeben, wird automatisch das Leerzeichen
|
||
benutzt.
|
||
|
||
... | fill-right 60 | ...
|
||
|
||
Ist der String bereits laenger als gewuenscht, wird er nicht weiter
|
||
veraendert und auch nicht verkuerzt.
|
||
|
||
=cut
|
||
|
||
sub fill_left{
|
||
my ($data, $value, $width, $char) = @_;
|
||
|
||
$width ||= 72;
|
||
$char = ' ' unless (defined($char) && length($char) == 1);
|
||
|
||
my $fill = $width - length($value);
|
||
|
||
$value = $char x $fill . $value if ($fill > 0);
|
||
|
||
return $value;
|
||
}
|
||
|
||
sub fill_right{
|
||
my ($data, $value, $width, $char) = @_;
|
||
|
||
$width ||= 72;
|
||
$char ||= ' ';
|
||
|
||
my $fill = $width - length($value);
|
||
|
||
$value .= $char x $fill if ($fill > 0);
|
||
|
||
return $value;
|
||
}
|
||
|
||
sub fill_both{
|
||
my ($data, $value, $width, $char) = @_;
|
||
|
||
$width ||= 72;
|
||
$char ||= ' ';
|
||
|
||
my $fill = $width - length($value);
|
||
|
||
if ($fill > 0){
|
||
my $left = int($fill / 2);
|
||
my $right = $fill - $left;
|
||
|
||
$value = $char x $left . $value . $char x $right;
|
||
}
|
||
|
||
return $value;
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item justify, justify-before, justify-behind
|
||
|
||
Fuegt zwischen den existierenden String und dem Wert des angegebenen
|
||
Schluessel genau so viele Leerzeichen ein, damit die gewuenschte
|
||
Stringlaenge erreicht wird.
|
||
|
||
... | justify-behind 'key' 72 | ...
|
||
|
||
C<justify-behind> haengt den Wert des Schluessel an das Ende des Strings,
|
||
C<justify-before> stellt es davor.
|
||
|
||
justify-behind: existing-string.........value-of-key
|
||
justify-before: value-of-key.........existing-string
|
||
|
||
C<justify> ist lediglich ein Alias auf C<justify-behind>.
|
||
|
||
Sind die beiden Strings zusammen l<>nger als die gewuenschte
|
||
Zeilenlaenge, wird automatisch einen Zeilenbruch eingefuegt
|
||
und beide Zeilen entsprechend mit Leerzeichen gefuellt.
|
||
|
||
very-very-very-long-existing-string.........\n
|
||
...................and-a-too-long-new-string
|
||
|
||
=cut
|
||
|
||
sub justify_behind{
|
||
my ($data, $value, $key, $width) = @_;
|
||
return _justify( $value, $data->getConvKey($key), $width);
|
||
}
|
||
|
||
sub justify_before{
|
||
my ($data, $value, $key, $width) = @_;
|
||
return _justify( $data->getConvKey($key), $value, $width);
|
||
}
|
||
|
||
sub _justify{
|
||
my ($lval, $rval, $width) = @_;
|
||
|
||
my $sep = ' ';
|
||
|
||
if (length($lval.$rval) >= $width ){
|
||
# wir basteln zwei zeilen
|
||
$lval .= $sep x ($width - length($lval));
|
||
$rval = $sep x ($width - length($rval)) . $rval;
|
||
|
||
return $lval."\n".$rval;
|
||
|
||
}else{
|
||
my $fill = $width - length($lval) - length($rval);
|
||
return $lval . $sep x $fill . $rval;
|
||
}
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item first-words
|
||
|
||
Gibt nur die ersten Worte eines Strings zurueck, die vollstaendig
|
||
innerhalb der angegebenen Laenge liegen.
|
||
|
||
=cut
|
||
|
||
sub first_words{
|
||
my ($data, $value, $width) = @_;
|
||
|
||
my @words = split('\s+', $value);
|
||
my $string;
|
||
|
||
$string .= shift(@words);
|
||
|
||
while(@words && (length($string) + length($words[0]) + 1) < $width){
|
||
$string .= ' ' . shift(@words);
|
||
}
|
||
|
||
return $string;
|
||
}
|
||
|
||
=item drop-words
|
||
|
||
Alle Woerter am Anfang des Strings entfernen, die komplett innerhalb
|
||
der angegebenen Laenge liegen.
|
||
|
||
=cut
|
||
|
||
sub drop_words{
|
||
my ($data, $value, $width) = @_;
|
||
|
||
my @words = split('\s+', $value);
|
||
|
||
# das erste "Wort" immer verwerfen, egal wie lang es ist
|
||
my $first = shift(@words);
|
||
my $length = length($first);
|
||
|
||
while (@words && ( $length + length($words[0]) + 1 ) < $width ){
|
||
$length += length($words[0]) + 1;
|
||
shift(@words);
|
||
}
|
||
|
||
return join(' ', @words);
|
||
}
|
||
|
||
=item create-lines
|
||
|
||
Zerlegt einen String in einen Array, in dem die einzelnen Zeilen nicht
|
||
laenger als die gewuenschte Anzahl Zeichen sind.
|
||
|
||
absatz := value 'key' | create-lines 72
|
||
|
||
Mit Hilfe dieser Funktion ist es moeglich, ueberlange Zeilen zu Absatzen
|
||
umzuformatieren.
|
||
|
||
Die Funktion erzeugt intern eine Liste, die jeweils den Schluessel C<line>
|
||
mit dem entsprechenden String als Wert enthaelt.
|
||
|
||
Im Template wird der so Absatz dann mit Hilfe des Schleifen-Syntax
|
||
eingebunden:
|
||
|
||
[@absatz|[line]\n]
|
||
|
||
Achtung! Da die Funktion keinen String zurueckgibt, sollte sie am Ende
|
||
der Kette stehen, da die normalen Formatierungsfunktionen einen String
|
||
als Input erwartern!
|
||
|
||
=cut
|
||
|
||
sub create_lines{
|
||
my ($data, $value, $width) = @_;
|
||
|
||
my @words = split('\s+', $value);
|
||
|
||
my @lines;
|
||
|
||
while (@words){
|
||
my $string .= shift(@words);
|
||
|
||
while(@words && (length($string) + length($words[0]) + 1) < $width){
|
||
$string .= ' ' . shift(@words);
|
||
}
|
||
|
||
my $new = $data->new( line => $string );
|
||
push(@lines, $new);
|
||
}
|
||
|
||
return \@lines;
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item multi-graph, multi-line
|
||
|
||
Spezielle Funktionen, um eine bestimmte graphische Ausgabe fuer
|
||
Votings mit mehreren Abstimmungspunkten zu erzeugen:
|
||
|
||
Punkt 1 --------------------------+
|
||
Punkt 2a ------------------------+|
|
||
Punkt 2b -----------------------+||
|
||
Punkt 3 -----------------------+|||
|
||
||||
|
||
Name of Voter 1 jjnn
|
||
Name of Voter 2 nnjj
|
||
|
||
C<multi-graph> ist hierbei f<>r die Formatierung der einzelnen Abstimmungspunkte
|
||
zustaendig.
|
||
|
||
multi-graph 'key' 'width' 'pos-key' 'max-key'
|
||
|
||
Der erste Parameter gibt den Schluessel an, dessen Wert als Abstimmungspunkt
|
||
ausgegeben werden soll. C<width> die Laenge des zu erzeugenden Strings.
|
||
C<pos-key> und C<max-key> sind die Namen der Schluessel, in denen stehen
|
||
muss, um den wievielten Abstimmungspunkt es sich handelt (per default 'pos')
|
||
und wieviele Abstimmungspunkte es insgesamt gibt ('anzpunkte').
|
||
|
||
C<multi-line> erzeugt einfach nur einen String in der gewuenschten
|
||
Laenge, der entsprechend der Anzahl der Abstimmungspunkte mit '|'
|
||
abschliesst.
|
||
|
||
=cut
|
||
|
||
sub mgraph{
|
||
my ($data, $value, $width, $pkey, $okey) = @_;
|
||
return unless $data;
|
||
|
||
my $pos = $data->getKey($pkey || 'pos');
|
||
my $of = $data->getKey($okey || 'anzpunkte');
|
||
|
||
my $gfx = '';
|
||
|
||
$gfx = ' ---'.'-' x ($of-$pos) .'+'. '|' x ($pos - 1) if ($pos && $of);
|
||
|
||
if (length($value.$gfx) < $width){
|
||
$value = ' ' x ($width - length($value.$gfx)) . $value . $gfx;
|
||
|
||
}elsif (length($value.$gfx) > $width){
|
||
my @lines = _wrap($value, $width - length($gfx));
|
||
|
||
$value = shift(@lines) . $gfx;
|
||
$value = ' ' x ($width - length($value)) . $value;
|
||
|
||
# Hilfzeile erzeugen
|
||
$gfx = ' '.' ' x ($of-$pos) . '|' x ($pos) if ($pos && $of);
|
||
|
||
foreach my $line (@lines){
|
||
$value .= "\n".' ' x ($width - length($line.$gfx)) . $line . $gfx;
|
||
}
|
||
}
|
||
|
||
return $value;
|
||
}
|
||
|
||
sub mgline{
|
||
my ($data, undef, $width, $okey) = @_;
|
||
return unless $data;
|
||
|
||
my $of = $data->getKey($okey || 'anzpunkte') || 0;
|
||
|
||
return ' ' x ($width - $of) . '|' x $of;
|
||
}
|
||
|
||
|
||
sub _wrap{
|
||
my ($string, $width) = @_;
|
||
|
||
my @words = split('\s+', $string);
|
||
|
||
my @lines;
|
||
|
||
while (@words){
|
||
my $line .= shift(@words);
|
||
|
||
while(@words && (length($line) + length($words[0]) + 1) < $width){
|
||
$line .= ' ' . shift(@words);
|
||
}
|
||
|
||
push(@lines, $line);
|
||
}
|
||
|
||
return @lines;
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item quote
|
||
|
||
Stellt in einem (mehrzeiligem) String jeder Zeile den gewuenschten
|
||
Quotestring voran.
|
||
|
||
body := value 'body' | quote '> '
|
||
|
||
=cut
|
||
|
||
sub quote{
|
||
my ($data, $value, $quotechar) = @_;
|
||
|
||
$quotechar = '> ' unless defined($quotechar);
|
||
|
||
$value =~ s/^/$quotechar/mg;
|
||
return $value;
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item replace
|
||
|
||
Ersetzt in einem String ein oder mehrere Zeichen durch eine beliebige
|
||
Anzahl anderer Zeichen. Diese Funktion kann z.B. genutzt werden, um
|
||
beim Result die Mailadressen zu verfremden (Schutz vor Adress-Spidern).
|
||
|
||
mail := value 'mail' | replace '@' '-at-'
|
||
|
||
=cut
|
||
|
||
sub replace{
|
||
my ($data, $value, $original, $replacement) = @_;
|
||
|
||
$original = ' ' unless defined($original);
|
||
$replacement = ' ' unless defined($replacement);
|
||
|
||
$value =~ s/\Q$original\E/$replacement/g;
|
||
return $value;
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item sprintf
|
||
|
||
Gibt Text oder Zahlen mittels der Funktion sprintf formatiert aus
|
||
(siehe "man 3 sprintf" oder "perldoc -f sprintf").
|
||
|
||
proportion := value 'proportion' | sprintf '%6.3f'
|
||
|
||
=cut
|
||
|
||
sub sprintf{
|
||
my ($data, $value, $format) = @_;
|
||
|
||
$format = '%s' unless defined($format);
|
||
|
||
return sprintf($format, $value);
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item generate_date_header
|
||
|
||
Gibt ein Datum im RFC822-Format zur Verwendung im Date:-Header einer
|
||
Mail aus.
|
||
|
||
date := generate_date_header
|
||
|
||
=cut
|
||
|
||
sub generate_date_header{
|
||
my ($data, $value, $format) = @_;
|
||
#return strftime('%a, %d %b %Y %H:%M:%S %z', localtime);
|
||
return format_date;
|
||
}
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=item generate_msgid
|
||
|
||
Gibt eine Message-ID im RFC822-Format zur Verwendung im Message-ID:-Header
|
||
einer Mail aus.
|
||
|
||
msgid := generate_msgid
|
||
|
||
=cut
|
||
|
||
sub generate_msgid{
|
||
return ("<".$$.time().rand(999)."\@".$UVconfig::config{fqdn}.">");
|
||
}
|
||
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
BEGIN{
|
||
%UVconfig::functions = ( %UVconfig::functions,
|
||
value => \&value,
|
||
append => \&append,
|
||
|
||
'fill-left' => \&fill_left,
|
||
'fill-right' => \&fill_right,
|
||
'fill-both' => \&fill_both,
|
||
|
||
justify => \&justify_behind,
|
||
'justify-behind' => \&justify_behind,
|
||
'justify-before' => \&justify_before,
|
||
|
||
'first-words' => \&first_words,
|
||
'drop-words' => \&drop_words,
|
||
|
||
'create-lines' => \&create_lines,
|
||
|
||
'multi-graph' => \&mgraph,
|
||
'multi-line' => \&mgline,
|
||
|
||
'quote' => \"e,
|
||
'replace' => \&replace,
|
||
'sprintf' => \&sprintf,
|
||
|
||
'generate-date-header' => \&generate_date_header,
|
||
'generate-msgid' => \&generate_msgid
|
||
);
|
||
}
|
||
|
||
1;
|
||
|
||
#----------------------------------------------------------------------
|
||
|
||
=back
|
||
|
||
=head1 SEE ALSO
|
||
|
||
L<UVtemplate>
|
||
|
||
=head1 AUTHOR
|
||
|
||
Cornell Binder <cobi@dex.de>
|
||
Marc Langer <usevote@marclanger.de>
|