SL/Presenter/Tag.pm

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