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 $default         = delete($attributes{default});
 109
 110   my $normalize_entry = sub {
 111     my ($type, $entry, $sub, $key) = @_;
 112
 113     return $sub->($entry) if $sub;
 114
 115     my $ref = ref($entry);
 116
 117     if ( !$ref ) {
 118       return $entry if $type eq 'value' || $type eq 'title';
 119       return 0;
 120     }
 121
 122     if ( $ref eq 'ARRAY' ) {
 123       return $entry->[ $type eq 'value' ? 0 : $type eq 'title' ? 1 : 2 ];
 124     }
 125
 126     return $entry->{$key} if $ref  eq 'HASH';
 127     return $entry->$key   if $type ne 'default' || $entry->can($key);
 128     return undef;
 129   };
 130
 131   my %selected = map { ( $normalize_entry->('value', $_, $default_sub, $default_key) => 1 ) }
 132                      (@{ ref($default) eq 'ARRAY' ? $default : [ $default ]});
 133
 134   my $list_to_code = sub {
 135     my ($sub_collection) = @_;
 136
 137     my @options;
 138     foreach my $entry ( @{ $sub_collection } ) {
 139       my $value;
 140       my $title;
 141
 142       if ( $value_title_sub ) {
 143         ($value, $title) = @{ $value_title_sub->($entry) };
 144       } else {
 145
 146         $value = $normalize_entry->('value', $entry, $value_sub, $value_key);
 147         $title = $normalize_entry->('title', $entry, $title_sub, $title_key);
 148       }
 149
 150       my $default = $normalize_entry->('default', $entry, $default_sub, $default_key);
 151
 152       push(@options, [$value, $title, !!$selected{$value}]);
 153     }
 154
 155     return join '', map { $self->html_tag('option', $self->escape($_->[1]), value => $_->[0], selected => $_->[2]) } @options;
 156   };
 157
 158   my $code  = '';
 159   $code    .= $self->html_tag('option', $self->escape($empty_title || ''), value => '') if $with_empty;
 160
 161   if (!$with_optgroups) {
 162     $code .= $list_to_code->($collection);
 163
 164   } else {
 165     $code .= join '', map {
 166       my ($optgroup_title, $sub_collection) = @{ $_ };
 167       $self->html_tag('optgroup', $list_to_code->($sub_collection), label => $optgroup_title)
 168     } @{ $collection };
 169   }
 170
 171   return $self->html_tag('select', $code, %attributes, name => $name);
 172 }
 173
 174 sub _set_id_attribute {
 175   my ($attributes, $name) = @_;
 176
 177   $attributes->{id} = name_to_id(undef, $name) if !delete($attributes->{no_id}) && !$attributes->{id};
 178
 179   return %{ $attributes };
 180 }
 181
 182 1;
 183 __END__
 184
 185 =pod
 186
 187 =encoding utf8
 188
 189 =head1 NAME
 190
 191 SL::Presenter::Tag - Layouting / tag generation
 192
 193 =head1 SYNOPSIS
 194
 195 Usage from a template:
 196
 197   [% USE P %]
 198
 199   [% P.select_tag('direction', [ [ 'left', 'To the left' ], [ 'right', 'To the right', 1 ] ]) %]
 200
 201   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 202                                  { direction => 'right', display => 'To the right' } ],
 203                                value_key => 'direction', title_key => 'display', default => 'right')) %]
 204
 205   [% P.select_tag('direction', [ { direction => 'left',  display => 'To the left'  },
 206                                  { direction => 'right', display => 'To the right', selected => 1 } ],
 207                                value_key => 'direction', title_key => 'display')) %]
 208
 209   # With Rose::DB::Object instances. For example a group membership
 210   # (SL::DB::AuthGroup) for a user (SL::DB::AuthUser) via the user's
 211   # "groups" relationship:
 212   [% P.select_tag('direction', SELF.all_groups, default=SELF.user.groups,
 213                                title_key='name', default_key='id', multiple=1) %]
 214
 215 =head1 DESCRIPTION
 216
 217 A module modeled a bit after Rails' ActionView helpers. Several small
 218 functions that create HTML tags from various kinds of data sources.
 219
 220 The C<id> attribute is usually calculated automatically. This can be
 221 overridden by either specifying an C<id> attribute or by setting
 222 C<no_id> to trueish.
 223
 224 =head1 FUNCTIONS
 225
 226 =head2 LOW-LEVEL FUNCTIONS
 227
 228 =over 4
 229
 230 =item C<html_tag $tag_name, $content_string, %attributes>
 231
 232 Creates an opening and closing HTML tag for C<$tag_name> and puts
 233 C<$content_string> between the two. If C<$content_string> is undefined
 234 or empty then only a E<lt>tag/E<gt> tag will be created. Attributes
 235 are key/value pairs added to the opening tag.
 236
 237 C<$content_string> is not HTML escaped.
 238
 239 =item C<name_to_id $name>
 240
 241 Converts a name to a HTML id by replacing various characters.
 242
 243 =item C<stringify_attributes %items>
 244
 245 Creates a string from all elements in C<%items> suitable for usage as
 246 HTML tag attributes. Keys and values are HTML escaped even though keys
 247 must not contain non-ASCII characters for browsers to accept them.
 248
 249 =back
 250
 251 =head2 HIGH-LEVEL FUNCTIONS
 252
 253 =over 4
 254
 255 =item C<input_tag $name, $value, %attributes>
 256
 257 Creates a HTML 'input type=text' tag named C<$name> with the value
 258 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 259 tag's C<id> defaults to C<name_to_id($name)>.
 260
 261 =item C<man_days_tag $name, $object, %attributes>
 262
 263 Creates two HTML inputs: a text input for entering a number and a drop
 264 down box for chosing the unit (either 'man days' or 'hours').
 265
 266 C<$object> must be a L<Rose::DB::Object> instance using the
 267 L<SL::DB::Helper::AttrDuration> helper.
 268
 269 C<$name> is supposed to be the name of the underlying column,
 270 e.g. C<time_estimation> for an instance of
 271 C<SL::DB::RequirementSpecItem>. If C<$name> has the form
 272 C<prefix.method> then the full C<$name> is used for the input's base
 273 names while the methods called on C<$object> are only the suffix. This
 274 makes it possible to write statements like e.g.
 275
 276   [% P.man_days_tag("requirement_spec_item.time_estimation", SELF.item) %]
 277
 278 The attribute C<size> can be used to set the text input's size. It
 279 defaults to 5.
 280
 281 =item C<select_tag $name, \@collection, %attributes>
 282
 283 Creates a HTML 'select' tag named C<$name> with the contents of one
 284 'E<lt>optionE<gt>' tag for each element in C<\@collection> and with arbitrary
 285 HTML attributes from C<%attributes>. The value
 286 to use and the title to display are extracted from the elements in
 287 C<\@collection>. Each element can be one of four things:
 288
 289 =over 12
 290
 291 =item 1. An array reference with at least two elements. The first element is
 292 the value, the second element is its title. The third element is optional and and should contain a boolean.
 293 If it is true, than the element will be used as default.
 294
 295 =item 2. A scalar. The scalar is both the value and the title.
 296
 297 =item 3. A hash reference. In this case C<%attributes> must contain
 298 I<value_key>, I<title_key> and may contain I<default_key> keys that name the keys in the element to use
 299 for the value, title and default respectively.
 300
 301 =item 4. A blessed reference. In this case C<%attributes> must contain
 302 I<value_key>, I<title_key> and may contain I<default_key> keys that name functions called on the blessed
 303 reference whose return values are used as the value, title and default
 304 respectively.
 305
 306 =back
 307
 308 For cases 3 and 4 C<$attributes{value_key}> defaults to C<id>,
 309 C<$attributes{title_key}> defaults to C<$attributes{value_key}>
 310 and C<$attributes{default_key}> defaults to C<selected>.
 311
 312 In addition to pure keys/method you can also provide coderefs as I<value_sub>
 313 and/or I<title_sub> and/or I<default_sub>. If present, these take precedence over keys or methods,
 314 and are called with the element as first argument. It must return the value, title or default.
 315
 316 Lastly a joint coderef I<value_title_sub> may be provided, which in turn takes
 317 precedence over the C<value_sub> and C<title_sub> subs. It will only be called once for each
 318 element and must return a list of value and title.
 319
 320 If the option C<with_empty> is set then an empty element (value
 321 C<undef>) will be used as the first element. The title to display for
 322 this element can be set with the option C<empty_title> and defaults to
 323 an empty string.
 324
 325 The option C<default> can be either a scalar or an array reference
 326 containing the values of the options which should be set to be
 327 selected. How the value from the elements is derived depends on three
 328 things: the parameters C<default_sub> (unset by default) and
 329 C<default_key> (default: "selected") as well as the element's type.
 330
 331 =over 4
 332
 333 =item * If C<default_sub> is a code reference then that reference is
 334 called with the element as its only parameter. The return value is the
 335 value compared to the value from the elements in C<\@collection>.
 336
 337 =item * If the element in question is a scalar then its value is used.
 338
 339 =item * If the element is a hash then C<default_key> names the index
 340 into the hash used as the value to select by default.
 341
 342 =item * If the element is a blessed object then C<default_key> names
 343 the method to call on the object. That method's return value is used
 344 as the value to select by default.
 345
 346 =back
 347
 348 See the synopsis for an example using C<default> with Rose::DB::Object
 349 instances.
 350
 351 The tag's C<id> defaults to C<name_to_id($name)>.
 352
 353 If the option C<with_optgroups> is set then this function expects
 354 C<\@collection> to be one level deeper. The upper-most level is
 355 translated into a HTML C<optgroup> tag. So the structure becomes:
 356
 357 =over 4
 358
 359 =item 1. Array of array references. Each element in the
 360 C<\@collection> is converted into an optgroup.
 361
 362 =item 2. The optgroup's C<label> attribute will be set to the the
 363 first element in the array element. The second array element is then
 364 converted to a list of C<option> tags like it is described above.
 365
 366 =back
 367
 368 Example for use of optgroups:
 369
 370   # First in a controller:
 371   my @collection = (
 372     [ t8("First optgroup with two items"),
 373       [ { id => 42, name => "item one" },
 374         { id => 54, name => "second item" },
 375         { id => 23, name => "and the third one" },
 376       ] ],
 377     [ t8("Another optgroup, with a lot of items from Rose"),
 378       SL::DB::Manager::Customer->get_all_sorted ],
 379   );
 380
 381   # Later in the template:
 382   [% L.select_tag('the_selection', COLLECTION, with_optgroups=1, title_key='name') %]
 383
 384 =back
 385
 386 =head1 BUGS
 387
 388 Nothing here yet.
 389
 390 =head1 AUTHOR
 391
 392 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 393 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 394
 395 =cut