UVformats.pm

   1 #----------------------------------------------------------------------
   2   package UVformats;
   3 #----------------------------------------------------------------------
   4
   5 =head1 NAME
   6
   7 UVformats - Methoden zur Stringformatierung
   8
   9 =head1 SYNOPSIS
  10
  11   value  <name-of-key>
  12   append <name-of-key>
  13
  14   fill-left   <width> <character>
  15   fill-right  <width> <character>
  16   fill-center <width> <character>
  17
  18   justify        <name-of-key> <width>
  19   justify-before <name-of-key> <width>
  20   justify-behind <name-of-key> <width>
  21
  22   first-words  <width>
  23   drop-words   <width>
  24   create-lines <width>
  25
  26   multi-graph <width> <position> <count>
  27   multi-line  <width> <count>
  28
  29   quote <string>
  30   replace <original-string> <replacement-string>
  31   sprintf <format-string>
  32
  33   generate_date_header
  34
  35 =head1 DESCRIPTION
  36
  37 Dieses Modul stellt verschiedenste Methoden bereit, um die Strings in
  38 den Templates auf die unterschiedlichste Art zu formatieren.
  39
  40 Dieses Modul beschraenkt sich auf die Beschreibung der Funktionen. Ihre
  41 Einbindung wird in UVtemplates beschrieben.
  42
  43 =head1 FUNCTIONS
  44
  45 =over 3
  46
  47 =cut
  48
  49 #----------------------------------------------------------------------
  50
  51 use strict;
  52 use vars qw(@ISA @EXPORT $VERSION $functions);
  53
  54 use Exporter;
  55 $VERSION = 0.01;
  56
  57 @ISA = qw(Exporter);
  58 @EXPORT = qw( getFunctions );
  59
  60 use Text::Wrap;
  61 #use POSIX qw(strftime);
  62 use Email::Date;
  63
  64 #----------------------------------------------------------------------
  65
  66 sub getFunctions{
  67   return $functions;
  68 }
  69
  70 #----------------------------------------------------------------------
  71 =item value
  72
  73 Gibt den Wert eines Schluessel zurueck.
  74
  75   new-key := value 'old-key' | <other-functions> ...
  76
  77 Diese Funktion sollte dann eingesetzt werden, wenn man einen virtuellen
  78 Schluessel erzeugen will. D.h. der Bezeichner nicht im Template als
  79 Schluessel vorhanden ist. Durch den Einsatz von value wird der Wert eines
  80 anderen Schluessel kopiert und kann dann weiter formatiert werden.
  81
  82 =cut
  83
  84 sub value{
  85   my ($data, $value, $key) = @_;
  86   return $data->getKey($key);
  87 }
  88
  89 #----------------------------------------------------------------------
  90
  91 =item append
  92
  93 Den Wert eines anderen Schluessels an den bisherigen String anhaengen.
  94
  95   ... | append 'other-key' | ...
  96
  97 Per default wird als Trenner der beiden String ein Leerzeichen verwendet.
  98 Soll dieses entfallen oder ein anderes Zeichen benutzt werden, so kann
  99 ein dementsprechender drittere Parameter angegeben werden.
 100
 101   ... | append 'other-key' ''  | ...
 102   ... | append 'other-key' '_' | ...
 103
 104 Im ersten Beispiel wird der Wert von C<other-key> nahtlos hinzugefuegt.
 105 Im zweiten statt des Leerzeichens '_' benutzt.
 106
 107 =cut
 108
 109 sub append{
 110   my ($data, $value, $key, $sep) = @_;
 111
 112   $sep = ' ' unless defined($sep);
 113
 114   return $value. $sep. $data->getConvKey($key);
 115 }
 116
 117 #----------------------------------------------------------------------
 118
 119 =item fill-left, fill-right, fill-center
 120
 121 Fuellt den String entsprechend mit Zeichen auf bis die gewuenschte
 122 Laenge erreicht ist. Bei C<fill-left> werden die Zeichen vorranggestellt,
 123 bei C<fill-right> angehaengt. C<fill-center> verteilt die Zeichen
 124 gleichmaessig vor und nach dem String.
 125
 126   ... | fill-left 72 '.' | ...
 127
 128 Wird kein zweiter Parameter angegeben, wird automatisch das Leerzeichen
 129 benutzt.
 130
 131   ... | fill-right 60 | ...
 132
 133 Ist der String bereits laenger als gewuenscht, wird er nicht weiter
 134 veraendert und auch nicht verkuerzt.
 135
 136 =cut
 137
 138 sub fill_left{
 139   my ($data, $value, $width, $char) = @_;
 140
 141   $width ||= 72;
 142   $char  = ' ' unless (defined($char) && length($char) == 1);
 143
 144   my $fill = $width - length($value);
 145
 146   $value = $char x $fill . $value if ($fill > 0);
 147
 148   return $value;
 149 }
 150
 151 sub fill_right{
 152   my ($data, $value, $width, $char) = @_;
 153
 154   $width ||= 72;
 155   $char  ||= ' ';
 156
 157   my $fill = $width - length($value);
 158
 159   $value .= $char x $fill if ($fill > 0);
 160
 161   return $value;
 162 }
 163
 164 sub fill_both{
 165   my ($data, $value, $width, $char) = @_;
 166
 167   $width ||= 72;
 168   $char  ||= ' ';
 169
 170   my $fill = $width - length($value);
 171
 172   if ($fill > 0){
 173     my $left  = int($fill / 2);
 174     my $right = $fill - $left;
 175
 176     $value = $char x $left . $value . $char x $right;
 177   }
 178
 179   return $value;
 180 }
 181
 182 #----------------------------------------------------------------------
 183
 184 =item justify, justify-before, justify-behind
 185
 186 Fuegt zwischen den existierenden String und dem Wert des angegebenen
 187 Schluessel genau so viele Leerzeichen ein, damit die gewuenschte
 188 Stringlaenge erreicht wird.
 189
 190   ... | justify-behind 'key' 72 | ...
 191
 192 C<justify-behind> haengt den Wert des Schluessel an das Ende des Strings,
 193 C<justify-before> stellt es davor.
 194
 195   justify-behind: existing-string.........value-of-key
 196   justify-before: value-of-key.........existing-string
 197
 198 C<justify> ist lediglich ein Alias auf C<justify-behind>.
 199
 200 Sind die beiden Strings zusammen länger als die gewuenschte
 201 Zeilenlaenge, wird automatisch einen Zeilenbruch eingefuegt
 202 und beide Zeilen entsprechend mit Leerzeichen gefuellt.
 203
 204   very-very-very-long-existing-string.........\n
 205   ...................and-a-too-long-new-string
 206
 207 =cut
 208
 209 sub justify_behind{
 210   my ($data, $value, $key, $width) = @_;
 211   return _justify( $value, $data->getConvKey($key), $width);
 212 }
 213
 214 sub justify_before{
 215   my ($data, $value, $key, $width) = @_;
 216   return _justify( $data->getConvKey($key), $value, $width);
 217 }
 218
 219 sub _justify{
 220   my ($lval, $rval, $width) = @_;
 221
 222   my $sep = ' ';
 223
 224   if (length($lval.$rval) >= $width ){
 225     # wir basteln zwei zeilen
 226     $lval .= $sep x ($width - length($lval));
 227     $rval = $sep x ($width - length($rval)) . $rval;
 228
 229     return $lval."\n".$rval;
 230
 231   }else{
 232     my $fill = $width - length($lval) - length($rval);
 233     return $lval . $sep x $fill . $rval;
 234   }
 235 }
 236
 237 #----------------------------------------------------------------------
 238
 239 =item first-words
 240
 241 Gibt nur die ersten Worte eines Strings zurueck, die vollstaendig
 242 innerhalb der angegebenen Laenge liegen.
 243
 244 =cut
 245
 246 sub first_words{
 247   my ($data, $value, $width) = @_;
 248
 249   my @words = split('\s+', $value);
 250   my $string;
 251
 252   $string .= shift(@words);
 253
 254   while(@words && (length($string) + length($words[0]) + 1) < $width){
 255     $string .= ' ' . shift(@words);
 256   }
 257
 258   return $string;
 259 }
 260
 261 =item drop-words
 262
 263 Alle Woerter am Anfang des Strings entfernen, die komplett innerhalb
 264 der angegebenen Laenge liegen.
 265
 266 =cut
 267
 268 sub drop_words{
 269   my ($data, $value, $width) = @_;
 270
 271   my @words = split('\s+', $value);
 272
 273   # das erste "Wort" immer verwerfen, egal wie lang es ist
 274   my $first  = shift(@words);
 275   my $length = length($first);
 276
 277   while (@words && ( $length + length($words[0]) + 1 ) < $width ){
 278     $length += length($words[0]) + 1;
 279     shift(@words);
 280   }
 281
 282   return join(' ', @words);
 283 }
 284
 285 =item create-lines
 286
 287 Zerlegt einen String in einen Array, in dem die einzelnen Zeilen nicht
 288 laenger als die gewuenschte Anzahl Zeichen sind.
 289
 290   absatz := value 'key' | create-lines 72
 291
 292 Mit Hilfe dieser Funktion ist es moeglich, ueberlange Zeilen zu Absatzen
 293 umzuformatieren.
 294
 295 Die Funktion erzeugt intern eine Liste, die jeweils den Schluessel C<line>
 296 mit dem entsprechenden String als Wert enthaelt.
 297
 298 Im Template wird der so Absatz dann mit Hilfe des Schleifen-Syntax
 299 eingebunden:
 300
 301   [@absatz|[line]\n]
 302
 303 Achtung! Da die Funktion keinen String zurueckgibt, sollte sie am Ende
 304 der Kette stehen, da die normalen Formatierungsfunktionen einen String
 305 als Input erwartern!
 306
 307 =cut
 308
 309 sub create_lines{
 310   my ($data, $value, $width) = @_;
 311
 312   my @words = split('\s+', $value);
 313
 314   my @lines;
 315
 316   while (@words){
 317     my $string .= shift(@words);
 318
 319     while(@words && (length($string) + length($words[0]) + 1) < $width){
 320       $string .= ' ' . shift(@words);
 321     }
 322
 323     my $new = $data->new( line => $string );
 324     push(@lines, $new);
 325   }
 326
 327   return \@lines;
 328 }
 329
 330 #----------------------------------------------------------------------
 331
 332 =item multi-graph, multi-line
 333
 334 Spezielle Funktionen, um eine bestimmte graphische Ausgabe fuer
 335 Votings mit mehreren Abstimmungspunkten zu erzeugen:
 336
 337   Punkt 1 --------------------------+
 338   Punkt 2a ------------------------+|
 339   Punkt 2b -----------------------+||
 340   Punkt 3 -----------------------+|||
 341                                  ||||
 342   Name of Voter 1                jjnn
 343   Name of Voter 2                nnjj
 344
 345 C<multi-graph> ist hierbei für die Formatierung der einzelnen Abstimmungspunkte
 346 zustaendig.
 347
 348   multi-graph 'key' 'width' 'pos-key' 'max-key'
 349
 350 Der erste Parameter gibt den Schluessel an, dessen Wert als Abstimmungspunkt
 351 ausgegeben werden soll. C<width> die Laenge des zu erzeugenden Strings.
 352 C<pos-key> und C<max-key> sind die Namen der Schluessel, in denen stehen
 353 muss, um den wievielten Abstimmungspunkt es sich handelt (per default 'pos')
 354 und wieviele Abstimmungspunkte es insgesamt gibt ('anzpunkte').
 355
 356 C<multi-line> erzeugt einfach nur einen String in der gewuenschten
 357 Laenge, der entsprechend der Anzahl der Abstimmungspunkte mit '|'
 358 abschliesst.
 359
 360 =cut
 361
 362 sub mgraph{
 363   my ($data, $value, $width, $pkey, $okey) = @_;
 364   return unless $data;
 365
 366   my $pos = $data->getKey($pkey || 'pos');
 367   my $of  = $data->getKey($okey || 'anzpunkte');
 368
 369   my $gfx = '';
 370
 371   $gfx = ' ---'.'-' x ($of-$pos) .'+'. '|' x ($pos - 1) if ($pos && $of);
 372
 373   if (length($value.$gfx) < $width){
 374     $value = ' ' x ($width - length($value.$gfx)) . $value . $gfx;
 375
 376   }elsif (length($value.$gfx) > $width){
 377     my @lines = _wrap($value, $width - length($gfx));
 378
 379     $value = shift(@lines) . $gfx;
 380     $value = ' ' x ($width - length($value)) . $value;
 381
 382     # Hilfzeile erzeugen
 383     $gfx = '    '.' ' x ($of-$pos) . '|' x ($pos) if ($pos && $of);
 384
 385     foreach my $line (@lines){
 386       $value .= "\n".' ' x ($width - length($line.$gfx)) . $line . $gfx;
 387     }
 388   }
 389
 390   return $value;
 391 }
 392
 393 sub mgline{
 394   my ($data, undef, $width, $okey) = @_;
 395   return unless $data;
 396
 397   my $of = $data->getKey($okey || 'anzpunkte') || 0;
 398
 399   return ' ' x ($width - $of) . '|' x $of;
 400 }
 401
 402
 403 sub _wrap{
 404   my ($string, $width) = @_;
 405
 406   my @words = split('\s+', $string);
 407
 408   my @lines;
 409
 410   while (@words){
 411     my $line .= shift(@words);
 412
 413     while(@words && (length($line) + length($words[0]) + 1) < $width){
 414       $line .= ' ' . shift(@words);
 415     }
 416
 417     push(@lines, $line);
 418   }
 419
 420   return @lines;
 421 }
 422
 423
 424 #----------------------------------------------------------------------
 425
 426 =item quote
 427
 428 Stellt in einem (mehrzeiligem) String jeder Zeile den gewuenschten
 429 Quotestring voran.
 430
 431   body := value 'body' | quote '> '
 432
 433 =cut
 434
 435 sub quote{
 436   my ($data, $value, $quotechar) = @_;
 437
 438   $quotechar = '> ' unless defined($quotechar);
 439
 440   $value =~ s/^/$quotechar/mg;
 441   return $value;
 442 }
 443
 444
 445 #----------------------------------------------------------------------
 446
 447 =item replace
 448
 449 Ersetzt in einem String ein oder mehrere Zeichen durch eine beliebige
 450 Anzahl anderer Zeichen. Diese Funktion kann z.B. genutzt werden, um
 451 beim Result die Mailadressen zu verfremden (Schutz vor Adress-Spidern).
 452
 453   mail := value 'mail' | replace '@' '-at-'
 454
 455 =cut
 456
 457 sub replace{
 458   my ($data, $value, $original, $replacement) = @_;
 459
 460   $original = ' ' unless defined($original);
 461   $replacement = ' ' unless defined($replacement);
 462
 463   $value =~ s/\Q$original\E/$replacement/g;
 464   return $value;
 465 }
 466
 467
 468 #----------------------------------------------------------------------
 469
 470 =item sprintf
 471
 472 Gibt Text oder Zahlen mittels der Funktion sprintf formatiert aus
 473 (siehe "man 3 sprintf" oder "perldoc -f sprintf").
 474
 475   proportion := value 'proportion' | sprintf '%6.3f'
 476
 477 =cut
 478
 479 sub sprintf{
 480   my ($data, $value, $format) = @_;
 481
 482   $format = '%s' unless defined($format);
 483
 484   return sprintf($format, $value);
 485 }
 486
 487
 488 #----------------------------------------------------------------------
 489
 490 =item generate_date_header
 491
 492 Gibt ein Datum im RFC822-Format zur Verwendung im Date:-Header einer
 493 Mail aus.
 494
 495   date := generate_date_header
 496
 497 =cut
 498
 499 sub generate_date_header{
 500   my ($data, $value, $format) = @_;
 501   #return strftime('%a, %d %b %Y %H:%M:%S %z', localtime);
 502   return format_date;
 503 }
 504
 505 #----------------------------------------------------------------------
 506
 507 =item generate_msgid
 508
 509 Gibt eine Message-ID im RFC822-Format zur Verwendung im Message-ID:-Header
 510 einer Mail aus.
 511
 512   msgid := generate_msgid
 513
 514 =cut
 515
 516 sub generate_msgid{
 517   return ("<".$$.time().rand(999)."\@".$UVconfig::config{fqdn}.">");
 518 }
 519
 520
 521 #----------------------------------------------------------------------
 522
 523 BEGIN{
 524   %UVconfig::functions = ( %UVconfig::functions,
 525     value               => \&value,
 526     append              => \&append,
 527
 528     'fill-left'         => \&fill_left,
 529     'fill-right'        => \&fill_right,
 530     'fill-both'         => \&fill_both,
 531
 532     justify             => \&justify_behind,
 533     'justify-behind'    => \&justify_behind,
 534     'justify-before'    => \&justify_before,
 535
 536     'first-words'       => \&first_words,
 537     'drop-words'        => \&drop_words,
 538
 539     'create-lines'      => \&create_lines,
 540
 541     'multi-graph'       => \&mgraph,
 542     'multi-line'        => \&mgline,
 543
 544     'quote'             => \&quote,
 545     'replace'           => \&replace,
 546     'sprintf'           => \&sprintf,
 547
 548     'generate-date-header' => \&generate_date_header,
 549     'generate-msgid'    => \&generate_msgid
 550   );
 551 }
 552
 553 1;
 554
 555 #----------------------------------------------------------------------
 556
 557 =back
 558
 559 =head1 SEE ALSO
 560
 561 L<UVtemplate>
 562
 563 =head1 AUTHOR
 564
 565 Cornell Binder <cobi@dex.de>
 566 Marc Langer <usevote@marclanger.de>