SL/Presenter/Tag.pm

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