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