/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1171 - (hide annotations)
Sun Jul 5 21:25:25 2009 UTC (14 years, 9 months ago) by dpavlin
File size: 10611 byte(s)
add around title to setup application title
1 dpavlin 369 package Frey::Action;
2     use Moose;
3     extends 'Frey::PPI';
4 dpavlin 1133 with 'Frey::Web', 'Frey::Config';
5 dpavlin 369
6 dpavlin 386 use Clone qw/clone/;
7 dpavlin 369 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 dpavlin 940 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 dpavlin 369 =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 dpavlin 782 has 'input_step_size' => (
34 dpavlin 780 documentation => 'Resize input fields by this step',
35     is => 'rw',
36     isa => 'Int',
37     # required => 1,
38     default => 20,
39     );
40    
41 dpavlin 369 =head2 required
42    
43     my @required_attributes = $self->required;
44     my $required_attributes = $self->required;
45 dpavlin 975 my $required_hash = $self->required('as_hash');
46 dpavlin 369
47     =cut
48    
49     sub required {
50 dpavlin 975 my ($self,$param) = @_;
51 dpavlin 369 $self->load_class( $self->class );
52 dpavlin 731
53 dpavlin 369 my @required =
54 dpavlin 435 grep {
55 dpavlin 469 defined $_ && $_->can('name') &&
56     ! $_->is_lazy
57 dpavlin 435 }
58 dpavlin 430 map {
59 dpavlin 435 my $attr = $self->class->meta->get_attribute($_);
60 dpavlin 440 blessed $attr && $attr->is_required && $attr;
61 dpavlin 369 } $self->class->meta->get_attribute_list;
62    
63 dpavlin 975 @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 dpavlin 1162 map {
69     $hash->{$_} = 1;
70     $hash->{$_} = 0 if defined $self->params->{$_};
71     } @required;
72 dpavlin 975 return $hash;
73     }
74 dpavlin 369 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 dpavlin 975 push @attrs, $_ foreach grep { ! $a->{$_} } @{ $self->required };
94 dpavlin 386 warn "# attributes = ",dump( @attrs ) if $self->debug;
95 dpavlin 369 return @attrs if wantarray;
96     return \@attrs;
97     }
98    
99     =head2 params_form
100    
101 dpavlin 386 my $html = $self->params_form;
102     my ($html,$default_params) = $self->params_form;
103 dpavlin 369
104     =cut
105    
106 dpavlin 1113 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 @values;
121     my $display;
122     my $html = '';
123    
124     foreach ( @$values ) {
125     my $v = ref($_) eq 'HASH' ? $_->{$name} : $_;
126     if ( $v =~ s/\t+(.+)$// ) {
127     $display->{$v} = $1;
128     }
129     warn "## value '$v'";
130     push @values, $v;
131     $max_value_len = length($v) if length($v) > $max_value_len;
132     }
133    
134     warn "# max_value_len: $max_value_len";
135     #my $render = eval $class . '->render_' . $name;
136     my $call = 'render_' . $name;
137 dpavlin 1142 my $render = $self->class->$call if $self->class->can($call);
138 dpavlin 1113 warn "## render $@";
139    
140     if ( $#values > 3 && $render !~ m{radio} ) {
141     my $options = join("\n",
142     map {
143     my $d = $display->{$_} || $_;
144     qq|<option value="$_">$d</option>|;
145     } @values
146     );
147     # onchange="alert(this.options[this.selectedIndex].value);"
148     $html = qq|
149     <select title="$attr_type" name="$name">
150     $options
151     </select>
152     | if $options;
153     } else {
154     my $delimiter = $max_value_len > $self->input_step_size ? qq|<br>| : '';
155     my $radio =
156     # $delimiter .
157     join("\n",
158     map { strip(qq|
159     <span title="$attr_type">
160     <input type="radio" name="$name" value="$_">
161     $_
162     </span>
163     $delimiter
164     |) } @values
165     );
166     if ( $radio ) {
167    
168     my $size = int( $max_value_len / $self->input_step_size ) + 1;
169     $size = 5 if $size > 5;
170     $size *= $self->input_step_size;
171     $radio .= qq|
172     <span>
173     <input type="radio" name="$name" value=" " onclick="document.getElementById('new-$name').focus();" >
174     <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">
175     </span>
176     |;
177     }
178     $html = qq|<div style="display: block;">$radio</div>|;
179     }
180    
181 dpavlin 1161 return $html;
182 dpavlin 1113 }
183    
184 dpavlin 369 sub params_form {
185     my ( $self ) = @_;
186 dpavlin 978
187     foreach my $checkbox ( split(/\s+/, $self->params->{'frey-checkboxes'} ) ) {
188     next if defined $self->params->{ $checkbox };
189    
190     $self->params->{ $checkbox } = 0;
191     warn "# checkbox $checkbox not ticked";
192     }
193    
194 dpavlin 975 my $required = $self->required('as_hash');
195 dpavlin 1162 if ( grep { $required->{$_} } keys %$required ) {
196 dpavlin 975 warn $self->class, " required params ", dump( keys %$required ) if $self->debug;
197     } else {
198 dpavlin 414 warn "all params available ", dump( $self->params ), " not creating form" if $self->debug;
199 dpavlin 386 return (undef,$self->params) if wantarray;
200 dpavlin 369 return;
201     }
202    
203     my $class = $self->class;
204    
205     $self->load_class( $class );
206    
207 dpavlin 386 my $default = clone $self->params; # XXX we really don't want to modify params!
208 dpavlin 369
209 dpavlin 731 my $params_config = {};
210     $params_config = $self->config($class);
211     warn "# $class config = ",dump( $params_config ) if $self->debug;
212 dpavlin 369
213 dpavlin 386 my $form;
214 dpavlin 1113 my $form_id = $self->form_id;
215 dpavlin 386
216 dpavlin 645 my @checkboxes;
217    
218 dpavlin 731 my $label_width = 1; # minimum
219    
220 dpavlin 1101 my @fields =
221 dpavlin 645 grep {
222 dpavlin 940 die "$_ doesn't have meta" unless $class->can('meta');
223 dpavlin 645 ! $class->meta->get_attribute($_)->is_lazy
224 dpavlin 1108 # && ! defined $default->{$_} # XXX show fields with values
225 dpavlin 715 && ! m{^_} # skip _private
226 dpavlin 1101 } $self->attributes;
227    
228     my $fieldset;
229    
230     my $last;
231     foreach my $name ( @fields ) {
232     my $set = $name;
233     $set =~ s{_[^_]+$}{};
234     push @{ $fieldset->{$set} }, $name;
235     }
236    
237     delete( $fieldset->{$_} )
238     foreach ( grep { $#{ $fieldset->{$_} } == 0 } keys %$fieldset );
239    
240 dpavlin 1108 warn "# fieldset = ",dump( $fieldset );
241 dpavlin 1101
242     foreach my $name ( @fields ) {
243 dpavlin 414 my $attr_type = '';
244 dpavlin 369 my $type = $name =~ m/^pass/ ? 'password' : 'text';
245 dpavlin 372 my $label = $name;
246     my $label_title = '';
247 dpavlin 369 my $value_html = '';
248 dpavlin 504
249     my $attr = $class->meta->get_attribute( $name );
250     $attr_type = $attr->type_constraint->name if $attr->has_type_constraint;
251    
252 dpavlin 645 my $value =
253     defined $default->{$name} ? $default->{$name} :
254     $attr->has_default ? $attr->default( $name ) :
255 dpavlin 978 undef;
256 dpavlin 510
257 dpavlin 783 if ( ref($params_config) eq 'HASH' && defined $params_config->{$name} ) {
258 dpavlin 731 $value = $params_config->{$name};
259     } elsif ( ref($params_config) eq 'ARRAY' ) {
260 dpavlin 1113 $value_html = $self->select_values( $name, $attr_type, $params_config );
261 dpavlin 731 $default->{$name} = $params_config->[0]->{$name};
262 dpavlin 504 } elsif ( $attr->has_type_constraint && $attr->type_constraint->can('values') ) {
263 dpavlin 1113 $value_html = $self->select_values( $name, $attr_type, $attr->type_constraint->values );
264 dpavlin 1079 } elsif ( $class->can( $name . '_available' ) ) {
265 dpavlin 1142 my $available = $name . '_available';
266     $available = $class->$available;
267 dpavlin 1079 confess $@ if $@;
268     $available =~ s/^\s+//gs;
269     $available =~ s/\s+$//gs;
270 dpavlin 1113 $value_html = $self->select_values( $name, $attr_type, [ split(/\n/,$available) ]);
271 dpavlin 640 } elsif ( $attr_type =~ m{^Bool} ) {
272 dpavlin 731 my $suffix = '';
273 dpavlin 978 $suffix = ' checked=1' if $value;
274     $value_html = qq|<input type="checkbox" name="$name" title="$attr_type" value=1$suffix>|;
275 dpavlin 731 push @checkboxes, $name;
276 dpavlin 1085 } elsif ( ! defined $value && ! $required->{$name} ) {
277 dpavlin 731 $value_html = qq|<tt id="$name">undef</tt><!-- $name = undef -->|; # FIXME if $self->debug
278 dpavlin 1119 } elsif ( $attr_type !~ m{^(Str|Int|Email)$} || $value =~ $Frey::Web::re_html || $name =~ m{text} ) {
279 dpavlin 731 $value_html = qq|<textarea name="$name" title="$attr_type">$value</textarea>|;
280 dpavlin 369 }
281 dpavlin 731
282 dpavlin 504 $label_title = qq| title="| . $attr->documentation . qq|"| if $attr->has_documentation;
283 dpavlin 372
284 dpavlin 469 $default->{$name} = $value unless defined $default->{$name};
285    
286 dpavlin 782 my $size = ( int( length($value) / $self->input_step_size ) + 1 ) * $self->input_step_size;
287 dpavlin 780 $value_html = qq|<input type="$type" name="$name" title="$attr_type" value="$value" size="$size">| unless $value_html;
288 dpavlin 372
289 dpavlin 369 # warn "# required $name ", $class->meta->get_attribute( $name )->dump( 2 );
290 dpavlin 975
291 dpavlin 1162 if ( defined $required->{$name} ) {
292 dpavlin 1108 $label_title .= qq| class="required"|;
293 dpavlin 1162 my $class = 'required';
294     $class = 'required-filled' if ! $required->{$name};
295     $value_html =~ s{(<\S+)\s}{$1 class=$class };
296 dpavlin 1108 }
297 dpavlin 975
298 dpavlin 1101 my $set = $name;
299     $set =~ s{_[^_]+$}{};
300    
301     my ( $before, $after ) = ( '', '<br>' );
302    
303     if ( my $s = $fieldset->{$set} ) {
304     if ($s->[0] eq $name) {
305     $before = qq|
306     <fieldset>
307     <legend>$set</legend>
308     |;
309     } elsif ( $s->[ -1 ] eq $name ) {
310     $after = qq|
311     </fieldset>
312     |;
313     }
314 dpavlin 1160 $label =~ s{^\Q$set\E_+}{};
315 dpavlin 1101 }
316    
317 dpavlin 1160 $label = $self->_label( $label );
318 dpavlin 1101 $form .= qq|$before<label for="$name"$label_title>$label</label>$value_html $after|;
319 dpavlin 731 my $ll = length($label);
320     $label_width = $ll if $ll > $label_width;
321 dpavlin 369 }
322 dpavlin 645 $form .= qq|<input type="hidden" name="frey-checkboxes" value="| . join(' ', @checkboxes) . qq|">| if @checkboxes;
323    
324 dpavlin 975 $label_width += 2; # XXX padding left+right em
325    
326 dpavlin 950 $self->add_js('static/Frey/Action.js');
327    
328 dpavlin 731 $self->add_css(qq|
329     label,input {
330     display: block;
331     float: left;
332     margin-bottom: 10px;
333     }
334    
335 dpavlin 950 input:focus {
336     border-color: #cc0;
337 dpavlin 975 background: #ffc;
338 dpavlin 950 }
339    
340 dpavlin 731 label {
341     text-align: right;
342     width: ${label_width}ex;
343 dpavlin 975 padding-right: 1ex;
344     white-space: nowrap;
345 dpavlin 731 }
346    
347 dpavlin 975 label.required {
348     font-weight: bold;
349     }
350 dpavlin 1108 input.required,
351     select.required {
352     border-color: #c00;
353     }
354 dpavlin 1162 input.required-filled,
355     select.required-filled {
356     border-color: #0c0;
357     }
358 dpavlin 975
359 dpavlin 731 br {
360     clear: left;
361     }
362 dpavlin 1101
363     fieldset {
364     margin: 0;
365     padding: 0;
366 dpavlin 1102 margin-bottom: 0.5em;
367 dpavlin 1101 }
368 dpavlin 731 |);
369    
370 dpavlin 645 my $html;
371    
372 dpavlin 734 # http://www.quirksmode.org/oddsandends/forms.html
373     # $form =~ s{<([^>]+)(name=")([^"]+)(")([^>]*)>}{<$1$2$3$4 id="$3" $5}gs;
374 dpavlin 731
375 dpavlin 1161 if ( $form ) {
376 dpavlin 645
377 dpavlin 1161 if ( $self->class->can('form_header') ) {
378     $html = $self->class->form_header;
379     } else {
380     $html = qq|
381     <h1>$class params</h1>
382     |;
383     }
384    
385 dpavlin 1164 my $submit = $self->_label( 'submit' );
386     $submit =~ s{^submit$}{Run $class};
387    
388 dpavlin 1161 $html .= qq|
389     <form name="$form_id" id="$form_id" method="post">
390     $form
391 dpavlin 1164 <input type="submit" value="$submit">
392 dpavlin 1161 </form>
393     |;
394     $html .= $self->class->form_footer if $self->class->can('form_footer');
395     }
396    
397 dpavlin 507 $self->add_status({
398 dpavlin 595 $self->class => {
399 dpavlin 469 params => $self->params,
400 dpavlin 731 params_config => $params_config,
401     default => $default,
402 dpavlin 390 },
403 dpavlin 507 });
404 dpavlin 369
405 dpavlin 1171 $self->title( $self->class->title ) if $self->class->title;
406    
407 dpavlin 386 return ($html,$default) if wantarray;
408 dpavlin 369 return $html;
409     }
410    
411 dpavlin 1160 sub _label {
412     my ($self,$name) = @_;
413     my $labels = $self->class->form_labels if $self->class->can('form_labels');
414     my $label = $labels->{$name};
415     if ( ! defined $label ) {
416     $label = $name;
417     $label =~ s{_}{ }g;
418     }
419     return $label;
420     }
421    
422 dpavlin 731 =head1 SEE ALSO
423    
424     L<http://www.quirksmode.org/css/forms.html> for info on CSS2 forms
425    
426     =cut
427    
428 dpavlin 1133 __PACKAGE__->meta->make_immutable;
429     no Moose;
430    
431 dpavlin 369 1;

  ViewVC Help
Powered by ViewVC 1.1.26