SL/Presenter/Tag.pm

   1 package SL::Presenter::Tag;
   2
   3 use strict;
   4
   5 use parent qw(Exporter);
   6
   7 use Exporter qw(import);
   8 our @EXPORT = qw(html_tag input_tag man_days_tag name_to_id select_tag stringify_attributes);
   9
  10 use Carp;
  11
  12 my %_valueless_attributes = map { $_ => 1 } qw(
  13   checked compact declare defer disabled ismap multiple noresize noshade nowrap
  14   readonly selected
  15 );
  16
  17 sub _call_on {
  18   my ($object, $method, @params) = @_;
  19   return $object->$method(@params);
  20 }
  21
  22 { # This will give you an id for identifying html tags and such.
  23   # It's guaranteed to be unique unless you exceed 10 mio calls per request.
  24   # Do not use these id's to store information across requests.
  25 my $_id_sequence = int rand 1e7;
  26 sub _id {
  27   return ( $_id_sequence = ($_id_sequence + 1) % 1e7 );
  28 }
  29 }
  30
  31
  32 sub stringify_attributes {
  33   my ($self, %params) = @_;
  34
  35   my @result = ();
  36   while (my ($name, $value) = each %params) {
  37     next unless $name;
  38     next if $_valueless_attributes{$name} && !$value;
  39     $value = '' if !defined($value);
  40     push @result, $_valueless_attributes{$name} ? $self->escape($name) : $self->escape($name) . '="' . $self->escape($value) . '"';
  41   }
  42
  43   return @result ? ' ' . join(' ', @result) : '';
  44 }
  45
  46 sub html_tag {
  47   my ($self, $tag, $content, %params) = @_;
  48   my $attributes = $self->stringify_attributes(%params);
  49
  50   return "<${tag}${attributes}>" unless defined($content);
  51   return "<${tag}${attributes}>${content}</${tag}>";
  52 }
  53
  54 sub input_tag {
  55   my ($self, $name, $value, %attributes) = @_;
  56
  57   _set_id_attribute(\%attributes, $name);
  58   $attributes{type} ||= 'text';
  59
  60   return $self->html_tag('input', undef, %attributes, name => $name, value => $value);
  61 }
  62
  63 sub man_days_tag {
  64   my ($self, $name, $object, %attributes) = @_;
  65
  66   my $size           =  delete($attributes{size})   || 5;
  67   my $method         =  $name;
  68   $method            =~ s/^.*\.//;
  69
  70   my $time_selection =  $self->input_tag( "${name}_as_man_days_string", _call_on($object, "${method}_as_man_days_string"), %attributes, size => $size);
  71   my $unit_selection =  $self->select_tag("${name}_as_man_days_unit",   [[ 'h', $::locale->text('h') ], [ 'man_day', $::locale->text('MD') ]],
  72                                           %attributes, default => _call_on($object, "${method}_as_man_days_unit"));
  73
  74   return $time_selection . $unit_selection;
  75 }
  76
  77 sub name_to_id {
  78   my ($self, $name) = @_;
  79
  80   $name =~ s/\[\+?\]/ _id() /ge; # give constructs with [] or [+] unique ids
  81   $name =~ s/[^\w_]/_/g;
  82   $name =~ s/_+/_/g;
  83
  84   return $name;
  85 }
  86
  87 sub select_tag {
  88   my ($self, $name, $collection, %attributes) = @_;
  89
  90   _set_id_attribute(\%attributes, $name);
  91
  92   my $value_key       = delete($attributes{value_key})   || 'id';
  93   my $title_key       = delete($attributes{title_key})   || $value_key;
  94   my $default_key     = delete($attributes{default_key}) || 'selected';
  95
  96
  97   my $value_title_sub = delete($attributes{value_title_sub});
  98
  99   my $value_sub       = delete($attributes{value_sub});
 100   my $title_sub       = delete($attributes{title_sub});
 101   my $default_sub     = delete($attributes{default_sub});
 102
 103   my $with_empty      = delete($attributes{with_empty});
 104   my $empty_title     = delete($attributes{empty_title});
 105
 106   my $with_optgroups  = delete($attributes{with_optgroups});
 107
 108   my %selected;
 109
 110   if ( ref($attributes{default}) eq 'ARRAY' ) {
 111
 112     foreach my $entry (@{$attributes{default}}) {
 113       $selected{$entry} = 1;
 114     }
 115   } elsif ( defined($attributes{default}) ) {
 116     $selected{$attributes{default}} = 1;
 117   }
 118
 119   delete($attributes{default});
 120
 121   my $normalize_entry = sub {
 122     my ($type, $entry, $sub, $key) = @_;
 123
 124     return $sub->($entry) if $sub;
 125
 126     my $ref = ref($entry);
 127
 128     if ( !$ref ) {
 129       return $entry if $type eq 'value' || $type eq 'title';
 130       return 0;
 131     }
 132
 133     if ( $ref eq 'ARRAY' ) {
 134       return $entry->[ $type eq 'value' ? 0 : $type eq 'title' ? 1 : 2 ];
 135     }
 136
 137     return $entry->{$key} if $ref  eq 'HASH';
 138     return $entry->$key   if $type ne 'default' || $entry->can($key);
 139     return undef;
 140   };
 141
 142   my $list_to_code = sub {
 143     my ($sub_collection) = @_;
 144
 145     my @options;
 146     foreach my $entry ( @{ $sub_collection } ) {
 147       my $value;
 148       my $title;
 149
 150       if ( $value_title_sub ) {
 151         ($value, $title) = @{ $value_title_sub->($entry) };
 152       } else {
 153
 154         $value = $normalize_entry->('value', $entry, $value_sub, $value_key);
 155         $title = $normalize_entry->('title', $entry, $title_sub, $title_key);
 156       }
 157
 158       my $default = $normalize_entry->('default', $entry, $default_sub, $default_key);
 159
 160       push(@options, [$value, $title, $default]);
 161     }
 162
 163     foreach my $entry (@options) {
 164       $entry->[2] = 1 if $selected{$entry->[0]};
 165     }
 166
 167     return join '', map { $self->html_tag('option', $self->escape($_->[1]), value => $_->[0], selected => $_->[2]) } @options;
 168   };
 169
 170   my $code  = '';
 171   $code    .= $self->html_tag('option', $self->escape($empty_title || ''), value => '') if $with_empty;
 172
 173   if (!$with_optgroups) {
 174     $code .= $list_to_code->($collection);
 175
 176   } else {
 177     $code .= join '', map {
 178       my ($optgroup_title, $sub_collection) = @{ $_ };
 179       $self->html_tag('optgroup', $list_to_code->($sub_collection), label => $optgroup_title)
 180     } @{ $collection };
 181   }
 182
 183   return $self->html_tag('select', $code, %attributes, name => $name);
 184 }
 185
 186 sub _set_id_attribute {
 187   my ($attributes, $name) = @_;
 188
 189   $attributes->{id} = name_to_id(undef, $name) if !delete($attributes->{no_id}) && !$attributes->{id};
 190
 191   return %{ $attributes };
 192 }
 193
 194 1;
 195 __END__
 196
 197 =pod
 198
 199 =encoding utf8
 200
 201 =head1 NAME
 202
 203 SL::Presenter::Tag - Layouting / tag generation
 204
 205 =head1 SYNOPSIS
 206
 207 Usage from a template:
 208
 209   [% USE P %]
 210
 211   [% P.select_tag('direction', [ [ 'left', 'To the left' ], [ 'right', 'To the right', 1 ] ]) %]
 212
 213   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 214                                  { direction => 'right', display => 'To the right' } ],
 215                                value_key => 'direction', title_key => 'display', default => 'right')) %]
 216
 217   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 218                                  { direction => 'right', display => 'To the right', selected => 1 } ],
 219                                value_key => 'direction', title_key => 'display')) %]
 220
 221 =head1 DESCRIPTION
 222
 223 A module modeled a bit after Rails' ActionView helpers. Several small
 224 functions that create HTML tags from various kinds of data sources.
 225
 226 The C<id> attribute is usually calculated automatically. This can be
 227 overridden by either specifying an C<id> attribute or by setting
 228 C<no_id> to trueish.
 229
 230 =head1 FUNCTIONS
 231
 232 =head2 LOW-LEVEL FUNCTIONS
 233
 234 =over 4
 235
 236 =item C<html_tag $tag_name, $content_string, %attributes>
 237
 238 Creates an opening and closing HTML tag for C<$tag_name> and puts
 239 C<$content_string> between the two. If C<$content_string> is undefined
 240 or empty then only a E<lt>tag/E<gt> tag will be created. Attributes
 241 are key/value pairs added to the opening tag.
 242
 243 C<$content_string> is not HTML escaped.
 244
 245 =item C<name_to_id $name>
 246
 247 Converts a name to a HTML id by replacing various characters.
 248
 249 =item C<stringify_attributes %items>
 250
 251 Creates a string from all elements in C<%items> suitable for usage as
 252 HTML tag attributes. Keys and values are HTML escaped even though keys
 253 must not contain non-ASCII characters for browsers to accept them.
 254
 255 =back
 256
 257 =head2 HIGH-LEVEL FUNCTIONS
 258
 259 =over 4
 260
 261 =item C<input_tag $name, $value, %attributes>
 262
 263 Creates a HTML 'input type=text' tag named C<$name> with the value
 264 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 265 tag's C<id> defaults to C<name_to_id($name)>.
 266
 267 =item C<man_days_tag $name, $object, %attributes>
 268
 269 Creates two HTML inputs: a text input for entering a number and a drop
 270 down box for chosing the unit (either 'man days' or 'hours').
 271
 272 C<$object> must be a L<Rose::DB::Object> instance using the
 273 L<SL::DB::Helper::AttrDuration> helper.
 274
 275 C<$name> is supposed to be the name of the underlying column,
 276 e.g. C<time_estimation> for an instance of
 277 C<SL::DB::RequirementSpecItem>. If C<$name> has the form
 278 C<prefix.method> then the full C<$name> is used for the input's base
 279 names while the methods called on C<$object> are only the suffix. This
 280 makes it possible to write statements like e.g.
 281
 282   [% P.man_days_tag("requirement_spec_item.time_estimation", SELF.item) %]
 283
 284 The attribute C<size> can be used to set the text input's size. It
 285 defaults to 5.
 286
 287 =item C<select_tag $name, \@collection, %attributes>
 288
 289 Creates a HTML 'select' tag named C<$name> with the contents of one
 290 'E<lt>optionE<gt>' tag for each element in C<\@collection> and with arbitrary
 291 HTML attributes from C<%attributes>. The value
 292 to use and the title to display are extracted from the elements in
 293 C<\@collection>. Each element can be one of four things:
 294
 295 =over 12
 296
 297 =item 1. An array reference with at least two elements. The first element is
 298 the value, the second element is its title. The third element is optional and and should contain a boolean.
 299 If it is true, than the element will be used as default.
 300
 301 =item 2. A scalar. The scalar is both the value and the title.
 302
 303 =item 3. A hash reference. In this case C<%attributes> must contain
 304 I<value_key>, I<title_key> and may contain I<default_key> keys that name the keys in the element to use
 305 for the value, title and default respectively.
 306
 307 =item 4. A blessed reference. In this case C<%attributes> must contain
 308 I<value_key>, I<title_key> and may contain I<default_key> keys that name functions called on the blessed
 309 reference whose return values are used as the value, title and default
 310 respectively.
 311
 312 =back
 313
 314 For cases 3 and 4 C<$attributes{value_key}> defaults to C<id>,
 315 C<$attributes{title_key}> defaults to C<$attributes{value_key}>
 316 and C<$attributes{default_key}> defaults to C<selected>.
 317
 318 In addition to pure keys/method you can also provide coderefs as I<value_sub>
 319 and/or I<title_sub> and/or I<default_sub>. If present, these take precedence over keys or methods,
 320 and are called with the element as first argument. It must return the value, title or default.
 321
 322 Lastly a joint coderef I<value_title_sub> may be provided, which in turn takes
 323 precedence over the C<value_sub> and C<title_sub> subs. It will only be called once for each
 324 element and must return a list of value and title.
 325
 326 If the option C<with_empty> is set then an empty element (value
 327 C<undef>) will be used as the first element. The title to display for
 328 this element can be set with the option C<empty_title> and defaults to
 329 an empty string.
 330
 331 The option C<default> can be either a scalar or an array reference
 332 containing the values of the options which should be set to be
 333 selected.
 334
 335 The tag's C<id> defaults to C<name_to_id($name)>.
 336
 337 If the option C<with_optgroups> is set then this function expects
 338 C<\@collection> to be one level deeper. The upper-most level is
 339 translated into a HTML C<optgroup> tag. So the structure becomes:
 340
 341 =over 4
 342
 343 =item 1. Array of array references. Each element in the
 344 C<\@collection> is converted into an optgroup.
 345
 346 =item 2. The optgroup's C<label> attribute will be set to the the
 347 first element in the array element. The second array element is then
 348 converted to a list of C<option> tags like it is described above.
 349
 350 =back
 351
 352 Example for use of optgroups:
 353
 354   # First in a controller:
 355   my @collection = (
 356     [ t8("First optgroup with two items"),
 357       [ { id => 42, name => "item one" },
 358         { id => 54, name => "second item" },
 359         { id => 23, name => "and the third one" },
 360       ] ],
 361     [ t8("Another optgroup, with a lot of items from Rose"),
 362       SL::DB::Manager::Customer->get_all_sorted ],
 363   );
 364
 365   # Later in the template:
 366   [% L.select_tag('the_selection', COLLECTION, with_optgroups=1, title_key='name') %]
 367
 368 =back
 369
 370 =head1 BUGS
 371
 372 Nothing here yet.
 373
 374 =head1 AUTHOR
 375
 376 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 377 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 378
 379 =cut