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