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