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   my $default_val_key = delete($attributes{default_value_key});
  96   my $default_coll    = delete($attributes{default});
  97
  98   my $value_title_sub = delete($attributes{value_title_sub});
  99
 100   my $value_sub       = delete($attributes{value_sub});
 101   my $title_sub       = delete($attributes{title_sub});
 102   my $default_sub     = delete($attributes{default_sub});
 103
 104   my $with_empty      = delete($attributes{with_empty});
 105   my $empty_title     = delete($attributes{empty_title});
 106
 107   my $with_optgroups  = delete($attributes{with_optgroups});
 108
 109   undef $default_key if $default_sub || $default_val_key;
 110
 111   my $normalize_entry = sub {
 112     my ($type, $entry, $sub, $key) = @_;
 113
 114     return $sub->($entry) if $sub;
 115
 116     my $ref = ref($entry);
 117
 118     if ( !$ref ) {
 119       return $entry if $type eq 'value' || $type eq 'title';
 120       return 0;
 121     }
 122
 123     if ( $ref eq 'ARRAY' ) {
 124       return $entry->[ $type eq 'value' ? 0 : $type eq 'title' ? 1 : 2 ];
 125     }
 126
 127     return $entry->{$key} if $ref  eq 'HASH';
 128     return $entry->$key   if $type ne 'default' || $entry->can($key);
 129     return undef;
 130   };
 131
 132   my %selected;
 133   if (defined($default_coll) && !ref $default_coll) {
 134     %selected = ($default_coll => 1);
 135
 136   } elsif (ref($default_coll) eq 'HASH') {
 137     %selected = %{ $default_coll };
 138
 139   } elsif ($default_coll) {
 140     $default_coll = [ $default_coll ] unless 'ARRAY' eq ref $default_coll;
 141
 142     %selected = $default_val_key ? map({ ($normalize_entry->('value', $_, undef, $default_val_key) => 1) } @{ $default_coll })
 143               :                    map({ ($_                                                       => 1) } @{ $default_coll });
 144   }
 145
 146   my $list_to_code = sub {
 147     my ($sub_collection) = @_;
 148
 149     my @options;
 150     foreach my $entry ( @{ $sub_collection } ) {
 151       my $value;
 152       my $title;
 153
 154       if ( $value_title_sub ) {
 155         ($value, $title) = @{ $value_title_sub->($entry) };
 156       } else {
 157
 158         $value = $normalize_entry->('value', $entry, $value_sub, $value_key);
 159         $title = $normalize_entry->('title', $entry, $title_sub, $title_key);
 160       }
 161
 162       my $default = $default_key ? $normalize_entry->('default', $entry, $default_sub, $default_key) : 0;
 163
 164       push(@options, [$value, $title, $selected{$value} || $default]);
 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   # Use an RDBO object and it's n:m relatioship as the default
 222   # values. For example, a user can be a member in many groups. "All
 223   # groups" is therefore the full collection and "$user->groups" is a
 224   # list of RDBO AuthGroup objects whose IDs must match the ones in
 225   # "All groups". This could look like the following:
 226   [% P.select_tag('user.groups[]', SELF.all_groups, multiple=1,
 227                   default=SELF.user.groups, default_value_key='id' ) %]
 228
 229 =head1 DESCRIPTION
 230
 231 A module modeled a bit after Rails' ActionView helpers. Several small
 232 functions that create HTML tags from various kinds of data sources.
 233
 234 The C<id> attribute is usually calculated automatically. This can be
 235 overridden by either specifying an C<id> attribute or by setting
 236 C<no_id> to trueish.
 237
 238 =head1 FUNCTIONS
 239
 240 =head2 LOW-LEVEL FUNCTIONS
 241
 242 =over 4
 243
 244 =item C<html_tag $tag_name, $content_string, %attributes>
 245
 246 Creates an opening and closing HTML tag for C<$tag_name> and puts
 247 C<$content_string> between the two. If C<$content_string> is undefined
 248 or empty then only a E<lt>tag/E<gt> tag will be created. Attributes
 249 are key/value pairs added to the opening tag.
 250
 251 C<$content_string> is not HTML escaped.
 252
 253 =item C<name_to_id $name>
 254
 255 Converts a name to a HTML id by replacing various characters.
 256
 257 =item C<stringify_attributes %items>
 258
 259 Creates a string from all elements in C<%items> suitable for usage as
 260 HTML tag attributes. Keys and values are HTML escaped even though keys
 261 must not contain non-ASCII characters for browsers to accept them.
 262
 263 =back
 264
 265 =head2 HIGH-LEVEL FUNCTIONS
 266
 267 =over 4
 268
 269 =item C<input_tag $name, $value, %attributes>
 270
 271 Creates a HTML 'input type=text' tag named C<$name> with the value
 272 C<$value> and with arbitrary HTML attributes from C<%attributes>. The
 273 tag's C<id> defaults to C<name_to_id($name)>.
 274
 275 =item C<man_days_tag $name, $object, %attributes>
 276
 277 Creates two HTML inputs: a text input for entering a number and a drop
 278 down box for chosing the unit (either 'man days' or 'hours').
 279
 280 C<$object> must be a L<Rose::DB::Object> instance using the
 281 L<SL::DB::Helper::AttrDuration> helper.
 282
 283 C<$name> is supposed to be the name of the underlying column,
 284 e.g. C<time_estimation> for an instance of
 285 C<SL::DB::RequirementSpecItem>. If C<$name> has the form
 286 C<prefix.method> then the full C<$name> is used for the input's base
 287 names while the methods called on C<$object> are only the suffix. This
 288 makes it possible to write statements like e.g.
 289
 290   [% P.man_days_tag("requirement_spec_item.time_estimation", SELF.item) %]
 291
 292 The attribute C<size> can be used to set the text input's size. It
 293 defaults to 5.
 294
 295 =item C<select_tag $name, \@collection, %attributes>
 296
 297 Creates a HTML 'select' tag named C<$name> with the contents of one
 298 'E<lt>optionE<gt>' tag for each element in C<\@collection> and with arbitrary
 299 HTML attributes from C<%attributes>. The value
 300 to use and the title to display are extracted from the elements in
 301 C<\@collection>. Each element can be one of four things:
 302
 303 =over 12
 304
 305 =item 1. An array reference with at least two elements. The first element is
 306 the value, the second element is its title. The third element is optional and and should contain a boolean.
 307 If it is true, than the element will be used as default.
 308
 309 =item 2. A scalar. The scalar is both the value and the title.
 310
 311 =item 3. A hash reference. In this case C<%attributes> must contain
 312 I<value_key>, I<title_key> and may contain I<default_key> keys that name the keys in the element to use
 313 for the value, title and default respectively.
 314
 315 =item 4. A blessed reference. In this case C<%attributes> must contain
 316 I<value_key>, I<title_key> and may contain I<default_key> keys that name functions called on the blessed
 317 reference whose return values are used as the value, title and default
 318 respectively.
 319
 320 =back
 321
 322 For cases 3 and 4 C<$attributes{value_key}> defaults to C<id>,
 323 C<$attributes{title_key}> defaults to C<$attributes{value_key}> and
 324 C<$attributes{default_key}> defaults to C<selected>. Note that
 325 C<$attributes{default_key}> is set to C<undef> if
 326 C<$attributes{default_value_key}> is used as well (see below).
 327
 328 In addition to pure keys/method you can also provide coderefs as I<value_sub>
 329 and/or I<title_sub> and/or I<default_sub>. If present, these take precedence over keys or methods,
 330 and are called with the element as first argument. It must return the value, title or default.
 331
 332 Lastly a joint coderef I<value_title_sub> may be provided, which in turn takes
 333 precedence over the C<value_sub> and C<title_sub> subs. It will only be called once for each
 334 element and must return a list of value and title.
 335
 336 If the option C<with_empty> is set then an empty element (value
 337 C<undef>) will be used as the first element. The title to display for
 338 this element can be set with the option C<empty_title> and defaults to
 339 an empty string.
 340
 341 The tag's C<id> defaults to C<name_to_id($name)>.
 342
 343 The option C<default> can be quite a lot of things:
 344
 345 =over 4
 346
 347 =item 1. A scalar value. This is the value of the entry that's
 348 selected by default.
 349
 350 =item 2. A hash reference for C<multiple=1>. Whether or not an entry
 351 is selected by default is looked up in this hash.
 352
 353 =item 3. An array reference containing scalar values. Same as 1., just
 354 for the case of C<multiple=1>.
 355
 356 =item 4. If C<default_value_key> is given: an array reference of hash
 357 references. For each hash reference the value belonging to the key
 358 C<default_value_key> is treated as one value to select by
 359 default. Constructs a hash that's treated like 3.
 360
 361 =item 5. If C<default_value_key> is given: an array reference of
 362 blessed objects. For each object the value returne from calling the
 363 function named C<default_value_key> on the object is treated as one
 364 value to select by default. Constructs a hash that's treated like 3.
 365
 366 =back
 367
 368 5. also applies for single RDBO instances (due to 'wantarray'
 369 shenanigangs assigning RDBO's relationships to a hash key will result
 370 in a single RDBO object being assigned instead of an array reference
 371 containing that single RDBO object).
 372
 373 If the option C<with_optgroups> is set then this function expects
 374 C<\@collection> to be one level deeper. The upper-most level is
 375 translated into a HTML C<optgroup> tag. So the structure becomes:
 376
 377 =over 4
 378
 379 =item 1. Array of array references. Each element in the
 380 C<\@collection> is converted into an optgroup.
 381
 382 =item 2. The optgroup's C<label> attribute will be set to the the
 383 first element in the array element. The second array element is then
 384 converted to a list of C<option> tags like it is described above.
 385
 386 =back
 387
 388 Example for use of optgroups:
 389
 390   # First in a controller:
 391   my @collection = (
 392     [ t8("First optgroup with two items"),
 393       [ { id => 42, name => "item one" },
 394         { id => 54, name => "second item" },
 395         { id => 23, name => "and the third one" },
 396       ] ],
 397     [ t8("Another optgroup, with a lot of items from Rose"),
 398       SL::DB::Manager::Customer->get_all_sorted ],
 399   );
 400
 401   # Later in the template:
 402   [% L.select_tag('the_selection', COLLECTION, with_optgroups=1, title_key='name') %]
 403
 404 =back
 405
 406 =head1 BUGS
 407
 408 Nothing here yet.
 409
 410 =head1 AUTHOR
 411
 412 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 413 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 414
 415 =cut