Perlbug::Object::Template - Template class
Index
AUTHOR
Code Index:
NAME
Perlbug::Object::Template - Template class
DESCRIPTION
Applies a template to the data generated by Perlbug::Format.
Each user may apply a template to each object | type.
Defaults for a particular type of object (eg; mail, flag, ...) may be
applied by enabling the type column instead of the object one.
For inherited methods, see Perlbug::Object
SYNOPSIS
use Perlbug::Object::Template;
my $o_tmp = Perlbug::Object:;Template->new();
print $o_tmp->object('bug')->read('19870502.007')->template('h');
ARGUMENTS
PLACEHOLDERS
Placeholders in templates look like this: <{datacol}> and <{rel_ids}> etc.
Example using bug object:
Column names:
bugid: <{bugid}>
created: <{created}>
author: <{sourceaddr}>
subject: <{subject}>
Relationships:
message count(<{message_count}>)
messageids: <{message_ids}>
patch ids: <{patch_ids}>
admins: <{user_names}>
CC list: <{address_names}>
status: <{status_names}>
<{ifadmin}>
this bit only if admin
</{ifadmin}>
To assist with formatting of ascii templates, an integer followed by white space may be placed between the last two special characters of the placeholders. The (internal) white space will be stripped, and the number will be used to pad out the given variable, with spaces, using sprintf to that length.
N.B. this will not trim the field, but pad it.
bugid: <{bugid}15 > status: <{status_names}>
severity: <{severity_names} 15 > osname: <{osname_names}>
messages: <{message_count} 15 > <{message_ids}>
will produce
bugid: 19870502.007 status: open
severity: high osname: linux aix etc.
messages: 5 22 23 41 72 102
METHODS
Create new Template object:
my $o_merge = Perlbug::Object::Template->new();
Return template id given current object key type and perhaps format and/or user
my $templateid = $o_tmp->object2id('bug', ['a', ['perlbug']]);
Return catchall object data laid out against format(a).
Long lines will be wrapped - if you want a better format, define a template :-)
my $str = $o_tmp->_merge($h_data, $h_rels);
my $str = $o_tmp->_merge($h_data, $h_rels, [$fmt]);
Return object in template layout according to format(a), relations are called from the object given.
my ($hdr, $str, $ftr) = $o_tmp->merge($o_obj, $fmt, [\%data, \%rels]);
If no template found, calls _merge()
Add a little extra to the data, as a helper for default templates
my $h_data = $o_tmp->xtra($key, $o_obj->oid, $h_attr);
AUTHOR
Richard Foley perlbug@rfi.net 2001
# Perlbug bug record handler
# (C) 1999 Richard Foley RFI perlbug@rfi.net
# $Id: Template.pm,v 1.10 2001/12/05 20:58:38 richardf Exp $
#
package Perlbug::Object::Template;
use strict;
use Text::Wrap;
use vars qw($VERSION @ISA);
$VERSION = do { my @r = (q$Revision: 1.10 $ =~ /\d+/go); sprintf "%d."."%02d" x $#r, @r };
$|=1;
use Data::Dumper;
use HTML::Entities;
use Perlbug::Object;
@ISA = qw(Perlbug::Object);
my $o_Perlbug_Base = undef;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
$o_Perlbug_Base = (ref($_[0])) ? shift : Perlbug::Base->new();
my $self = Perlbug::Object->new( $o_Perlbug_Base,
'name' => 'Template',
'from' => [qw(user)],
'to' => [qw()],
);
bless($self, $class);
}
sub object2id {
my $self = shift;
my $obj = shift;
my $fmt = shift || $self->base->current('format');
my $userid = shift || $self->base->isadmin;
my $tempid = '';
my $straight = "object = '$obj' AND ".$self->base->db->case_sensitive('format', $fmt);
my @tmpids = $self->ids($straight);
$self->debug(3, "straight($straight) => tmpids(@tmpids)") if $Perlbug::DEBUG;
if (scalar(@tmpids) == 0) { # default?
my ($type) = $self->object('object')->col('type', "name = '$obj'");
my $default = "type = '$type' AND ".$self->base->db->case_sensitive('format', $fmt);
@tmpids = $self->ids($default);
$self->debug(3, "default($default) => tmpids(@tmpids)") if $Perlbug::DEBUG;
}
if (scalar(@tmpids) == 1) { # gotcha
($tempid) = @tmpids;
} elsif (scalar(@tmpids) > 1) { # shrinkit
my $tmpids = join("', '", @tmpids);
my $user = 'templateid', "userid = '$userid' AND templateid IN('$tmpids')";
my @utmpids = $self->rel('user')->col($user);
$self->debug(3, "user($user) => tmpids(@utmpids)") if $Perlbug::DEBUG;
@tmpids = @utmpids if scalar(@utmpids) >= 1;
($tempid) = reverse sort { $a <=> $b } @tmpids; # latest in every case
} # else zip found
$self->debug((($tempid) ? 2 : 0), "obj($obj) fmt($fmt) user($userid) => templateid($tempid)") if $Perlbug::DEBUG;
return $tempid;
}
sub _merge {
my $self = shift;
my $h_data = shift;
my $h_rels = shift;
my $fmt = shift || $self->base->current('format');
my $str = '';
if (ref($h_data) ne 'HASH' or ref($h_rels) ne 'HASH') {
$self->error("non-valid required args: data_href($h_data) and rels_href($h_rels)!");
} else {
my $h_dat = $self->format_fields({%{$h_data}, %{$h_rels}}, $fmt); # i_max?
my $br = "\n";
my ($dmax) = reverse sort {$a <=> $b} map { length($_) } keys %{$h_data};
my ($rmax) = reverse sort {$a <=> $b} map { length($_) } keys %{$h_rels};
# $^W = 0;
$str .= "DATA:$br";
DATA:
foreach my $xdata (sort keys %{$h_data}) {
$str .= ' '.sprintf('%-'.$dmax.'s', $xdata).' = '.$$h_dat{$xdata}.$br;
}
$str .= "RELATIONS:$br";
my $xmax = '%-'.($rmax + 8).'s'; # '$rel (ids|names): '
RELS:
foreach my $rel (sort keys %{$h_rels}) {
if ($fmt =~ /^[a-z]$/) {
my $tgt = 'count';
if ($$h_dat{$rel.'_'.$tgt}) {
$str .= ' '.sprintf($xmax, "$rel $tgt: ").$$h_dat{$rel.'_'.$tgt}.$br;
}
} else {
foreach my $tgt (sort qw(count ids names)) {
if ($$h_dat{$rel.'_'.$tgt}) {
$str .= ' '.sprintf($xmax, "$rel $tgt: ").$$h_dat{$rel.'_'.$tgt}.$br;
}
}
}
}
# $^W = 1;
if ($self->base->current('context') eq 'http' && $fmt !~ /[hHIL]/) {
# encode_entities done in format_fields
$str = '<pre>'.$str.'</pre>'; # maintain formatting
} elsif ($self->data('wrap') =~ /^([1-9])/o) { # WRAP
$str = wrap('', '', $str) if $str; # .
}
$self->debug(3, "str($str)") if $Perlbug::DEBUG;
}
return $str;
}
sub merge {
my $self = shift;
my $o_obj = shift;
my $fmt = shift;
my $h_data = shift || $o_obj->_oref('data');
my $h_rels = shift;
my ($hdr, $str, $ftr) = ('', '', '');
if (!(ref($o_obj) && $fmt =~ /^\w$/ && ref($h_data) eq 'HASH')) {
$self->error("required args: obj($o_obj), fmt($fmt), h_data($h_data)!");
} else {
my $obj = $o_obj->key;
my $tempid = $self->object2id($obj, $fmt);
my $i_read = ($tempid =~ /\d+/ && $self->read($tempid)->READ) ? 1 : 0;
my $h_attr = ($fmt =~ /[dD]/) ? $o_obj->_oref('attr') : {};
$self->debug(2, "temp($tempid) read($i_read)") if $Perlbug::DEBUG;
if (!($tempid && $i_read)) { # long way to do it
$h_rels = $o_obj->refresh_relations()->_oref('relation');
$h_data = $self->xtra($h_data, $obj, $o_obj->oid, $h_attr);
$str = $self->_merge($h_data, $h_rels, $fmt);
} else { # a bit snappier now with rr() [ except message/s ]
($hdr, $str, $ftr) = map { $self->data($_) || '' } qw(header body footer);
# $hdr = $self->data('header') || '';
# $str = $self->data('body') || '';
# $ftr = $self->data('footer') || '';
#($hdr, $str, $ftr) = map { s/\Q<{ifadmin}>\E.*?(\<\/\Q{ifadmin}>\E)//gimos }
# ($hdr, $str, $ftr) unless $self->base->isadmin;
unless ($self->base->isadmin) {
$hdr =~ s/\Q<{ifadmin}>\E.*?(\<\/\Q{ifadmin}>\E)//gimos if $hdr;
$str =~ s/\Q<{ifadmin}>\E.*?(\<\/\Q{ifadmin}>\E)//gimos if $str;
$ftr =~ s/\Q<{ifadmin}>\E.*?(\<\/\Q{ifadmin}>\E)//gimos if $ftr;
}
my $tmp = $hdr.$str.$ftr;
$self->debug(3, "template: \n$tmp") if $Perlbug::DEBUG;
my %map = ();
%map = map { $_ => ++$map{$_} } ($tmp =~
/<{([a-z]+)(?:_count|id|_ids|_names)}[\s\d]*>/gi); # better _with_ ids|names?
$h_rels = $o_obj->refresh_relations(keys %map)->_oref('relation') unless $h_rels;
$self->debug(3, "rels: ".Dumper($h_rels)) if $Perlbug::DEBUG;
my $h_dat = $o_obj->format_fields({%{$h_data}, %{$h_rels}}, $fmt);
$$h_dat{'id4key'} = $$h_dat{$obj.'id'}; # helpful
$$h_dat{'key'} = $obj; #
$self->debug(3, "data: ".Dumper($h_dat)) if $Perlbug::DEBUG;
# $^W = 0;
my %seen = ();
DATA:
foreach my $data (keys %{$h_dat}) {
my $replace = $$h_dat{$data};
if (ref($data) eq 'HASH') {
$seen{ref($data)}++;
redo DATA unless $seen{ref($data)} >= 9; # ?-]
} elsif (ref($$h_dat{$data}) eq 'ARRAY') {
$replace = join(', ', @{$$h_dat{$data}});
}
# ($hdr, $str, $ftr) = map { s/\<\{$data\}\s*(\d*)\s*\>/sprintf('%-'.($1).'s', $replace)/gmsie } ($hdr, $str, $ftr);
$hdr =~ s/\<\{$data\}\s*(\d*)\s*\>/sprintf('%-'.($1).'s', $replace)/gmsie if $hdr;
$str =~ s/\<\{$data\}\s*(\d*)\s*\>/sprintf('%-'.($1).'s', $replace)/gmsie if $str;
$ftr =~ s/\<\{$data\}\s*(\d*)\s*\>/sprintf('%-'.($1).'s', $replace)/gmsie if $ftr;
}
# $^W = 1;
my $blank = ($self->base->current('context') eq 'http') ? ' ' : ' ';
# ($hdr, $str, $ftr) = map { $_ =~ s/\<\/{0,1}\{\w+\}\>/$blank/gimos } ($hdr, $str, $ftr);
$hdr =~ s/\<\/{0,1}\{\w+\}\>/$blank/gimos if $hdr;
$str =~ s/\<\/{0,1}\{\w+\}\>/$blank/gimos if $str;
$ftr =~ s/\<\/{0,1}\{\w+\}\>/$blank/gimos if $ftr;
#($hdr, $str, $ftr) = map { wrap('', '', $_) } ($hdr, $str, $ftr)
# if $self->data('wrap') =~ /^([1-9])/o; # WRAP
if ($self->data('wrap') =~ /^([1-9])/o) { # WRAP
$hdr = wrap('', '', $hdr) if $hdr; # $1
$str = wrap('', '', $str) if $str; # .
$ftr = wrap('', '', $ftr) if $ftr; # .
}
#($hdr, $str, $ftr) = map { '<pre>'.$_.'</pre>' } ($hdr, $str, $ftr)
# if $self->base->current('context') eq 'http' && $fmt !~ /[hHIL]/;
if ($self->base->current('context') eq 'http' && $fmt !~ /[hHIL]/) {
$hdr = '<pre>'.$hdr.'</pre>' if $hdr; #
$str = '<pre>'.$str.'</pre>' if $str; #
$ftr = '<pre>'.$ftr.'</pre>' if $ftr; #
}
}
}
$self->debug(3, "obj($o_obj) fmt($fmt) => hdr($hdr) str($str) ftr($ftr)") if $Perlbug::DEBUG;
return ($hdr, $str, $ftr);
}
sub xtra {
my $self = shift;
my $h_data = shift;
my $key = shift || 'unknown-obj';
my $oid = shift || 'unknown-oid';
my $h_attr = shift || {};
$$h_data{'attr'} = $h_attr;
$$h_data{'id4key'} = $oid; # santa's little helper
$$h_data{'key'} = $key; # for default templates
return $h_data;
}
sub xadmin { # remove <{ifadmin}>'s unless isadmin
}
sub strim { # remove <{\w+}>'s
}
sub pre { # <pre>@_</pre>
}
sub wrap { # wrap if i_wrap
}
1;