/[Frey]/trunk/lib/Frey/Action.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/lib/Frey/Action.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1175 - (show annotations)
Mon Jul 6 20:27:57 2009 UTC (13 years, 7 months ago) by dpavlin
File size: 11257 byte(s)
adaptive length of input type=text on form using new form_value_len
which is implemented by App class
1 package Frey::Action;
2 use Moose;
3 extends 'Frey::PPI';
4 with 'Frey::Web', 'Frey::Config';
5
6 use Clone qw/clone/;
7 use Data::Dump qw/dump/;
8
9 =head1 DESCRIPTION
10
11 Invoke any L<Frey> object creating html for with various default parameters
12 if not supplied at invocation.
13
14 You can force rendering of fields if you define C<render_attribute> sub with
15 desired rendering as in:
16
17 sub render_pipe { 'radio' }
18
19 =cut
20
21 has 'class' => (
22 is => 'rw',
23 isa => 'Str',
24 required => 1,
25 );
26
27 has 'params' => (
28 is => 'rw',
29 isa => 'HashRef',
30 default => sub { {} },
31 );
32
33 has 'input_step_size' => (
34 documentation => 'Resize input fields by this step',
35 is => 'rw',
36 isa => 'Int',
37 # required => 1,
38 default => 20,
39 );
40
41 =head2 required
42
43 my @required_attributes = $self->required;
44 my $required_attributes = $self->required;
45 my $required_hash = $self->required('as_hash');
46
47 =cut
48
49 sub required {
50 my ($self,$param) = @_;
51 $self->load_class( $self->class );
52
53 my @required =
54 grep {
55 defined $_ && $_->can('name') &&
56 ! $_->is_lazy
57 }
58 map {
59 my $attr = $self->class->meta->get_attribute($_);
60 blessed $attr && $attr->is_required && $attr;
61 } $self->class->meta->get_attribute_list;
62
63 @required = map { $_->name } @required;
64 warn "## required = ",dump( @required ), " for ", $self->class if @required && $self->debug;
65
66 if ( $param eq 'as_hash' ) {
67 my $hash;
68 map {
69 $hash->{$_} = 1;
70 $hash->{$_} = 0 if defined $self->params->{$_};
71 } @required;
72 return $hash;
73 }
74 return @required if wantarray;
75 return \@required;
76 }
77
78 =head2 attributes
79
80 Generated from attributes specified in code (extracted using L<Frey::PPI>)
81 and required atributes
82
83 my @class_attributes = $self->attributes;
84 my @class_attributes = $self->attributes;
85
86 =cut
87
88 sub attributes {
89 my ( $self ) = @_;
90 my $a;
91 my @attrs = @{ $self->attribute_order };
92 @attrs = map { $a->{$_}++; $_ } @attrs;
93 push @attrs, $_ foreach grep { ! $a->{$_} } @{ $self->required };
94 warn "# attributes = ",dump( @attrs ) if $self->debug;
95 return @attrs if wantarray;
96 return \@attrs;
97 }
98
99 =head2 params_form
100
101 my $html = $self->params_form;
102 my ($html,$default_params) = $self->params_form;
103
104 =cut
105
106 sub form_id {
107 my ($self) = @_;
108 my $form_id = $self->class;
109 $form_id =~ s{\W+}{_}g;
110 return $form_id;
111 }
112
113 sub select_values {
114 my ( $self, $name, $attr_type, $values ) = @_;
115
116 $attr_type ||= '?' and warn "$name doesn't have attr_type";
117
118 my $form_id = $self->form_id;
119 my $max_value_len = 0;
120 my $form_value_len = $self->class->form_value_len if $self->class->can('form_value_len');
121 my @values;
122 my $display;
123 my $html = '';
124
125 foreach ( @$values ) {
126 my $v = ref($_) eq 'HASH' ? $_->{$name} : $_;
127 if ( $v =~ s/\t+(.+)$// ) {
128 $display->{$v} = $1;
129 }
130 warn "## value '$v'";
131 push @values, $v;
132 $max_value_len = length($v) if length($v) > $max_value_len;
133 }
134
135 if ( my $l = $form_value_len->{$name} ) {
136 $max_value_len = $l if $l > $max_value_len;
137 }
138
139 warn "# max_value_len: $max_value_len";
140 #my $render = eval $class . '->render_' . $name;
141 my $call = 'render_' . $name;
142 my $render = $self->class->$call if $self->class->can($call);
143 warn "## render $@";
144
145 if ( $#values > 3 && $render !~ m{radio} ) {
146 my $options = join("\n",
147 map {
148 my $d = $display->{$_} || $_;
149 qq|<option value="$_">$d</option>|;
150 } @values
151 );
152 # onchange="alert(this.options[this.selectedIndex].value);"
153 $html = qq|
154 <select title="$attr_type" name="$name">
155 $options
156 </select>
157 | if $options;
158 } else {
159 my $delimiter = $max_value_len > $self->input_step_size ? qq|<br>| : '';
160 my $radio =
161 # $delimiter .
162 join("\n",
163 map { strip(qq|
164 <span title="$attr_type">
165 <input type="radio" name="$name" value="$_">
166 $_
167 </span>
168 $delimiter
169 |) } @values
170 );
171 if ( $radio ) {
172
173 my $size = int( $max_value_len / $self->input_step_size ) + 1;
174 $size = 5 if $size > 5;
175 $size *= $self->input_step_size;
176 $radio .= qq|
177 <span>
178 <input type="radio" name="$name" value=" " onclick="document.getElementById('new-$name').focus();" >
179 <input type="text" name="new-$name" id="new-$name" onchange="clear_radio('$form_id','$name'); this.disable = false;" onblur="this.disable = true;" title="enter new value" size="$size">
180 </span>
181 |;
182 }
183 $html = qq|<div style="display: block;">$radio</div>|;
184 }
185
186 return $html;
187 }
188
189 sub params_form {
190 my ( $self ) = @_;
191
192 foreach my $checkbox ( split(/\s+/, $self->params->{'frey-checkboxes'} ) ) {
193 next if defined $self->params->{ $checkbox };
194
195 $self->params->{ $checkbox } = 0;
196 warn "# checkbox $checkbox not ticked";
197 }
198
199 my $required = $self->required('as_hash');
200 if ( grep { $required->{$_} } keys %$required ) {
201 warn $self->class, " required params ", dump( keys %$required ) if $self->debug;
202 } else {
203 warn "all params available ", dump( $self->params ), " not creating form" if $self->debug;
204 return (undef,$self->params) if wantarray;
205 return;
206 }
207
208 my $class = $self->class;
209
210 $self->load_class( $class );
211
212 my $default = clone $self->params; # XXX we really don't want to modify params!
213
214 my $params_config = {};
215 $params_config = $self->config($class);
216 warn "# $class config = ",dump( $params_config ) if $self->debug;
217
218 my $form;
219 my $form_id = $self->form_id;
220
221 my @checkboxes;
222
223 my $label_width = 1; # minimum
224
225 my @fields =
226 grep {
227 die "$_ doesn't have meta" unless $class->can('meta');
228 ! $class->meta->get_attribute($_)->is_lazy
229 # && ! defined $default->{$_} # XXX show fields with values
230 && ! m{^_} # skip _private
231 } $self->attributes;
232
233 my $fieldset;
234
235 my $last;
236 foreach my $name ( @fields ) {
237 my $set = $name;
238 $set =~ s{_[^_]+$}{};
239 push @{ $fieldset->{$set} }, $name;
240 }
241
242 delete( $fieldset->{$_} )
243 foreach ( grep { $#{ $fieldset->{$_} } == 0 } keys %$fieldset );
244
245 warn "# fieldset = ",dump( $fieldset );
246
247 foreach my $name ( @fields ) {
248 my $attr_type = '';
249 my $type = $name =~ m/^pass/ ? 'password' : 'text';
250 my $label = $name;
251 my $label_title = '';
252 my $value_html = '';
253
254 my $attr = $class->meta->get_attribute( $name );
255 $attr_type = $attr->type_constraint->name if $attr->has_type_constraint;
256
257 my $value =
258 defined $default->{$name} ? $default->{$name} :
259 $attr->has_default ? $attr->default( $name ) :
260 undef;
261
262 if ( defined $params_config && ref($params_config) eq 'HASH' && defined $params_config->{$name} ) {
263 $value = $params_config->{$name};
264 } elsif ( ref($params_config) eq 'ARRAY' ) {
265 $value_html = $self->select_values( $name, $attr_type, $params_config );
266 $default->{$name} = $params_config->[0]->{$name};
267 } elsif ( $attr->has_type_constraint && $attr->type_constraint->can('values') ) {
268 $value_html = $self->select_values( $name, $attr_type, $attr->type_constraint->values );
269 } elsif ( $class->can( $name . '_available' ) ) {
270 my $available = $name . '_available';
271 $available = $class->$available;
272 confess $@ if $@;
273 $available =~ s/^\s+//gs;
274 $available =~ s/\s+$//gs;
275 $value_html = $self->select_values( $name, $attr_type, [ split(/\n/,$available) ]);
276 } elsif ( $attr_type =~ m{^Bool} ) {
277 my $suffix = '';
278 $suffix = ' checked=1' if $value;
279 $value_html = qq|<input type="checkbox" name="$name" title="$attr_type" value=1$suffix>|;
280 push @checkboxes, $name;
281 } elsif ( ! defined $value && ! $required->{$name} ) {
282 $value_html = qq|<tt id="$name">undef</tt><!-- $name = undef -->|; # FIXME if $self->debug
283 } elsif ( $attr_type !~ m{^(Str|Int|Email)$} || $value =~ $Frey::Web::re_html || $name =~ m{text} ) {
284 $value_html = qq|<textarea name="$name" title="$attr_type">$value</textarea>|;
285 }
286
287 $label_title = qq| title="| . $attr->documentation . qq|"| if $attr->has_documentation;
288
289 my $value_size = '';
290
291 $default->{$name} = $value unless defined $default->{$name};
292
293 if ( ! $value_html ) { # fallback to default input type=text
294
295 my $form_value_len = $self->class->form_value_len->{$name} if $self->class->can('form_value_len');
296 $form_value_len = length($value) if length($value) > $form_value_len;
297
298 my $size = ( int( $form_value_len / ( $self->input_step_size * 1.5 ) ) + 1 ) * $self->input_step_size if $form_value_len;
299 $value = qq|value="$value"| if defined $value;
300 $size = qq|size="$size"| if $size;
301 $value_html = qq|<input type="$type" name="$name" title="$attr_type" $value $size>| unless $value_html;
302
303 }
304
305 # warn "# required $name ", $class->meta->get_attribute( $name )->dump( 2 );
306
307 if ( defined $required->{$name} ) {
308 $label_title .= qq| class="required"|;
309 my $class = 'required';
310 $class = 'required-filled' if ! $required->{$name};
311 $value_html =~ s{(<\S+)\s}{$1 class=$class };
312 }
313
314 my $set = $name;
315 $set =~ s{_[^_]+$}{};
316
317 my ( $before, $after ) = ( '', '<br>' );
318
319 if ( my $s = $fieldset->{$set} ) {
320 if ($s->[0] eq $name) {
321 $before = qq|
322 <fieldset>
323 <legend>$set</legend>
324 |;
325 } elsif ( $s->[ -1 ] eq $name ) {
326 $after = qq|
327 </fieldset>
328 |;
329 }
330 $label =~ s{^\Q$set\E_+}{};
331 }
332
333 $label = $self->_label( $label );
334 $form .= qq|$before<label for="$name"$label_title>$label</label>$value_html $after|;
335 my $ll = length($label);
336 $label_width = $ll if $ll > $label_width;
337 }
338 $form .= qq|<input type="hidden" name="frey-checkboxes" value="| . join(' ', @checkboxes) . qq|">| if @checkboxes;
339
340 $label_width += 2; # XXX padding left+right em
341
342 $self->add_js('static/Frey/Action.js');
343
344 $self->add_css(qq|
345 label,input {
346 display: block;
347 float: left;
348 margin-bottom: 10px;
349 }
350
351 input:focus {
352 border-color: #cc0;
353 background: #ffc;
354 }
355
356 label {
357 text-align: right;
358 width: ${label_width}ex;
359 padding-right: 1ex;
360 white-space: nowrap;
361 }
362
363 label.required {
364 font-weight: bold;
365 }
366
367 input,
368 select {
369 margin-right: -${label_width}ex;
370 }
371 input.required,
372 select.required {
373 border-color: #c00;
374 }
375 input.required-filled,
376 select.required-filled {
377 border-color: #0c0;
378 }
379
380 br {
381 clear: left;
382 }
383
384 fieldset {
385 margin: 0;
386 padding: 0;
387 margin-bottom: 0.5em;
388 }
389 |);
390
391 my $html;
392
393 # http://www.quirksmode.org/oddsandends/forms.html
394 # $form =~ s{<([^>]+)(name=")([^"]+)(")([^>]*)>}{<$1$2$3$4 id="$3" $5}gs;
395
396 if ( $form ) {
397
398 if ( $self->class->can('form_header') ) {
399 $html = $self->class->form_header;
400 } else {
401 $html = qq|
402 <h1>$class params</h1>
403 |;
404 }
405
406 my $submit = $self->_label( 'submit' );
407 $submit =~ s{^submit$}{Run $class};
408
409 $html .= qq|
410 <form name="$form_id" id="$form_id" method="post">
411 $form
412 <input type="submit" value="$submit">
413 </form>
414 |;
415 $html .= $self->class->form_footer if $self->class->can('form_footer');
416 }
417
418 $self->add_status({
419 $self->class => {
420 params => $self->params,
421 params_config => $params_config,
422 default => $default,
423 },
424 });
425
426 $self->title( $self->class->title ) if $self->class->title;
427
428 return ($html,$default) if wantarray;
429 return $html;
430 }
431
432 sub _label {
433 my ($self,$name) = @_;
434 my $labels = $self->class->form_labels if $self->class->can('form_labels');
435 my $label = $labels->{$name};
436 if ( ! defined $label ) {
437 $label = $name;
438 $label =~ s{_}{ }g;
439 }
440 return $label;
441 }
442
443 =head1 SEE ALSO
444
445 L<http://www.quirksmode.org/css/forms.html> for info on CSS2 forms
446
447 =cut
448
449 __PACKAGE__->meta->make_immutable;
450 no Moose;
451
452 1;

  ViewVC Help
Powered by ViewVC 1.1.26