HTML-TurboForm-0.634/ 0000755 0001750 0001750 00000000000 11473014547 014513 5 ustar thorsten thorsten HTML-TurboForm-0.634/lib/ 0000755 0001750 0001750 00000000000 11473014547 015261 5 ustar thorsten thorsten HTML-TurboForm-0.634/lib/HTML/ 0000755 0001750 0001750 00000000000 11473014547 016025 5 ustar thorsten thorsten HTML-TurboForm-0.634/lib/HTML/TurboForm.pm 0000644 0001750 0001750 00000053367 11473007273 020316 0 ustar thorsten thorsten package HTML::TurboForm;
use strict;
use warnings;
use UNIVERSAL::require;
use YAML::Syck;
our $VERSION='0.635';
use File::Copy;
sub new{
my ($class, $r,$prefix)=@_;
my $self = {};
$self->{request}= $r;
$self->{submitted} = 0;
$self->{after_upload}='';
$self->{submit_value} = '';
$self->{count}=0;
$self->{submit_id} = -1;
$self->{addition_modules}='';
$self->{prefix}='';
$self->{row_wrapper}='';
$self->{prefix}=$prefix if ($prefix);
bless( $self, $class );
return $self;
}
sub set_row_wrapper{
my ($self, $wrapper) = @_;
$self->{row_wrapper}=$wrapper;
}
sub add_modules{
my ($self, $mods) = @_;
$self->{addition_modules}=$mods;
}
sub add_constraint{
my ($self, $params) = @_;
my $name= $self->{prefix}.$params->{name};
$params->{request}=$self->{request};
my $class_name = "HTML::TurboForm::Constraint::" . $params->{ type };
$class_name->require() or die "Constraint Class '" . $class_name . "' does not exist: $@";
push(@ { $self->{constraints} }, $class_name->new($params));
}
sub add_uploads{
my ($self, $uploads) = @_;
$self->{uploads} = $uploads;
}
sub build_form{
my ($self, $data, $resultsource, $options)=@_;
my @columns=$resultsource->columns;
foreach (@columns){
my $forbidden=0;
my $info=$resultsource->column_info($_);
my $label=$_;
$label=$info->{label} if $info->{label};
my $type='Text';
$type=$info->{fieldtype} if $info->{fieldtype};
my $args={ type=>$type, name=> $_, label=> $label };
if ($data->{$_}) {
while(my($key, $value) = each(%{$data->{$_}})){
$args->{$key}=$value if ($key ne 'name');
}
}
my $k=$_;
if ($options->{definedonly}){
if ($options->{definedonly} eq '1'){
} else{
my $number = keys %$info;
$forbidden=1 if ($number==0);
}
} else{
my $number = keys %$info;
$forbidden=1 if ($number==0);
}
if (($data->{forbidden})&&($forbidden==0)){
#if ($data->{forbidden}){
foreach (@{$data->{forbidden}}){ $forbidden=1 if ($_ eq $k); }
}
$self->add_element($args) if $forbidden == 0;
}
}
sub load{
my ($self,$fn)=@_;
my $data = LoadFile($fn);
foreach my $item( @{ $data->{elements} }) {
$self->add_element($item);
}
foreach my $item( @{ $data->{constraints} }) {
if ($item->{params}->{compvalue}){
my $tmp=$item->{params}->{compvalue};
$item->{params}->{comp}=$self->get_value($tmp);
}
$self->add_constraint($item);
}
}
sub unignore_all{
my ($self ) = @_;
my $k;
my $v;
foreach $k(keys %{ $self->{element_index} } ){
$self->{element_index}->{$k}->{ignore}='false';
}
}
sub ignore_all{
my ($self ) = @_;
my $k;
my $v;
foreach $k(keys %{ $self->{element_index} } ){
$self->{element_index}->{$k}->{ignore}='true';
}
}
sub remove_all{
my ($self ) = @_;
$self->{element_index}={};
$self->{element}=();
}
sub ignore_element{
my ($self, $name ) = @_;
$name=$self->{prefix}.$name;
$self->{element_index}->{$name}->{ignore}='true';
}
sub unignore_element{
my ($self, $name ) = @_;
$name=$self->{prefix}.$name;
$self->{element_index}->{$name}->{ignore}='false';
}
sub add_element{
my( $self, $params ) = @_;
my $class='';
my $options='';
if (!$params->{name}){
$params->{name}='html'.$self->{count};
$self->{count}++;
}
$params->{request}=$self->{request};
my $namew= $params->{name};
my $name= $self->{prefix}.$params->{name};
$params->{name}=$name;
#print $name."\n";
my $class_name = "HTML::TurboForm::Element::" . $params->{ type };
$class_name->require() or die "Class '" . $class_name . "' does not exist: $@";
if (!$params->{wrapper}){
$params->{wrapper}=$self->{row_wrapper} if ($self->{row_wrapper} ne '');
}
my $element= $class_name->new($params,$self->{uploads}->{$name.'_upload'});
my $new_len = push(@ { $self->{element} }, $element);
$self->{element_index}->{$name}->{index}=$new_len-1;
$self->{element_index}->{$name}->{frozen}=0;
$self->{element_index}->{$name}->{ignore}='false';
$self->{element_index}->{$name}->{error_message}='';
if ($params->{type} eq 'Imageupload') {
if ( exists $self->{uploads}->{$name."_upload"} ){
$self->{after_upload}=$name;
$element->do_img();
}
}
if ($params->{type} eq 'Submit') {
if (( exists $self->{request}->{$name.".x"} )or(exists $self->{request}->{$name})){
$self->{submitted}=1 ;
$self->{submit_value} = $namew;
}
}
if ($params->{submit}){
if ( $self->{request}->{$name} ){
$self->{submitted}=1 ;
$self->{submit_value} = $namew;
}
}
if (($params->{type} eq 'Image')||($params->{type} eq 'Upload')) {
if ( exists $self->{request}->{$name.'_submit' } ){
$self->{submitted}=1 ;
$self->{submit_value} = $namew.'_uploaded';
}
}
if ($params->{type} eq 'Imagegalerie') {
my $f='';
$f = $self->find_action($name.'_delete_');
$self->{submit_value} = $namew.'_delete' if ($f ne '');
if ($f eq ''){
$f = $self->find_action($name.'_next_');
$self->{submit_value} = $namew.'_next' if ($f ne '');
}
if ($f eq ''){
$f = $self->find_action($name.'_prev_');
$self->{submit_value} = $namew.'_prev' if ($f ne '');
}
if ($f ne ''){
$self->{submitted}=1 ;
$self->{submit_id} = $f;
}
}
if ($params->{type} eq 'Imageslider') {
my $f='';
$f = $self->find_action($name.'_delete_');
if ($f ne ''){
$self->{submitted}=1 ;
$self->{submit_value} = $name.'_delete';
$self->{submit_id} = $f;
}
}
if ($params->{type} eq 'Captcha') {
my $tlabel=$params->{label1};
my $tlabel2=$params->{label2};
my $tname=$name."_input";
my $tname2=$name."_input2";
$self->add_element({ type => 'Text', name => $tname, label=> $tlabel } );
$self->add_element({ type => 'Text', name => $tname2, class=>"form_input2", label=> $tlabel2 } );
my $c_val = $self->get_value($tname2);
#use Data::Dumper;
#print STDERR Dumper($params);
$self->add_constraint({ type=> 'Equation', operator=>'eq', name=>$tname, comp=>$c_val, text=>$params->{message} });
#$self->add_constraint({ type=> 'Equation', operator=>'eq', name=>$tname2, comp=>'', text=>$params->{message} });
$self->add_constraint({ type=> 'Mintime', name=>$tname, keyname=> $params->{keyname}."2", keyphrase=>$params->{keyphrase} ,session=> $params->{session} , text=>'Error, please wait 5 Seconds and resubmit the form.' });
}
}
sub find_action{
my ($self, $action_part)=@_;
foreach (%{$self->{request}}){
if (length($_)>length($action_part)){
if (index($_,$action_part) > -1){
my $tmp = substr($_,length($action_part));
return $tmp if (length($tmp)>0);
}
}
}
return '';
}
sub do{
my ($self, $name, $fn,@args)=@_;
$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->$fn(@args);
}
sub get_javascript{
my ($self, $url)=@_;
my $js='';
my $result='';
my $usejquery = 0;
foreach my $item(@{$self->{element}}) {
if ($item->{js}){
$usejquery = 1;
$js.=$item->{js}."\n";
}
}
if ($usejquery==1){
$js='';
}
return $js;
}
sub get_jquery_modules{
my ($self, $url)=@_;
my @modules;
my @stylefiles;
my $js='';
my $result='';
my $css_r = '';
my $usejquery = 0;
foreach my $item(@{$self->{element}}) {
if ($item->{modules}){
foreach (@{ $item->{modules} }){
my $f = 0; foreach my $t(@modules){ if ($t eq $_) { $f = 1; }}
push(@modules, $_) if ($f==0) ;
}
}
if ($item->{stylefiles}){
foreach (@{ $item->{stylefiles} }){
my $f = 0; foreach my $t(@stylefiles){ if ($t eq $_) { $f = 1; }}
push(@stylefiles, $_) if ($f==0) ;
}
}
if ($item->{js}){
$usejquery = 1;
$js.=$item->{js}."\n";
}
}
if ($usejquery==1){
$js='';
}
foreach (@modules){
$result .=''."\n";
}
foreach (@stylefiles){
$css_r.=''."\n";
}
return $css_r.$result.$js.$self->{addition_modules};
}
sub set_table_class{
my ($self, $classname)=@_;
$self->{table_class}=$classname;
}
sub set_table_attributes{
my ($self, $attributes)=@_;
my $attr='';
while ( my ($key, $value) = each(%$attributes) ) {
$attr.=$key.'="'.$value.'" ';
}
$self->{table_attibutes}=$attr;
}
sub render{
my ($self, $view, $action)=@_;
my $table=-1;
my $count=0;
$view='' if (!$view);
$action=' action="'.$action.'" ' if ($action);
$action='' if (!$action);
my $table_class='class="form_table"';
$table_class= 'class="'.$self->{table_class}.'"' if ($self->{table_class});
$table_class=$self->{table_attibutes} if ($self->{table_attibutes});
my $result='
';
}
sub uploaded{
my ($self) = @_;
return $self->{after_upload} if ($self->{after_upload} ne '');
return '';
}
sub submit{
my ($self) = @_;
my $result='';
if ($self->{submit_value} ne '') {
$result=$self->{submit_value};
}
return $result;
}
sub submitted{
my ($self) = @_;
my $result='';
my $set=0;
if ($self->{submit_value} ne '') {
$result=$self->{submit_value};
#$result=substr($result,length($self->{prefix})) if ($self->{prefix} ne'');
foreach my $item(@{$self->{constraints}}) {
my $name=$item->{name};
if ($item->check() == 0){
$self->{element_index}->{$name}->{error_message}= $item->message();
$set=1;
}
}
$result='' if ($set==1);
}
return $result;
}
sub get_single_dbix{
my ($self,$name)=@_;
my $result = $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->get_dbix();
return $result;
}
sub get_dbix{
my ($self)=@_;
my $result;
foreach (@{$self->{element}}) {
my $tmp = $_->get_dbix();
if ($tmp){
while ( my ($key, $value) = each(%$tmp) ) {
$result->{$key} = $value;
}
}
}
return $result;
}
sub add_options{
my ($self,$name,$options)=@_;
$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->add_options($options);
}
sub reset_options{
my ($self,$name,$options,$label,$id)=@_;
$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->reset_options($options,$label,$id);
}
sub freeze{
my ($self, $name)=@_;
$self->{element_index}->{$self->{prefix}.$name}->{frozen}=1;
$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->freeze();
}
sub get_r{
my ($self, $name)=@_;
$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->pure(1) if (!$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->pure);
return $self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->render();
}
sub get_e{
my ($self, $name)=@_;
return '' if (!$self->{element_index}->{$self->{prefix}.$name}->{error_message});
return $self->{element_index}->{$self->{prefix}.$name}->{error_message};
}
sub get_errors{
my ($self)=@_;
my $k;
my $result='';
foreach $k(keys %{ $self->{element_index} } ){
$result.=$self->{element_index}->{$k}->{error_message}.' ' if ( $self->{element_index}->{$k}->{error_message});
}
return $result;
}
sub freeze_all{
my ($self)=@_;
my $k;
my $v;
foreach $k(keys %{ $self->{element_index} } ){
$self->{element_index}->{$k}->{frozen}=1;
}
}
sub unfreeze{
my ($self, $name)=@_;
$self->{element_index}->{$self->{prefix}.$name}->{frozen}=0;
}
sub get_value{
my ($self, $name)=@_;
my $result='';
if (!$self->{request}->{$self->{prefix}.$name}){
} else {
$result=$self->{element}[$self->{element_index}->{$self->{prefix}.$name}->{index}]->get_value();
}
return $result;
}
sub populate{
my ($self, $data, $anyway)=@_;
$self->{submit_value}='' unless ($self->{submit_value});
if (($self->{submit_value} eq '') or ($anyway ne '')) {
if (ref($data) eq 'HASH') {
while (my ($key, $value) = each %{ $data }){
$self->{request}->{$self->{prefix}.$key}=$value;
}
} else {
my @columns= $data->result_source->columns;
foreach my $item(keys %{$self->{element_index}}) {
$item=substr($item,length($self->{prefix})) if ($self->{prefix} ne'');
if ( grep { $item eq $_ } @columns ) {
if (!$self->{request}->{$self->{prefix}.$item}) {
$self->{request}->{$self->{prefix}.$item}=$data->get_column($item);
}
}
}
}
}
}
sub serial_populate{
my ($self, $data)=@_;
my $result = {};
my @arr_data = split('&',$data);
foreach (@arr_data) {
my @tmp = split('=',$_);
$self->{request}->{$self->{prefix}.$tmp[0]} = $tmp[1] if ($tmp[1]);
}
}
sub map_value{
my ($self, @columns)=@_;
my $result;
foreach my $item(keys %{$self->{element_index}}) {
$item=substr($item,length($self->{prefix})) if ($self->{prefix} ne'');
my $type=$self->{element}[$self->{element_index}->{$self->{prefix}.$item}->{index}]->type;
if (($type ne 'Upload')&&($type ne 'Image')){
if ( grep { $item eq $_ } @columns ) {
$result->{$item}=$self->get_value($item);
}
}
}
return $result;
}
sub get_values{
my ($self)=@_;
my $result;
foreach my $item(keys %{$self->{element_index}}) {
$item=substr($item,length($self->{prefix})) if ($self->{prefix} ne'');
$result->{$item}=$self->get_value($item);
}
return $result;
}
1;
__END__
=head1 HTML::TurboForm
HTML::TurboForm - fast and compact HTML Form Class
=head1 SYNOPSIS
to start with, two simple examples of how to use turboform. I am still working on both the classes and the docs so please be patient.
=head2 Usage variant 1 : via objects and methods
my $options;
$options->{ 'label1' }='1';
$options->{ 'label2' }='2';
$options->{ 'label3' }='3';
$form->add_element({ type => 'Html', text =>'
' });
$form->add_element({ type => 'Text', name => 'texttest', label => 'element1' } );
$form->add_element({ type => 'Text', name => 'texttest2', label => 'vergleichselement' } );
$form->add_element({ type => 'Textarea', name => 'textareatest', label => 'Areahalt:' } );
$form->add_element({ type => 'Submit', name => 'freeze', label => ' ', value=>'einfrieren' } );
$form->add_element({ type => 'Submit', name => 'unfreeze', label => ' ', value=>'normal' } );
$form->add_element({ type => 'Checkbox', name => 'boxtest', label => 'auswählen', options => $options, params =>{ 'listmode'=>'' } } );
$form->add_element({ type => 'Html', text =>'' });
$form->add_element({ type => 'Select', name => 'selecttest', label => 'selectieren', options => $options } );
$form->add_element({ type => 'Select', name => 'selecttest2', label => 'selectieren', options => $options, attributes => { 'multiple'=>'' , 'size'=>'3' } } );
$form->add_element({ type => 'Text', name => 'mailtest', label => 'E-Mail' } );
$form->add_element({ type => 'Radio', name => 'tadiotest', label => 'radioteile', options => $options, params =>{ 'listmode', 'norow'} } );
$form->add_element({ type => 'Date', name => 'datetest', label => 'Datum', params=>{ startyear=> '2000' , endyear => '2020' } } );
$form->add_element({ type => 'Image', name => 'imagetest', label => 'Bild', width=>'400', height=>'300',
thumbnail => { width => '60', height=>'80' },
savedir=>'/home/whocares/catalyst/formproject/root/static/images/temp',
loadurl=>'/static/images/temp' } );
$form->add_constraint({ type=> 'Equation', name=> 'texttest', text=> 'kein Vergleich', params=>{ operator => 'eq', comp=>$form->get_value('texttest2') } });
$form->add_constraint({ type=> 'Required', name=> 'boxtest', text=> 'du musst schon was auswählen' });
$form->add_constraint({ type=> 'Date', name=> 'datetest', text=> 'das ist doch kein datum' });
$form->add_constraint({ type=> 'Email', name=> 'mailtest', text=> 'ungültige Mailadresse' });
$form->add_element({ type => 'Html', text =>'
' });
$form->freeze_all() if ($form->submitted() eq 'freeze');
$c->stash->{form} = $form->render();
$c->stash->{template}='formtest/formtest.tt';
if ($form->submitted() eq 'freeze') {
my @cols= ('txt1','date','txt2','checkboxtest');
my $data=$form->map_value(@cols);
}
=head2 Usage Variant 2 : via yml file:
my $form= new HTML::TurboForm($c->req->params);
$form->load('test.yml');
my $text=$form->render();
if ($form->submitted eq 'freeze') {}
Sample yml-file:
---
languages:
- de
elements:
- type: Html
text:
- type: Text
name: messageausyml
label: ausyml
- type: Text
name: txt1
label: sampleinput
- type: Text
name: txt2
label: whatever to compare
- type: Checkbox
label: chooser
name: checkboxtest
options:
label1: 1
label2: 2
- type: Html
text:
- type: Radio
label: radiochooser
options:
radio1: 1
radio2: 2
- type: Submit
name: freeze
value: einfrieren
- type: Submit
name: defreeze
value: normal
- type: Date
label: Datum
name: date
params:
startyear: 2000
endyear: 2010
- type: Html
text:
constraints:
- type: Required
name: messageausyml
text: mandatory field
- type: Date
name: date
text: must be a correct date
- type: Equation
name: txt1
text: must be higher
params:
operator: <
compvalue: txt2
=head1 DESCRIPTION
HTML::TurboForm was designed as a small, fast and compact Form Class to use with catalyst in order to easily create any needed Form.
I know there a quite a lot of classes out there which do the same but i wasn't quite content with what i found.
They were either too slow or complicated or both.
=head1 METHODS
=head2 new
Arguments: $request
Creates new Form Object, needs Request Arguments to fill out Form Elements. To do so it's very important that the form elements
have the same names as the request parameters.
=head2 add_constraint
Arguments: $params
Adds a new Contraint to the Form. Constraints can be date, required or any other constraint class object.
Only if they successfully match the given constraint rule the form will return valid.
=head2 load
Arguments: $fn
Loads a form from a given YML File.
=head2 unignore_element
Arguments: $name
will unIgnore an element so it will be rendered normally
=head2 ignore_element
Arguments: $name
will Ignore an element so it won't be rendered and in effect invisible, it's value will be given to the form as hidden value
=head2 add_element
Arguments: $params
Will add a new Form Element, for example a new text element or select box or whatever.
=head2 render
Arguments: none
Renders the form. Will retrun the HTML Code for the form including error messages.
=head2 submitted
Arguments: none
Will be true if the form is correctly filled out by user, otherwise it returns false and shows the corresponding error message(s).
=head2 add_options
Arguments: $name, $option
Adds option to HTML elements that needs them, for example select boxes.
=head2 freeze
Arguments: $name
Will disable the HTML Element identified by name for viewing purposes only.
=head2 freeze_all
Arguments: none
Freezes the whole form.
=head2 unfreeze
Arguments: $name
Unfreezes certain Element.
=head2 get_value
Arguments: $name
Returns Value of Eelement by name
=head2 populate
Arguments: $data
fills form with values form hash.
=head2 map_value
Arguments: @columns
Expects an array with column names. This method is used to map the request and form elements to the columns of a database table.
=head1 AUTHOR
Thorsten Drobnik, camelcase@hotmail.com
=head1 LICENSE
This library is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/ 0000755 0001750 0001750 00000000000 11473014547 017744 5 ustar thorsten thorsten HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint.pm 0000644 0001750 0001750 00000001137 11455433374 022433 0 ustar thorsten thorsten package HTML::TurboForm::Constraint;
use warnings;
use strict;
use base qw/ Class::Accessor /;
__PACKAGE__->mk_accessors( qw/ params request type name text / );
sub message{
my ($self)=@_;
return $self->text;
}
1;
__END__
=head1 HTML::TurboForm::Constraint
Base Class for formconstraints
=head1 SYNOPSIS
$form->addconstraint(...);
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 message
Arguments: none
returns error message of constraint
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element.pm 0000644 0001750 0001750 00000014427 11473007143 021675 0 ustar thorsten thorsten package HTML::TurboForm::Element;
use warnings;
use strict;
use base qw/ Class::Accessor /;
__PACKAGE__->mk_accessors( qw/ params submit wrapper errorclass pure default dbsearchfield dbdata optionstext dbop dbid dblabel ignore_dbix type id name label text value request options optionsnum class left_class limit right_class row_class attributes table submit columns / );
sub new{
my ($class, $request) = @_;
my $self = $class->SUPER::new( $request );
$self->{view} ='';
$self->{submitted} = 0;
$self->{submitted} = 1 if ($request->{ $self->name });
if ($self->dbdata and $self->dbid and $self->dblabel){
my @t = @{ $self->dbdata };
foreach (@t){
my $label_method = $self->dblabel;
my $value_method = $self->dbid;
my $l=$_->$label_method;
my $v=$_->$value_method;
$self->options->{$l}=$v;
}
}
if ($self->submit){
@{$self->{modules}} = ('jquery/jquery');
$self->{js} = ' $("#'.$self->name.'").'.$self->submit.'(function(){$("form")[0].submit(); }); ';
}
if ($self->dbdata and $self->dbid and not $self->dblabel){
my @t = @{ $self->dbdata };
my @tmp;
foreach (@t){
my $value_method = $self->dbid;
my $v=$_->$value_method;
push(@tmp,$v);
}
@{$self->{options}} = @tmp;
}
$self->init();
return $self;
}
sub init{
my ($self) = @_;
}
sub add_options{
my ($self, $opt) = @_;
$self->{options} = $opt;
}
sub reset_options{
my ($self, $opt) = @_;
$self->{dbdata}=[];
$self->{options}=[];
$self->{options} = $opt;
}
sub freeze{
my($self) =@_;
}
sub populate{
my($self) =@_;
}
sub get_attr{
my ($self) =@_;
my $result="";
while ( my( $key,$value) = each %{$self->{attributes}}){
if ($value) {
$result.=' '.$key.'="'.$value.'"';
} else {
$result.=' '.$key;
}
}
return $result.' ';
}
sub check_param{
my ($self, $name)=@_;
my $result=0;
if ( exists($self->{params}->{ $name })) {
$result=1;
}
return $result;
}
sub get_dbix{
my ($self)=@_;
if (!$self->ignore_dbix) {
my $dbname=$self->name if ($self->name);
$dbname =$self->dbsearchfield if ($self->dbsearchfield);
if ($self->type eq 'Select'){ return 0 if ($self->get_value() eq '-1'); }
if($self->get_value() ne '') {
return { $dbname => $self->get_value()};
} else {
return 0;
}
} else {return 0;}
}
sub vor{
my ($self,$options)=@_;
return "" if ( $self->pure );
my $error='';
$error=$options->{error_message} if $options->{error_message};
my $result='';
my $table='';
my $rwc='';
my $rtc='';
my $ltc='';
my $class='class="form_row"';
my $errorclass=" ".$self->errorclass if ($self->errorclass);
if ($self->{class}) { $class='class="'.$self->{class}.'"'; }
if ($self->{row_class}) { $rwc = " class='".$self->{row_class}."' "; }
if ($self->{right_class}) { $rtc = " class='".$self->{right_class}."' "; }
if ($self->{left_class}) { $ltc = " class='".$self->{left_class}."' "; }
if ($self->{view} eq '') {
$error="
$error
" if ($error ne '');
$self->label('') if (!$self->label);
$errorclass='' if (!$errorclass);
$result=$table."
".$error.
"
".$self->label."
".
"
";
#$result=$table."
".$error.
# "
".$self->label."
".
# "
";
$result=$table."
" if ($self->type eq "Html");
}
if ($self->{view} eq 'table') {
$error='
'.$error.'
' if ($error ne '');
$table='' if (!$table);
$error='' if (!$error);
$class='';
$rwc='' if (!$rwc);
$rtc='' if (!$rtc);
$self->label('') if (!$self->label);
$result = $table. $error. "
".
"
".$self->label."
".
"
";
$result=$table.'
' if ($self->type eq "Html");
}
if ($self->{view} eq 'column') {
$self->label('') if (!$self->label);
$result='
'.$self->label.'
';
$result.=$error.' ' if ($error ne '');
}
if ($self->wrapper){
my $wrap=$self->wrapper;
my $s='';
$s=$self->label if (!$s);
$wrap=~s/
" if ($self->{view} eq 'table');
$result="" if ($self->{view} eq 'column');
if ($self->wrapper){
$result=$self->{after_wrap} if ($self->{after_wrap});
}
$result.="\n";
return $result;
}
sub get_label{
my ($self) = @_;
my $result='';
$result=$self->label if $self->label;
return $result;
}
sub get_value{
my ($self) = @_;
my $result='';
$result=$self->{request}->{$self->name} if exists($self->{request}->{$self->name});
return $result;
}
1;
__END__
=head1 HTML::TurboForm::Element
Base Class for HTML elements
=head1 SYNOPSIS
$form->addelement(...);
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 add_options
Arguments: $options
adds option tags to a html element
=head2 get_value
Arguments: none
returns value of the element
=head2 get_attr
Arguments: none
Return List of attributes of HTML Tag
=head2 check_param
Arguments: $name
checks if param with given name does exist
=head2 nach
Arguments: none
returns given prehtml
=head2 vor
Arguments: none
return given posthtml
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/ 0000755 0001750 0001750 00000000000 11473014547 021335 5 ustar thorsten thorsten HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Slider.pm 0000644 0001750 0001750 00000006255 11455433374 023130 0 ustar thorsten thorsten package HTML::TurboForm::Element::Slider;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ min max steps label_addon start modules zerovalue / );
sub init{
my ($self)=@_;
my $min = 0;
my $max = 100;
my $step = 10;
my $start = $self->start;
$min=$self->min;
$min-- if($self->zerovalue);
$step=$self->steps;
$max=$self->max;
my $js_min='';
$js_min ='if (ui.value == '.$min.') label="'.$self->zerovalue.'";' if($self->zerovalue);
@{$self->{modules}} = ('jquery/jquery','jquery/ui.core.min','jquery/ui.slider.min');
my $labelchange='';
$labelchange = 'if (label != "'.$self->zerovalue.'") label+="'.$self->label_addon.'";' if ($self->label_addon);
$self->{js} = '
$("#'.$self->name.'_slider").slider({
"steps": '.$step.',
"min": '.$min.',
"max": '.$max.',
"startValue": '.$start.',
"slide": function(e, ui){
var label = ui.value;
'.$js_min.'
$("#'.$self->name.'").val(ui.value);
'.$labelchange.'
$("#'.$self->name.'_label").html(label);
}
}); ';
$self->{value}=$self->request->{ $self->name };
if ($self->{value}){
$self->{js} .= '$("#'.$self->name.'_slider").slider("moveTo",'.$self->{value}.');';
}
}
sub get_dbix{
my ($self)=@_;
my $dbname=$self->name if ($self->name);
$dbname =$self->dbsearchfield if ($self->dbsearchfield);
my $val = $self->get_value();
if($val ne '') {
if ($val < $self->min) {
return 0;
} else {
if (!$self->dbop){
return { $dbname => $val } ;
} else {
return { $dbname => { $self->dbop => $val }} ;
}
}
} else {
return 0;
}
}
sub get_value{
my ($self)=@_;
return 0 if (($self->zerovalue) && ( $self->{value} == ($self->{min}-1)));
return $self->{value};
}
sub freeze{
my ($self)=@_;
$self->{js} .= '$("#'.$self->name.'_slider").slider("disable");';
}
sub render {
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_text';
$class = $self->class if ($self->class);
my $name=$self->name;
my $minlabel = $self->min;
my $maxlabel = $self->max;
$minlabel = $self->zerovalue if ($self->zerovalue);
$result='
'.$minlabel.'
';
return $self->vor($options).$result.$self->nach;
}
1;
__END__
=head1 HTML::TurboForm::Element::Slider
Representation class for HTML SLider input element. This Element uses the jquery Javascript library !
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Text.pm 0000644 0001750 0001750 00000002502 11455433374 022621 0 ustar thorsten thorsten package HTML::TurboForm::Element::Text;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
sub render {
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $id='';
$id=' id="'.$self->id.'" ' if ($self->id);
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_text';
$class = $self->class if ($self->class);
$class = 'class="'.$class.'"';
my $name=' name="'.$self->name.'" ';
my $value='';
$value=' value="'.$request->{ $self->name }.'" ' if ($request->{ $self->name });
if ($options->{frozen}) {
if ($options->{frozen} eq 1) {
my $text= $value;
$disabled=' disabled ';
$result='';
}
}
my $limit='';
$limit=' maxlength="'.$self->limit.'"' if ($self->limit);
$result .='' ;
return $self->vor($options).$result.$self->nach;
}
1;
__END__
=head1 HTML::TurboForm::Element::Text
Representation class for HTML Text input element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Imagegalerie.pm 0000644 0001750 0001750 00000004626 11455433374 024261 0 ustar thorsten thorsten package HTML::TurboForm::Element::Imagegalerie;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ del_link all_link max dir noimgs / );
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $result='';
my $disabled='';
my $class='form_imagegalerie';
my $request=$self->request;
$self->label(' ') if ($self->label eq '');
$class=$self->{class} if exists($self->{class});
my $aha=$self->options;
my $name=$self->name;
my $nr_obj = scalar(@{ $self->{options} });
$disabled=' disabled ' if ($options->{frozen} == 1);
my $dir='';
$dir = $self->dir if ($self->dir);
$result.='
'."\n";
$result.='
';
foreach (@{$self->{options}}){
my $col_fn = $self->dbid;
my $col_label = $self->dblabel;
my $fn ='';
$fn = $_->$col_fn if ($_->$col_fn);
if (!$self->noimgs){
if ($self->all_link){
my $label = '';
$label = ' '.$_->$col_label.'' if($self->dblabel);
$result.='
'.$label.'
'."\n";
}else{
$result.='
'."\n";
}
}
if ($self->noimgs){ $result.='
'.$fn.'
'."\n";}
}
$result.='
';
$result='' if ($nr_obj ==0);
$result= $self->vor($options).$result.$self->nach if ($self->check_param('norow')==0);
return $result;
}
sub init{
my ($self)=@_;
my $name=$self->name;
}
sub get_dbix{
my ($self)=@_;
return 0;
}
1;
__END__
=head1 HTML::TurboForm::Element::Imageslider
Representation class for Imageslider element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for checkbox element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Submit.pm 0000644 0001750 0001750 00000003166 11455433374 023147 0 ustar thorsten thorsten package HTML::TurboForm::Element::Submit;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ image pure ajaxcall / );
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $result='';
my $disabled='';
if ($self->label and ($self->label eq '')) {
$self->label(' ');
}
my $class= "form_std";
$class=$self->class if ($self->class);
my $id='';
$id=" id='$self->{name}' ";
my $value=$self->value;
$value= ' value="'.$value.'" ';
if ($options->{frozen}){
if ($options->{frozen} == 1) {
my $text= $value;
}
}
my $js_tag_text = '';
if ($self->ajaxcall) {
$result= '';
$result= $result.'ajaxcall."'".');" value="'.$self->{value}.'"> ';
} else {
my $t = 'type="Submit"';
$t = 'type="image" src="'.$self->image.'"' if ($self->image);
$result =$result.'' ;
}
return $result if ($self->{pure});
return $self->vor($options).$result.$self->nach;
}
sub get_dbix{
my ($self)=@_;
return 0;
}
1;
__END__
=head1 HTML::TurboForm::Element::Submit
Representation class for HTML Submit element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for Submit element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Hidden.pm 0000644 0001750 0001750 00000001707 11455433374 023076 0 ustar thorsten thorsten package HTML::TurboForm::Element::Hidden;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
sub render {
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $id='';
$id=" id='".$self->name."' ";
my $name=' name="'.$self->name.'" ';
my $value='';
$value=' value="'.$self->value.'" ' if ($self->value);
$value=' value="'.$request->{ $self->name }.'" ' if ($request->{ $self->name });
$result .='' ;
return $result;
}
1;
__END__
=head1 HTML::TurboForm::Element::Hidden
Representation class for HTML Hidden input element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Checkbox.pm 0000644 0001750 0001750 00000004537 11455433374 023435 0 ustar thorsten thorsten package HTML::TurboForm::Element::Checkbox;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ tablelayout listmode/ );
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $result='';
my $disabled='';
my $class='';
my $request=$self->request;
if (!$self->label){ $self->label(''); }
$self->label(' ') if ($self->label eq '');
$class=' class="'.$self->{class}.'" ' if exists($self->{class});
my $name=' name="'.$self->name.'" ';
my $checked='';
if ($options->{frozen}){
$disabled=' disabled ' if ($options->{frozen} == 1) ;
}
my $pre='';
my $post='';
my $after='';
$self->listmode('') if (!$self->listmode);
if ( $self->listmode ne '' ){
$result.='
';
$pre='
';
$post='
';
$after='
';
}
my $counter=0;
my $max=0;
if ($self->tablelayout) {
$result.='
';
$max = $self->tablelayout ;
}
while ( my( $key,$value) = each %{$self->options}){
$counter++;
if (($counter == $max) && ($self->tablelayout)) {
$result.="
\n
";
$counter = 0;
}
my $values = $request->{ $self->name };
$values = [ $values ] unless ref( $values ) =~ /ARRAY/;
$checked='';
if ([ $values]){ $checked=' checked ' if ( grep { $_ eq $value if ($_) } @{ $values } ); }
$result.=$pre.''.$key.$post;
$result.='' if (($disabled ne '')&& ( $checked ne ''));
$result.=' ' if($self->tablelayout);
}
$result.=$after;
$result.='
' if ($self->tablelayout);
return $result if ($self->tablelayout);
$result= $self->vor($options).$result.$self->nach if ($self->check_param('norow')==0);
return $result;
}
1;
__END__
=head1 HTML::TurboForm::Element::Checkbox
Representation class for HTML Checkbox element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for checkbox element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Imageupload.pm 0000644 0001750 0001750 00000021065 11455433374 024131 0 ustar thorsten thorsten package HTML::TurboForm::Element::Imageupload;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
use Imager;
use File::Finder;
__PACKAGE__->mk_accessors( qw/ prev upload keeporiginal scaletype filename width height savedir thumbnail loadurl caption maxsize errormessage / );
sub new{
my ($class, $request, $upload) = @_;
my $self = $class->SUPER::new( $request );
$self->upload( $upload );
$self->do_img();
return $self;
}
sub ren{
my ($self, $newfilename)=@_;
my $file='';
my $request=$self->request;
$file=$self->{pic};
if (!$self->{pic}){
$file=$request->{$self->name} if ($request->{$self->name});
}
rename($self->savedir.'/med_'.$file, $self->savedir.'/'.$newfilename.'.jpg');
}
sub ren_thumb{
my ($self, $newfilename)=@_;
my $file='';
my $request=$self->request;
$file=$self->{pic};
if (!$self->{pic}){
$file=$request->{$self->name} if ($request->{$self->name});
}
rename($self->thumbnail->{savedir}.'/thumb_'.$file, $self->thumbnail->{savedir}.'/'.$newfilename.'.jpg');
}
sub do_img{
my ($self)=@_;
my $request=$self->request;
my $pic='';
$pic = $self->request->{$self->name} if ($self->request->{$self->name} );
if ($request->{ $self->name.'_upload' }) {
if( $self->upload->type !~ /^image\/(jpeg|jpg|gif|png|pjpeg)$/ ) {
#$c->stash->{ 'error' } = 'Filetype not supported!';
} else {
# read image
my $image = Imager->new;
$self->{sizeerror}=0;
if ($self->maxsize) {
if (($self->upload->size/1024) > $self->maxsize){
$self->{sizeerror}=1;
}
}
if (!$self->{sizeerror}){
if( $image->read( file => $self->upload->tempname ) ) {
# remove alpha channels because jpg does not support it # and its not used anyways
$image = $image->convert( preset => 'noalpha' );
#attribute keeporignal isparams local path for storing orig sized images
my $tmp = File::Temp->new( DIR => $self->savedir.'', UNLINK => 0, SUFFIX => '.jpg' );
$pic = substr( $tmp, length( $self->savedir )+1 );
$self->{pic}=$pic;
if ($self->keeporiginal){
$self->upload->copy_to($self->keeporiginal.'/orig_'.$pic);
}
# if there is a save dir, resize. depending if width and/or height is given, scale to dimensions
if ($self->savedir){
my $continueflag=1;
if ($self->scaletype eq 'smart'){
if ($self->width && $self->height){
$continueflag = 0;
my $container_dir='v';
if ($self->width > $self->height){
my $container_dir='h';
}
my $dir='v';
if ($image->getwidth() > $image->getheight()){
$dir='h';
}
if ($container_dir ne $dir ){
my $tmp=$self->width;
$self->width=$self->height;
$self->height=$tmp;
}
$image = $image->scale(ypixels=>$self->height,xpixels=>$self->width);
}
}
if ($continueflag==1){
if (($self->width) and ($self->height) and ($self->scaletype)) {
# Resize height, scale width
$image = $image->scale(ypixels=>$self->height,xpixels=>$self->width,type=>$self->scaletype);
} elsif (($self->width) and ($self->height)) {
# No scale. Resize to given dimensions
$image = $image->scaleX(pixels=>$self->width)->scaleY(pixels=>$self->height);
} elsif ($self->width) {
# Resize width, scale height
$image = $image->scale(xpixels=>$self->width);
} elsif ($self->height) {
# Resize height, scale width
$image = $image->scale(ypixels=>$self->height);
}
}
$image->write(
file => $self->savedir.'/med_'.$pic,
type => 'jpeg',
jpegquality => 90
);
unlink($self->upload->tempname);
if ($self->thumbnail) {
if ($self->thumbnail->{width} || $self->thumbnail->{height} ) {
if (($self->thumbnail->{width}) and ($self->thumbnail->{height})) {
# No scale. Resize to given dimensions
$image = $image->scaleX(pixels=>$self->thumbnail->{width})->scaleY(pixels=>$self->thumbnail->{height});
} elsif ($self->thumbnail->{width}) {
# Resize width, scale height
$image = $image->scale(xpixels=>$self->thumbnail->{width});
} elsif ($self->thumbnail->{height}) {
# Resize height, scale width
$image = $image->scale(ypixels=>$self->thumbnail->{height});
}
my $thmb_fn = $self->savedir.'/thumb_'.$pic;
$thmb_fn = $self->thumbnail->{savedir}.'/thumb_'.$pic if ($self->thumbnail->{savedir});
$image->write(
file => $thmb_fn,
type => 'jpeg',
jpegquality => 90
);
}
}
unlink($self->savedir.'/'.$pic);
}
}
}
}
}#end of if upload and submit
}
sub get_value{
my ($self) = @_;
my $result='';
my $request=$self->request;
$result=$self->{pic};
if (!$self->{pic}){
$result=$request->{$self->name} if ($request->{$self->name});
}
return $result;
}
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_image_select';
$self->label(' ') if ($self->label eq '');
$class=$self->{class} if exists($self->{class});
my $name=' name="'.$self->name.'_upload" ';
my $checked='';
my $pic='';
$pic= $self->{pic} if ($self->{pic});
$pic=$request->{$self->name} if ($request->{$self->name});
if ($options->{frozen}) {
$disabled=' disabled ' if ($options->{frozen} == 1);
}
my $tmpres='';
$tmpres.= $self->errormessage if ($self->{sizeerror} && $self->errormessage);
$tmpres.='get_attr().$disabled.$name.'>';
if ($options->{frozen}) {
$result .= $tmpres unless ($options->{frozen} == 1 );
} else {
$result .= $tmpres;
}
$result.='';
if ($pic ne ''){
$result.="
";
$result.="" if ($self->loadurl);
}
return $self->vor($options).$result.$self->nach;
}
1;
__END__
=head1 HTML::TurboForm::Element::Imageupload
Representation class for HTMl SelectBox element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for select element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Upload.pm 0000644 0001750 0001750 00000005376 11473004657 023133 0 ustar thorsten thorsten package HTML::TurboForm::Element::Upload;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
use File::Copy "mv";
use File::Path;
__PACKAGE__->mk_accessors( qw/ prev upload maxsize keeporiginal savedir loadurl filedir caption overwrite errormessage / );
sub new{
my ($class, $request, $upload) = @_;
my $self = $class->SUPER::new( $request );
$self->upload( $upload );
my $pic='';
$pic = $self->request->{$self->name} if ($self->request->{$self->name} );
if (!$self->filedir){
$self->filedir('');
} else {
mkpath($self->savedir.'/'.$self->filedir);
$self->filedir($self->filedir.'/') if ($self->filedir!~/(.*)\/$/);
}
if ($self->request->{ $self->name.'_upload' }) {
if ((-e $self->savedir.'/'.$self->filedir.$self->upload->basename)&&(!$self->overwrite)){
$pic='ERROR';
} else {
mv($self->upload->tempname,$self->savedir.'/'.$self->filedir.$self->upload->basename);
$pic = $self->savedir.'/'.$self->upload->basename;
}
}
$self->{pic}=$pic;
return $self;
}
sub get_value{
my ($self) = @_;
my $result='';
my $request=$self->request;
$result=$self->{pic} if ($self->{pic});
if (!$self->{pic}){
$result=$request->{$self->name} if ($request->{$self->name});
}
return $result;
}
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_upload_select';
$self->label(' ') if ($self->label eq '');
$class=$self->{class} if exists($self->{class});
my $name=' name="'.$self->name.'_upload" ';
my $checked='';
$disabled=' disabled ' if ($options->{frozen} == 1);
if ($options->{frozen} != 1 ){
$result.= $self->errormessage if ($self->{sizeerror} && $self->errormessage);
$result.='get_attr().$disabled.$name.'>';
$result.='';
}
if ($self->get_value() ne ''){
my @parts=split('/',$self->get_value());
my $f= pop(@parts);
$result.='File: '.$f;
}
return $self->vor($options).$result.$self->nach;
}
1;
__END__
=head1 HTML::TurboForm::Element::Upload
Representation class for HTMl SelectBox element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for select element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Select.pm 0000644 0001750 0001750 00000010222 11473011707 023102 0 ustar thorsten thorsten package HTML::TurboForm::Element::Select;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ default first optionstext/ );
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_select';
$self->label(' ') if (!$self->label);
$class=$self->{class} if exists($self->{class});
my $name=' name="'.$self->name.'" ';
my $id=' id="'.$self->name.'" ';
my $checked='';
$self->{submitted} = 1 if ($request->{ $self->name });
if ($self->{submitted} == 0){
$request->{ $self->name } = $self->default if($self->default);
}
if ($options->{frozen}){
$disabled=' disabled ' if ($options->{frozen} == 1);
}
if ($self->dbdata and $self->dbid and $self->dblabel){
my @t = @{ $self->dbdata };
foreach (@t){
my $label_method = $self->dblabel;
my $value_method = $self->dbid;
my $l=$_->$label_method;
my $v=$_->$value_method;
$self->options->{$l}=$v;
}
}
$result.='';
return $self->vor($options).$result.$result2.$self->nach if ($self->{pure});
return $self->vor($options).$result.$result2.$self->nach;
}
sub get_value{
my ($self) = @_;
my $result='';
$result=$self->{request}->{$self->name} if exists($self->{request}->{$self->name});
$result='' if ($result eq '-1');
return $result;
}
1;
__END__
=head1 HTML::TurboForm::Element::Select
Representation class for HTMl SelectBox element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for select element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Html.pm 0000644 0001750 0001750 00000001463 11455433374 022606 0 ustar thorsten thorsten package HTML::TurboForm::Element::Html;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ pure / );
sub render {
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
return $self->{text} if ($self->{pure});
return $self->vor($options).$self->{text}.$self->nach;
}
sub get_dbix{
my ($self)=@_;
return 0;
}
1;
__END__
=head1 HTML::TurboForm::Element::Html
Representation class for Html element .
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code. This element is needed if you want to insert plain HTML Code in a certain Position in a form.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Date.pm 0000644 0001750 0001750 00000014067 11455433374 022563 0 ustar thorsten thorsten package HTML::TurboForm::Element::Date;
use warnings;
use strict;
use DateTime::Format::MySQL;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ showdate language /);
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_date';
$self->label(' ') if ($self->label eq '');
$class=$self->{class} if exists($self->{class});
my $name=' name="'.$self->name;
my $checked='';
my $startyear=1977;
my $endyear=2010;
$startyear=$self->{params}->{startyear};
$endyear=$self->{params}->{endyear};
if (!$self->{request}->{$self->name}.'_day' ) {
if ($self->{request}->{$self->name}){
my $dt = DateTime::Format::MySQL->parse_datetime($self->{request}->{$self->name});
if ($self->showdate ne 'no'){
$self->{request}->{$self->name.'_year'} = $dt->year;
$self->{request}->{$self->name.'_month'} = $dt->month;
$self->{request}->{$self->name.'_day'} = $dt->day;
}
if ($self->{params}->{showtime} eq '24'){
$self->{request}->{$self->name.'_hour'} = $dt->hour;
$self->{request}->{$self->name.'_minute'} = $dt->minute;
}
}
}
if ($options->{frozen} == 1){
$disabled=' disabled ';
$result.='';
$result.='';
$result.='';
}
if ($self->showdate ne 'no'){
$result.='';
$result.='';
$result.='';
} else {
$result.='';
$result.='';
$result.='';
}
if ($self->{params}->{showtime} eq '24'){
$result.=' ';
$result.='';
}
return $self->vor($options).$result.$self->nach;
}
sub get_value{
my ($self) = @_;
my $result='';
if ($self->{request}->{$self->name.'_day'}) {
$result=$self->{request}->{$self->name.'_year'}.'-'.
$self->{request}->{$self->name.'_month'}.'-'.
$self->{request}->{$self->name.'_day'};
if ($self->{params}->{showtime} eq '24'){
$result.=' '.$self->{request}->{$self->name.'_hour'}.'-'.
$self->{request}->{$self->name.'_minute'};
}
} else {
if ($self->{request}->{$self->name}){
my $dt = DateTime::Format::MySQL->parse_datetime($self->{request}->{$self->name});
$self->{request}->{$self->name.'_year'} = $dt->year;
$self->{request}->{$self->name.'_month'} = $dt->month;
$self->{request}->{$self->name.'_day'} = $dt->day;
if ($self->{params}->{showtime} eq '24'){
$self->{request}->{$self->name.'_hour'} = $dt->hour;
$self->{request}->{$self->name.'_minute'} = $dt->minute;
}
}
}
return $result;
}
1;
__END__
=head1 HTML::TurboForm::Element::Date
Representation class for Date element consisting out of three seperate select boxes.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for date element.
=head2 get_value
Arguments: none
returns selected Date as MySQL compatible String.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Imageslider.pm 0000644 0001750 0001750 00000006167 11455433374 024135 0 ustar thorsten thorsten package HTML::TurboForm::Element::Imageslider;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ del_link max dir noimgs / );
sub reset_js{
my ($self)=@_;
my $name=$self->name;
$self->{options}=[] if (!$self->{options});
my $nr_obj = scalar(@{ $self->{options} });
#$nr_obj=1 if (($nr_obj == 0) and ($self->{options}));
my $max = $self->max;
$max = $nr_obj if($nr_obj < $max);
if ($nr_obj > 1){
$self->{js} = '
$(function() {
$("#'.$name.'").jCarouselLite({
btnNext: "#next_'.$name.'",
btnPrev: "#prev_'.$name.'",
visible: '.$max.'
});
});
';
}
}
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $result='';
my $disabled='';
my $class='form_slider';
my $request=$self->request;
$self->label(' ') if ($self->label eq '');
$class=$self->{class} if exists($self->{class});
my $aha=$self->options;
my $name=$self->name;
my $nr_obj = scalar(@{ $self->{options} });
$disabled=' disabled ' if ($options->{frozen} == 1);
my $dir='';
$dir = $self->dir if ($self->dir);
if ($nr_obj>1){
$result='
<-
';
$result.='
->
'."\n";
#$result.='
'."\n";
$result.='
'."\n";
my $result2='';
foreach (@{$self->{options}}){
if (!$self->noimgs){
if ($self->del_link){
# $result2.='';
$result.='
'."\n";
}else{
$result.=''."\n";
}
};
if ($self->noimgs){ $result.='
'.$_.'
'."\n";}
}
$result.="
";
}
if ($nr_obj==1){
foreach (@{$self->{options}}){
$result.='
'."\n";
}
}
if ($nr_obj==0){ $result = '';}
$result= $self->vor($options).$result.$self->nach if ($self->check_param('norow')==0);
#$result= '' if ($self->{options});
return $result;
}
sub init{
my ($self)=@_;
@{$self->{modules}} = ('jquery/jquery','jquery/jcarousellite_1.0.1.min', 'jquery/easing');
$self->{max} = 3;
my $name=$self->name;
$self->reset_js();
}
sub get_dbix{
my ($self)=@_;
return 0;
}
1;
__END__
=head1 HTML::TurboForm::Element::Imageslider
Representation class for Imageslider element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for checkbox element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Textarea.pm 0000644 0001750 0001750 00000003076 11455433374 023461 0 ustar thorsten thorsten package HTML::TurboForm::Element::Textarea;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ id tinymce / );
sub init{
my ($self)=@_;
@{$self->{modules}} = ('tinymce/tiny_mce') if ($self->tinymce);
}
sub render {
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_textarea';
$class = $self->class if ($self->class);
my $id='';
$id = ' id="'.$self->id.'" ' if ($self->id);
$class = 'class="'.$class.'"';
my $name=' name="'.$self->name.'" ';
my $value=$request->{ $self->name };
if ($options->{frozen}) {
if ($options->{frozen} == 1) {
my $text= $value;
$disabled=' disabled ';
$result='';
}
}
my $tinytext='';
if ($self->tinymce){
$tinytext = '
';
}
$value='' if (!$value);
$result =$result.$tinytext.'' ;
return $self->vor($options).$result.$self->nach;
}
1;
__END__
=head1 HTML::TurboForm::Element::Textarea
Representation class for HTML Textarea input element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Range.pm 0000644 0001750 0001750 00000012164 11455433374 022736 0 ustar thorsten thorsten package HTML::TurboForm::Element::Range;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ min max round rangetext zerovalue dbtype steps start1 start2 modules / );
sub init{
my ($self)=@_;
my $step = 10;
if ($self->min) { $self->{min}=int($self->min); };
if ($self->max) { $self->{max}= int( $self->max ); };
if ($self->start1) { $self->{start1}=$self->start1; };
if ($self->start2) { $self->{start2}=$self->start2; };
$self->{value}='';
my $js_min='';
my $js_max='';
if($self->zerovalue){
$self->{start1}=$self->{min};
$self->{start2}=$self->{max};
$js_min ='if (value1 == '.$self->{min}.') $("#'.$self->name.'_label1").html("'.$self->zerovalue.'");';
$js_max ='if (value2 == '.$self->{max}.') $("#'.$self->name.'_label2").html("'.$self->zerovalue.'");';
}
if ($self->steps) { $step=$self->steps; } else { $step = $self->{max} - $self->{min}; };
if ($self->request->{ $self->name }) {
$self->{value} = $self->request->{ $self->name };
my @vals = split(/,/, $self->request->{ $self->name });
$self->{start1}= $vals[0];
$self->{start2}= $vals[1];
}
@{$self->{modules}} = ('jquery/jquery','jquery/ui.core.min','jquery/ui.slider.min');
$self->{js} = '
$("#'.$self->name.'_slider").slider({
"steps": '.$step.',range:true,
"min": '.$self->{min}.',
"max": '.$self->{max}.',
"slide": function(e, ui){
var value1 = $("#'.$self->name.'_slider").slider("value",0);
var value2 = $("#'.$self->name.'_slider").slider("value",1);
var field = value1+","+value2;
$("#'.$self->name.'_label1").html(value1.toFixed(0),0);
$("#'.$self->name.'_label2").html(value2.toFixed(0),1);
$("#'.$self->name.'").val(field);
'.$js_min.'
'.$js_max.'
}
}); ';
if ($self->{start2}){
$self->{js} .= '$("#'.$self->name.'_slider").slider("moveTo",'.$self->{start2}.',1);';
}
if ($self->{start1}){
$self->{js} .= '$("#'.$self->name.'_slider").slider("moveTo",'.$self->{start1}.',0);';
}
}
sub get_value{
my ($self)=@_;
return 0 if (($self->zerovalue) && ( $self->{value} == ($self->{min}-1)));
return 0 if (($self->zerovalue) && ( $self->{value} == ($self->{max}+1)));
return $self->{value};
}
sub freeze{
my ($self)=@_;
$self->{js} .= '$("#'.$self->name.'_slider").slider("disable");';
}
sub get_dbix{
my ($self)=@_;
my $dbname=$self->name if ($self->name);
$dbname =$self->dbsearchfield if ($self->dbsearchfield);
my @vals = split(/,/, $self->get_value());
my $low = $vals[0];
my $high = $vals[1];
my $result = 0;
if ($self->zerovalue) {
$low='' if ($low == $self->{min});
$high='' if ($high == $self->{max});
}
if($self->get_value() ne '') {
$result={};
if ($self->dbtype) {
$result->{'CAST('.$dbname.' AS '.$self->dbtype.')'}->{'>='}=[$low] if ($low ne '');
$result->{'CAST('.$dbname.' AS '.$self->dbtype.')'}->{'<='}=[$high] if ($high ne '');
} else {
$result->{$dbname}->{'>='}=$low if ($low ne '');
$result->{$dbname}->{'<='}=$high if ($high ne '');
}
}
return $result;
}
sub render {
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_text';
$class = $self->class if ($self->class);
my $name=$self->name;
my $minlabel = $self->{min};
my $maxlabel = $self->{max};
$minlabel = $self->zerovalue if ($self->zerovalue);
$maxlabel = $self->zerovalue if ($self->zerovalue);
#print STDERR $self->{min}." bis ".$self->{max}."\n";
#$self->{min} =~ s/^(.*?)\..*$/$1/ ;
#$self->{max} =~ s/^(.*?)\..*$/$1/ ;
my $rt='';
$rt = ' '.$self->{rangetext}.' ' if ($self->rangetext);
$result='
'.$minlabel.'
'.$rt.'
'.$maxlabel.'
';
return $self->vor($options).$result.$self->nach;
}
1;
__END__
=head1 HTML::TurboForm::Element::Range
Representation class for HTML SLider input element with two Sliders. This Element uses the jquery Javascript library !
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Radio.pm 0000644 0001750 0001750 00000010516 11455713641 022735 0 ustar thorsten thorsten package HTML::TurboForm::Element::Radio;
use warnings;
use strict;
use Tie::IxHash;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ class special listmode pre post position labelclass/);
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_radio';
if ($self->label) {
$self->label(' ') if ($self->label eq '');
} else {
$self->label(' ');
}
$class=$self->{class} if exists($self->{class});
$class=' class="'.$class.'" ';
my $aha=$self->options;
my $name=' name="'.$self->name.'" ';
my $checked='';
if ($options->{frozen}){ $disabled=' disabled ' if ($options->{frozen} == 1) ; }
my $pre='';
my $post='';
my $after='';
if ( $self->listmode ){
$result.='
';
$pre='
';
$post='
';
$after='
';
}
$pre.=$self->pre if ($self->pre);
$post.=$self->post if ($self->post);
my $norm_hash=1;
if ($self->options){
foreach (%{$self->options}){
$norm_hash=2 if (ref($_) eq 'HASH');
}
if ($norm_hash==2){
for my $k2 ( sort{ $a <=> $b} keys %{$self->options} ) {
while ( my( $key,$value) = each %{$self->options->{$k2}}){
my $values = $request->{ $self->name };
if (! $values){
$values = $self->default;
}
$values = [ $values ] unless ref( $values ) =~ /ARRAY/;
$checked='';
if ([ $values ]) { $checked=' checked="true" ' if ( grep { $_ eq $value } @{ $values } ); }
my $special='';
#$special='' if ($self->special==$k2);
$result.=$pre.''.$key.$special.$post;
$result.='' if (($disabled ne '')&& ( $checked ne ''));
}
}
} else {
while ( my( $key,$value) = each %{$self->options}){
# if (ref($value) eq 'HASH'){ print "wkfndfkhvbkh";}
my $values = $request->{ $self->name };
if (! $values){
$values = $self->default;
}
$values = [ $values ] unless ref( $values ) =~ /ARRAY/;
$checked='';
if ([ $values ]) { $checked=' checked ' if ( grep { $_ eq $value } @{ $values } ); }
$result.=$pre.''.$key.$post;
$result.='' if (($disabled ne '')&& ( $checked ne ''));
}
}
}
if ($self->optionsnum){
foreach (@{$self->optionsnum}){
while( my ($key, $value) = each %$_ ) {
my $values = $request->{ $self->name };
if (! $values){
$values = $self->default;
}
if($self->labelclass){
$key='
'.$key.'
';
}
my $keyr=$key;
my $keyl='';
if ($self->position){
if ($self->position eq 'left') {
$keyl=$key;
$keyr='';
}
}
$values = [ $values ] unless ref( $values ) =~ /ARRAY/;
$checked='';
if ([ $values ]) { $checked=' checked ' if ( grep { $_ eq $value if ($_) } @{ $values } ); }
$result.=$pre.$keyl.''.$keyr.$post;
$result.='' if (($disabled ne '')&& ( $checked ne ''));
}
}
}
$result.=$after;
$result= $self->vor($options).$result.$self->nach if ($self->check_param('norow')==0);
return $result;
}
1;
__END__
=head1 HTML::TurboForm::Element::Radio
Representation class for HTML Radiobox element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for Radiobox.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Captcha.pm 0000644 0001750 0001750 00000006572 11455433374 023253 0 ustar thorsten thorsten package HTML::TurboForm::Element::Captcha;
use warnings;
use strict;
use Crypt::Lite;
use base qw(HTML::TurboForm::Element);
__PACKAGE__->mk_accessors( qw/ session length keyname keyphrase/ );
sub render {
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_text';
$class = $self->class if ($self->class);
$self->length(4) if (!$self->length);
my $name=' name="'.$self->name.'_input" ';
my $value='';
$value=' value="'.$request->{ $self->name }.'" ' if ($request->{ $self->name });
if ($options->{frozen} == 1) {
my $text= $value;
$disabled=' disabled ';
$result='';
}
my @numbers = (0,1,2,3,4,5,6,7,8,9);
my $random = '';
for (my $i=0; $i < $self->length;$i++){
my $x = int(rand(scalar(@numbers)));
$random .= $x;
}
my $k='_captcha';
$k=$self->keyname if ($self->keyname);
$result=$self->print_number($random);
my $crypt = Crypt::Lite->new( debug => 0, encoding => 'hex8' );
if ($self->keyphrase){
$random=$crypt->encrypt($random,$self->keyphrase);
}
my $tstamp=time();
$tstamp=$crypt->encrypt($tstamp,$self->keyphrase);
if ($self->session && $self->name){
$self->session->{ $self->name.$k}=$random;
$self->session->{ $self->name.$k.'2'}=$tstamp;
}
$self->{value}=$random;
# $result .='' ;
return $self->vor($options).$result.$self->nach;
}
sub get_value{
my ($self)=@_;
my $k='_captcha';
$k=$self->keyname if ($self->keyname);
my $val=$self->session->{ $self->name.$k };
if ($self->keyphrase){
my $crypt = Crypt::Lite->new( debug => 0, encoding => 'hex8' );
$val=$crypt->decrypt($val,$self->keyphrase);
}
return $val;
}
sub get_digit_matrix{
my ($self, $number)=@_;
my @bitmasks = (31599, 18742, 29607, 31143, 18921, 31183, 31695, 18855, 31727, 31215);
my @bits = (1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384);
my @matrix=(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
my $mask = $bitmasks[$number];
for (my $i=14;$i>0;$i--){
if (($mask / $bits[$i])>1) {
$mask = $mask - $bits[$i];
$matrix[$i]=1;
}
}
if ($mask == 1) { $matrix[0]=1; }
return @matrix ;
}
sub print_matrix{
my ($self, @matrix)=@_;
my $output ='';
my $size = @matrix;
for (my $i=0;$i<5;$i++) {
for (my $k=0;$k < $size ;$k++){
for (my $j=0;$j<3;$j++) {
if ( $matrix[$k][($j+(3*$i))] == 1 ){
$output.='';
} else {
$output.='';
}
}
$output.='';
}
$output.=' ';
}
return $output;
}
sub print_number{
my ($self, $number)=@_;
my @matrix;
for(my $i=0; $iget_digit_matrix($digit) ];
}
return $self->print_matrix(@matrix);
}
1;
__END__
=head1 HTML::TurboForm::Element::Captcha
Representation class for Captcha element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Image.pm 0000644 0001750 0001750 00000014233 11455433374 022723 0 ustar thorsten thorsten package HTML::TurboForm::Element::Image;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
use Imager;
__PACKAGE__->mk_accessors( qw/ prev upload keeporiginal width height savedir thumbnail loadurl caption maxsize errormessage / );
sub new{
my ($class, $request, $upload) = @_;
my $self = $class->SUPER::new( $request );
$self->upload( $upload );
$self->do_img();
return $self;
}
sub do_img{
my ($self)=@_;
my $request=$self->request;
my $pic='';
$pic = $self->request->{$self->name} if ($self->request->{$self->name} );
if ($request->{ $self->name.'_upload' } && $request->{$self->name.'_submit'} ) {
if( $self->upload->type !~ /^image\/(jpeg|jpg|gif|png|pjpeg)$/ ) {
#$c->stash->{ 'error' } = 'Filetype not supported!';
} else {
# read image
my $image = Imager->new;
$self->{sizeerror}=0;
if ($self->maxsize) {
if (($self->upload->size/1024) > $self->maxsize){
$self->{sizeerror}=1;
}
}
if (!$self->{sizeerror}){
if( $image->read( file => $self->upload->tempname ) ) {
# remove alpha channels because jpg does not support it # and its not used anyways
$image = $image->convert( preset => 'noalpha' );
#attribute keeporignal isparams local path for storing orig sized images
my $tmp = File::Temp->new( DIR => $self->savedir.'', UNLINK => 0, SUFFIX => '.jpg' );
$pic = substr( $tmp, length( $self->savedir )+1 );
$self->{pic}=$pic;
if ($self->keeporiginal){
$self->upload->copy_to($self->keeporiginal.'/orig_'.$pic);
}
# if there is a save dir, resize. depending if width and/or height is given, scale to dimensions
if ($self->savedir){
if (($self->width) and ($self->height)) {
# No scale. Resize to given dimensions
$image = $image->scaleX(pixels=>$self->width)->scaleY(pixels=>$self->height);
} elsif ($self->width) {
# Resize width, scale height
$image = $image->scale(xpixels=>$self->width);
} elsif ($self->height) {
# Resize height, scale width
$image = $image->scale(ypixels=>$self->height);
}
$image->write(
file => $self->savedir.'/med_'.$pic,
type => 'jpeg',
jpegquality => 90
);
if ($self->thumbnail) {
if ($self->thumbnail->{width} || $self->thumbnail->{height} ) {
if (($self->thumbnail->{width}) and ($self->thumbnail->{height})) {
# No scale. Resize to given dimensions
$image = $image->scaleX(pixels=>$self->thumbnail->{width})->scaleY(pixels=>$self->thumbnail->{height});
} elsif ($self->thumbnail->{width}) {
# Resize width, scale height
$image = $image->scale(xpixels=>$self->thumbnail->{width});
} elsif ($self->thumbnail->{height}) {
# Resize height, scale width
$image = $image->scale(ypixels=>$self->thumbnail->{height});
}
my $thmb_fn = $self->savedir.'/thumb_'.$pic;
$thmb_fn = $self->thumbnail->{savedir}.'/thumb_'.$pic if ($self->thumbnail->{savedir});
$image->write(
file => $thmb_fn,
type => 'jpeg',
jpegquality => 90
);
}
}
unlink($self->savedir.'/'.$pic);
}
}
}
}
}#end of if upload and submit
}
sub get_value{
my ($self) = @_;
my $result='';
my $request=$self->request;
$result=$self->{pic};
if (!$self->{pic}){
$result=$request->{$self->name} if ($request->{$self->name});
}
return $result;
}
sub render{
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_image_select';
$self->label(' ') if ($self->label eq '');
$class=$self->{class} if exists($self->{class});
my $name=' name="'.$self->name.'_upload" ';
my $checked='';
my $pic='';
$pic= $self->{pic} if ($self->{pic});
$pic=$request->{$self->name} if ($request->{$self->name});
$disabled=' disabled ' if ($options->{frozen} == 1);
if ($options->{frozen} != 1 ){
$result.= $self->errormessage if ($self->{sizeerror} && $self->errormessage);
$result.='get_attr().$disabled.$name.'>';
$result.='';
}
$result.='';
if ($pic ne ''){
$result.="
";
$result.="" if (($self->thumbnail) && ($self->prev));
}
return $self->vor($options).$result.$self->nach;
}
1;
__END__
=head1 HTML::TurboForm::Element::Image
Representation class for HTMl SelectBox element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for select element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Element/Password.pm 0000644 0001750 0001750 00000003111 11455433374 023474 0 ustar thorsten thorsten package HTML::TurboForm::Element::Password;
use warnings;
use strict;
use base qw(HTML::TurboForm::Element);
use Digest::SHA1 qw(sha1 sha1_hex);
sub render {
my ($self, $options, $view)=@_;
if ($view) { $self->{view}=$view; }
my $id='';
$id=' id="'.$self->id.'" ' if ($self->id);
my $request=$self->request;
my $result='';
my $disabled='';
my $class='form_text';
$class = $self->class if ($self->class);
$class = 'class="'.$class.'"';
my $name=' name="'.$self->name.'" ';
my $value='';
$value=' value="'.$request->{ $self->name }.'" ' if ($request->{ $self->name });
if ($options->{frozen}) {
if ($options->{frozen} eq 1) {
my $text= $value;
$disabled=' disabled ';
# $result='';
}
}
my $limit='';
$limit=' maxlength="'.$self->limit.'"' if ($self->limit);
$result .='' ;
return $self->vor($options).$result.$self->nach;
}
sub get_value{
my ($self) = @_;
my $result='';
$result=$self->{request}->{$self->name} if exists($self->{request}->{$self->name});
return sha1_hex($result) if ($result);
return '' if (!$result);
}
1;
__END__
=head1 HTML::TurboForm::Element::Password
Representation class for HTML Password input element.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 render
Arguments: $options
returns HTML Code for element.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/.project 0000644 0001750 0001750 00000000556 11455433374 021424 0 ustar thorsten thorsten
formclassorg.epic.perleditor.perlbuilderorg.epic.perleditor.perlnature
HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/ 0000755 0001750 0001750 00000000000 11473014547 022070 5 ustar thorsten thorsten HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Email.pm 0000644 0001750 0001750 00000001433 11455433374 023461 0 ustar thorsten thorsten package HTML::TurboForm::Constraint::Email;
use warnings;
use strict;
use Email::Valid;
use base qw(HTML::TurboForm::Constraint);
sub check{
my ($self)=@_;
my $request=$self->request;
return 1 if Email::Valid->address( -address => $request->{$self->name} );
return 0;
}
sub message{
my ($self)=@_;
return $self->{text};
}
1;
__END__
=head1 HTML::TurboForm::Constraint::Email
Representation class for Email constraint.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 check
Arguments: none
returns 1 if valid, otherwise 0.
=head2 message
Arguments: none
returns Errormessage of Element which is connected to constraint.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Required.pm 0000644 0001750 0001750 00000001664 11455433374 024220 0 ustar thorsten thorsten package HTML::TurboForm::Constraint::Required;
use warnings;
use strict;
use base qw(HTML::TurboForm::Constraint);
__PACKAGE__->mk_accessors( qw/ emptyval / );
sub check{
my ($self)=@_;
my $request=$self->request;
my $result=0;
my $empty = '';
$empty=$self->emptyval if ($self->emptyval);
if (exists($request->{$self->{name}})) {
$result=1 if ($request->{$self->{name}} ne $empty );
}
return $result;
}
sub message{
my ($self)=@_;
return $self->{text};
}
1;
__END__
=head1 HTML::TurboForm::Constraint::Required
Representation class for Required constraint.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 check
Arguments: none
returns 1 if valid, otherwise 0.
=head2 message
Arguments: none
returns Errormessage of Element which is connected to constraint.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Length.pm 0000644 0001750 0001750 00000001444 11455433374 023655 0 ustar thorsten thorsten package HTML::TurboForm::Constraint::Length;
use warnings;
use strict;
use base qw(HTML::TurboForm::Constraint);
__PACKAGE__->mk_accessors( qw/ maxlength / );
sub check{
my ($self)=@_;
my $result=0;
my $request=$self->request;
my $max = $self->maxlength;
if ($max){
my $value=$request->{$self->{name}};
return 1 if( length($value) <= $max );
}
return 0;
}
sub message{
my ($self)=@_;
return $self->{text};
}
1;
__END__
=head1 HTML::TurboForm::Constraint::Length
Representation class for Length constraint.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 check
Arguments: none
returns 1 if valid, otherwise 0.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Equation.pm 0000644 0001750 0001750 00000002523 11455433374 024220 0 ustar thorsten thorsten package HTML::TurboForm::Constraint::Equation;
use warnings;
use strict;
use base qw(HTML::TurboForm::Constraint);
__PACKAGE__->mk_accessors( qw/ operator comp / );
sub check{
my ($self)=@_;
my $result=0;
my $request=$self->request;
my $op='';
my $comp_val;
my $val=$request->{ $self->name };
$op= $self->operator;
$comp_val = $self->comp ;
if (($op eq "eq") or ($op eq "ne")) {
if (($val)&&($comp_val)){
$val="'$val'";
$comp_val="'$comp_val'";
}
}
if ($val and $op and $comp_val ){
my $equation=$val." ".$op." ".$comp_val ;
return 1 if( eval($equation) );
}
return 0;
}
sub message{
my ($self)=@_;
return $self->text;
}
1;
__END__
=head1 HTML::TurboForm::Constraint::Equation
Representation class for Equation constraint.
=head1 DESCRIPTION
The equation constraint is supposed to be used whenever two values are to be compared.
You have to give it the perl operator (ne, eq, <,>, whatever) and the two values to be compared via the params hash.
Straight forward so no need for much documentation. See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 check
Arguments: none
returns 1 if valid, otherwise 0.
=head2 message
Arguments: none
returns Errormessage of Element which is connected to constraint.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Date.pm 0000644 0001750 0001750 00000001770 11455433374 023313 0 ustar thorsten thorsten package HTML::TurboForm::Constraint::Date;
use warnings;
use strict;
use Date::Calc qw/check_date/;
use base qw(HTML::TurboForm::Constraint);
sub check{
my ($self)=@_;
my $result=0;
my $day='';
my $month='';
my $year='';
my $request=$self->request;
$day=$request->{$self->{name}.'_day'};# if (exists($request->{$self->{name}.'_day'}));
$month=$request->{$self->{name}.'_month'};# if (exists($request->{$self->{name}.'_month'}));
$year=$request->{$self->{name}.'_year'};# if (exists($request->{$self->{name}.'year'})) ;
return 1 if( check_date( $year,$month,$day ) );
return 0;
}
sub message{
my ($self)=@_;
return $self->{text};
}
1;
__END__
=head1 HTML::TurboForm::Constraint::Date
Representation class for Date constraint.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 check
Arguments: none
returns 1 if valid, otherwise 0.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Mintime.pm 0000644 0001750 0001750 00000002266 11455433374 024041 0 ustar thorsten thorsten package HTML::TurboForm::Constraint::Mintime;
use warnings;
use strict;
use base qw(HTML::TurboForm::Constraint);
use Crypt::Lite;
__PACKAGE__->mk_accessors( qw/ mintime session keyphrase keyname / );
sub check{
my ($self)=@_;
my $request=$self->request;
my $result=0;
my $mintime = 5;
$mintime=$self->mintime if ($self->mintime);
my $time=time();
my $id=$self->name;
$id=$self->name.$self->keyname if ($self->keyname);
my $t=$self->session->{$id};
my $crypt = Crypt::Lite->new( debug => 0, encoding => 'hex8' );
if ($self->keyphrase) {
$t=$crypt->decrypt($t,$self->keyphrase);
}
$result=1 if (($time-$mintime) > $t);
return $result;
}
sub message{
my ($self)=@_;
return $self->{text};
}
1;
__END__
=head1 HTML::TurboForm::Constraint::Required
Representation class for Required constraint.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 check
Arguments: none
returns 1 if valid, otherwise 0.
=head2 message
Arguments: none
returns Errormessage of Element which is connected to constraint.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut
HTML-TurboForm-0.634/lib/HTML/TurboForm/Constraint/Regex.pm 0000644 0001750 0001750 00000001451 11455433374 023504 0 ustar thorsten thorsten package HTML::TurboForm::Constraint::Regex;
use warnings;
use strict;
use base qw(HTML::TurboForm::Constraint);
__PACKAGE__->mk_accessors( qw/ regex / );
sub check{
my ($self)=@_;
my $result=0;
my $request=$self->request;
my $regex = $self->regex;
my $value=$request->{$self->{name}};
return 1 if (!$value);
if ($regex){ return 1 if( $value =~ qr/$regex/ ); }
return 0;
}
sub message{
my ($self)=@_;
return $self->{text};
}
1;
__END__
=head1 HTML::TurboForm::Constraint::Regex
Representation class for Regex constraint.
=head1 DESCRIPTION
Straight forward so no need for much documentation.
See HTML::TurboForm doku for mopre details.
=head1 METHODS
=head2 check
Arguments: none
returns 1 if valid, otherwise 0.
=head1 AUTHOR
Thorsten Domsch, tdomsch@gmx.de
=cut HTML-TurboForm-0.634/lib/HTML/.project 0000644 0001750 0001750 00000000556 11455433374 017505 0 ustar thorsten thorsten
formclassorg.epic.perleditor.perlbuilderorg.epic.perleditor.perlnature
HTML-TurboForm-0.634/lib/.project 0000644 0001750 0001750 00000000560 11455433374 016734 0 ustar thorsten thorsten
html formfuorg.epic.perleditor.perlbuilderorg.epic.perleditor.perlnature
HTML-TurboForm-0.634/inc/ 0000755 0001750 0001750 00000000000 11473014547 015264 5 ustar thorsten thorsten HTML-TurboForm-0.634/inc/Module/ 0000755 0001750 0001750 00000000000 11473014547 016511 5 ustar thorsten thorsten HTML-TurboForm-0.634/inc/Module/AutoInstall.pm 0000644 0001750 0001750 00000053306 11455433374 021320 0 ustar thorsten thorsten #line 1
package Module::AutoInstall;
use strict;
use Cwd ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.03';
}
# special map on pre-defined feature sets
my %FeatureMap = (
'' => 'Core Features', # XXX: deprecated
'-core' => 'Core Features',
);
# various lexical flags
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
my (
$Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
);
my ( $PostambleActions, $PostambleUsed );
# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
_init();
sub _accept_default {
$AcceptDefault = shift;
}
sub missing_modules {
return @Missing;
}
sub do_install {
__PACKAGE__->install(
[
$Config
? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
: ()
],
@Missing,
);
}
# initialize various flags, and/or perform install
sub _init {
foreach my $arg (
@ARGV,
split(
/[\s\t]+/,
$ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
)
)
{
if ( $arg =~ /^--config=(.*)$/ ) {
$Config = [ split( ',', $1 ) ];
}
elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
exit 0;
}
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
$AcceptDefault = 1;
}
elsif ( $arg =~ /^--check(?:deps)?$/ ) {
$CheckOnly = 1;
}
elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
$SkipInstall = 1;
}
elsif ( $arg =~ /^--test(?:only)?$/ ) {
$TestOnly = 1;
}
elsif ( $arg =~ /^--all(?:deps)?$/ ) {
$AllDeps = 1;
}
}
}
# overrides MakeMaker's prompt() to automatically accept the default choice
sub _prompt {
goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
my ( $prompt, $default ) = @_;
my $y = ( $default =~ /^[Yy]/ );
print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
print "$default\n";
return $default;
}
# the workhorse
sub import {
my $class = shift;
my @args = @_ or return;
my $core_all;
print "*** $class version " . $class->VERSION . "\n";
print "*** Checking for Perl dependencies...\n";
my $cwd = Cwd::cwd();
$Config = [];
my $maxlen = length(
(
sort { length($b) <=> length($a) }
grep { /^[^\-]/ }
map {
ref($_)
? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
: ''
}
map { +{@args}->{$_} }
grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
)[0]
);
# We want to know if we're under CPAN early to avoid prompting, but
# if we aren't going to try and install anything anyway then skip the
# check entirely since we don't want to have to load (and configure)
# an old CPAN just for a cosmetic message
$UnderCPAN = _check_lock(1) unless $SkipInstall;
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
my $default = 1;
my $conflict = 0;
if ( $feature =~ m/^-(\w+)$/ ) {
my $option = lc($1);
# check for a newer version of myself
_update_to( $modules, @_ ) and return if $option eq 'version';
# sets CPAN configuration options
$Config = $modules if $option eq 'config';
# promote every features to core status
$core_all = ( $modules =~ /^all$/i ) and next
if $option eq 'core';
next unless $option eq 'core';
}
print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
$modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
unshift @$modules, -default => &{ shift(@$modules) }
if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
if ( $mod =~ m/^-(\w+)$/ ) {
my $option = lc($1);
$default = $arg if ( $option eq 'default' );
$conflict = $arg if ( $option eq 'conflict' );
@tests = @{$arg} if ( $option eq 'tests' );
@skiptests = @{$arg} if ( $option eq 'skiptests' );
next;
}
printf( "- %-${maxlen}s ...", $mod );
if ( $arg and $arg =~ /^\D/ ) {
unshift @$modules, $arg;
$arg = 0;
}
# XXX: check for conflicts and uninstalls(!) them.
my $cur = _load($mod);
if (_version_cmp ($cur, $arg) >= 0)
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
push @Existing, $mod => $arg;
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
if (not defined $cur) # indeed missing
{
print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
}
else
{
# no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
print "too old. ($cur < $arg)\n";
}
push @required, $mod => $arg;
}
}
next unless @required;
my $mandatory = ( $feature eq '-core' or $core_all );
if (
!$SkipInstall
and (
$CheckOnly
or ($mandatory and $UnderCPAN)
or $AllDeps
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
. ( $mandatory ? ' mandatory' : ' optional' )
. qq{ module(s) from CPAN?},
$default ? 'y' : 'n',
) =~ /^[Yy]/
)
)
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
elsif ( !$SkipInstall
and $default
and $mandatory
and
_prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
=~ /^[Nn]/ )
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
$DisabledTests{$_} = 1 for map { glob($_) } @tests;
}
}
if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
require Config;
print
"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
# make an educated guess of whether we'll need root permission.
print " (You may need to do that as the 'root' user.)\n"
if eval '$>';
}
print "*** $class configuration finished.\n";
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
sub _running_under {
my $thing = shift;
print <<"END_MESSAGE";
*** Since we're running under ${thing}, I'll just let it take care
of the dependency's installation later.
END_MESSAGE
return 1;
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
return unless @Missing or @_;
my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
}
require CPAN;
if ($CPAN::VERSION > '1.89') {
if ($cpan_env) {
return _running_under('CPAN');
}
return; # CPAN.pm new enough, don't need to check further
}
# last ditch attempt, this -will- configure CPAN, very sorry
_load_cpan(1); # force initialize even though it's already loaded
# Find the CPAN lock-file
my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
return unless -f $lock;
# Check the lock
local *LOCK;
return unless open(LOCK, $lock);
if (
( $^O eq 'MSWin32' ? _under_cpan() : == getppid() )
and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
) {
print <<'END_MESSAGE';
*** Since we're running under CPAN, I'll just let it take care
of the dependency's installation later.
END_MESSAGE
return 1;
}
close LOCK;
return;
}
sub install {
my $class = shift;
my $i; # used below to strip leading '-' from config keys
my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
my ( @modules, @installed );
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
else {
push @modules, $pkg, $ver;
}
}
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
print "*** Installing dependencies...\n";
return unless _connected_to('cpan.org');
my %args = @config;
my %failed;
local *FAILED;
if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
while () { chomp; $failed{$_}++ }
close FAILED;
my @newmod;
while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
push @newmod, ( $k => $v ) unless $failed{$k};
}
@modules = @newmod;
}
if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) {
_install_cpanplus( \@modules, \@config );
} else {
_install_cpan( \@modules, \@config );
}
print "*** $class installation finished.\n";
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
print FAILED "$pkg\n";
}
}
close FAILED if $args{do_once};
return @installed;
}
sub _install_cpanplus {
my @modules = @{ +shift };
my @config = _cpanplus_config( @{ +shift } );
my $installed = 0;
require CPANPLUS::Backend;
my $cp = CPANPLUS::Backend->new;
my $conf = $cp->configure_object;
return unless $conf->can('conf') # 0.05x+ with "sudo" support
or _can_write($conf->_get_build('base')); # 0.04x
# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
my $makeflags = $conf->get_conf('makeflags') || '';
if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
# 0.03+ uses a hashref here
$makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
} else {
# 0.02 and below uses a scalar
$makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
}
$conf->set_conf( makeflags => $makeflags );
$conf->set_conf( prereqs => 1 );
while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
$conf->set_conf( $key, $val );
}
my $modtree = $cp->module_tree;
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
print "*** Installing $pkg...\n";
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
my $success;
my $obj = $modtree->{$pkg};
if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
delete $INC{$inc};
}
my $rv = $cp->install( modules => [ $obj->{module} ] );
if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
print "*** $pkg successfully installed.\n";
$success = 1;
} else {
print "*** $pkg installation cancelled.\n";
$success = 0;
}
$installed += $success;
} else {
print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
}
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
}
return $installed;
}
sub _cpanplus_config {
my @config = ();
while ( @_ ) {
my ($key, $value) = (shift(), shift());
if ( $key eq 'prerequisites_policy' ) {
if ( $value eq 'follow' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
} elsif ( $value eq 'ask' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_ASK();
} elsif ( $value eq 'ignore' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
} else {
die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
}
} else {
die "*** Cannot convert option $key to CPANPLUS version.\n";
}
}
return @config;
}
sub _install_cpan {
my @modules = @{ +shift };
my @config = @{ +shift };
my $installed = 0;
my %args;
_load_cpan();
require Config;
if (CPAN->VERSION < 1.80) {
# no "sudo" support, probe for writableness
return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
and _can_write( $Config::Config{sitelib} );
}
# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
my $makeflags = $CPAN::Config->{make_install_arg} || '';
$CPAN::Config->{make_install_arg} =
join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
# don't show start-up info
$CPAN::Config->{inhibit_startup_message} = 1;
# set additional options
while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
( $args{$opt} = $arg, next )
if $opt =~ /^force$/; # pseudo-option
$CPAN::Config->{$opt} = $arg;
}
local $CPAN::Config->{prerequisites_policy} = 'follow';
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
print "*** Installing $pkg...\n";
my $obj = CPAN::Shell->expand( Module => $pkg );
my $success = 0;
if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
delete $INC{$inc};
}
my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
: CPAN::Shell->install($pkg);
$rv ||= eval {
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
->{install}
if $CPAN::META;
};
if ( $rv eq 'YES' ) {
print "*** $pkg successfully installed.\n";
$success = 1;
}
else {
print "*** $pkg installation failed.\n";
$success = 0;
}
$installed += $success;
}
else {
print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
}
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
}
return $installed;
}
sub _has_cpanplus {
return (
$HasCPANPLUS = (
$INC{'CPANPLUS/Config.pm'}
or _load('CPANPLUS::Shell::Default')
)
);
}
# make guesses on whether we're under the CPAN installation directory
sub _under_cpan {
require Cwd;
require File::Spec;
my $cwd = File::Spec->canonpath( Cwd::cwd() );
my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
return ( index( $cwd, $cpan ) > -1 );
}
sub _update_to {
my $class = __PACKAGE__;
my $ver = shift;
return
if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
'y' ) =~ /^[Nn]/
)
{
die "*** Please install $class $ver manually.\n";
}
print << ".";
*** Trying to fetch it from CPAN...
.
# install ourselves
_load($class) and return $class->import(@_)
if $class->install( [], $class, $ver );
print << '.'; exit 1;
*** Cannot bootstrap myself. :-( Installation terminated.
.
}
# check if we're connected to some host, using inet_aton
sub _connected_to {
my $site = shift;
return (
( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
qq(
*** Your host cannot resolve the domain name '$site', which
probably means the Internet connections are unavailable.
==> Should we try to install the required module(s) anyway?), 'n'
) =~ /^[Yy]/
);
}
# check if a directory is writable; may create it on demand
sub _can_write {
my $path = shift;
mkdir( $path, 0755 ) unless -e $path;
return 1 if -w $path;
print << ".";
*** You are not allowed to write to the directory '$path';
the installation may fail due to insufficient permissions.
.
if (
eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
qq(
==> Should we try to re-execute the autoinstall process with 'sudo'?),
((-t STDIN) ? 'y' : 'n')
) =~ /^[Yy]/
)
{
# try to bootstrap ourselves from sudo
print << ".";
*** Trying to re-execute the autoinstall process with 'sudo'...
.
my $missing = join( ',', @Missing );
my $config = join( ',',
UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
return
unless system( 'sudo', $^X, $0, "--config=$config",
"--installdeps=$missing" );
print << ".";
*** The 'sudo' command exited with error! Resuming...
.
}
return _prompt(
qq(
==> Should we try to install the required module(s) anyway?), 'n'
) =~ /^[Yy]/;
}
# load a module and return the version it reports
sub _load {
my $mod = pop; # class/instance doesn't matter
my $file = $mod;
$file =~ s|::|/|g;
$file .= '.pm';
local $@;
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
}
# Load CPAN.pm and it's configuration
sub _load_cpan {
return if $CPAN::VERSION and $CPAN::Config and not @_;
require CPAN;
if ( $CPAN::HandleConfig::VERSION ) {
# Newer versions of CPAN have a HandleConfig module
CPAN::HandleConfig->load;
} else {
# Older versions had the load method in Config directly
CPAN::Config->load;
}
}
# compare two versions, either use Sort::Versions or plain comparison
# return values same as <=>
sub _version_cmp {
my ( $cur, $min ) = @_;
return -1 unless defined $cur; # if 0 keep comparing
return 1 unless $min;
$cur =~ s/\s+$//;
# check for version numbers that are not in decimal format
if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
if ( ( $version::VERSION or defined( _load('version') )) and
version->can('new')
) {
# use version.pm if it is installed.
return version->new($cur) <=> version->new($min);
}
elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
{
# use Sort::Versions as the sorting algorithm for a.b.c versions
return Sort::Versions::versioncmp( $cur, $min );
}
warn "Cannot reliably compare non-decimal formatted versions.\n"
. "Please install version.pm or Sort::Versions.\n";
}
# plain comparison
local $^W = 0; # shuts off 'not numeric' bugs
return $cur <=> $min;
}
# nothing; this usage is deprecated.
sub main::PREREQ_PM { return {}; }
sub _make_args {
my %args = @_;
$args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
if $UnderCPAN or $TestOnly;
if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
require ExtUtils::Manifest;
my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
$args{EXE_FILES} =
[ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
}
$args{test}{TESTS} ||= 't/*.t';
$args{test}{TESTS} = join( ' ',
grep { !exists( $DisabledTests{$_} ) }
map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
my $missing = join( ',', @Missing );
my $config =
join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
$PostambleActions = (
($missing and not $UnderCPAN)
? "\$(PERL) $0 --config=$config --installdeps=$missing"
: "\$(NOECHO) \$(NOOP)"
);
return %args;
}
# a wrapper to ExtUtils::MakeMaker::WriteMakefile
sub Write {
require Carp;
Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
if ($CheckOnly) {
print << ".";
*** Makefile not written in check-only mode.
.
return;
}
my %args = _make_args(@_);
no strict 'refs';
$PostambleUsed = 0;
local *MY::postamble = \&postamble unless defined &MY::postamble;
ExtUtils::MakeMaker::WriteMakefile(%args);
print << "." unless $PostambleUsed;
*** WARNING: Makefile written with customized MY::postamble() without
including contents from Module::AutoInstall::postamble() --
auto installation features disabled. Please contact the author.
.
return 1;
}
sub postamble {
$PostambleUsed = 1;
return <<"END_MAKE";
config :: installdeps
\t\$(NOECHO) \$(NOOP)
checkdeps ::
\t\$(PERL) $0 --checkdeps
installdeps ::
\t$PostambleActions
END_MAKE
}
1;
__END__
#line 1056
HTML-TurboForm-0.634/inc/Module/Install/ 0000755 0001750 0001750 00000000000 11473014547 020117 5 ustar thorsten thorsten HTML-TurboForm-0.634/inc/Module/Install/Fetch.pm 0000644 0001750 0001750 00000004627 11455433374 021522 0 ustar thorsten thorsten #line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
HTML-TurboForm-0.634/inc/Module/Install/Win32.pm 0000644 0001750 0001750 00000003403 11455433374 021362 0 ustar thorsten thorsten #line 1
package Module::Install::Win32;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
);
print "The required 'nmake' executable not found, fetching it...\n";
require File::Basename;
my $rv = $self->get_file(
url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
local_dir => File::Basename::dirname($^X),
size => 51928,
run => 'Nmake15.exe /o > nul',
check_for => 'Nmake.exe',
remove => 1,
);
die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
Since you are using Microsoft Windows, you will need the 'nmake' utility
before installation. It's available at:
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
or
ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
Please download the file manually, save it to a directory in %PATH% (e.g.
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
that directory, and run "Nmake15.exe" from there; that will create the
'nmake.exe' file needed by this module.
You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
}
1;
HTML-TurboForm-0.634/inc/Module/Install/Can.pm 0000644 0001750 0001750 00000003333 11455433374 021163 0 ustar thorsten thorsten #line 1
package Module::Install::Can;
use strict;
use Config ();
use File::Spec ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
my $abs = File::Spec->catfile($dir, $_[1]);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# can we locate a (the) C compiler
sub can_cc {
my $self = shift;
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
}
return;
}
# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
require ExtUtils::MM_Cygwin;
require ExtUtils::MM_Win32;
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
*ExtUtils::MM_Cygwin::maybe_command = sub {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
ExtUtils::MM_Win32->maybe_command($file);
} else {
ExtUtils::MM_Unix->maybe_command($file);
}
}
}
}
1;
__END__
#line 156
HTML-TurboForm-0.634/inc/Module/Install/AutoInstall.pm 0000644 0001750 0001750 00000002273 11455433374 022723 0 ustar thorsten thorsten #line 1
package Module::Install::AutoInstall;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub AutoInstall { $_[0] }
sub run {
my $self = shift;
$self->auto_install_now(@_);
}
sub write {
my $self = shift;
$self->auto_install(@_);
}
sub auto_install {
my $self = shift;
return if $self->{done}++;
# Flatten array of arrays into a single array
my @core = map @$_, map @$_, grep ref,
$self->build_requires, $self->requires;
my @config = @_;
# We'll need Module::AutoInstall
$self->include('Module::AutoInstall');
require Module::AutoInstall;
Module::AutoInstall->import(
(@config ? (-config => \@config) : ()),
(@core ? (-core => \@core) : ()),
$self->features,
);
$self->makemaker_args( Module::AutoInstall::_make_args() );
my $class = ref($self);
$self->postamble(
"# --- $class section:\n" .
Module::AutoInstall::postamble()
);
}
sub auto_install_now {
my $self = shift;
$self->auto_install(@_);
Module::AutoInstall::do_install();
}
1;
HTML-TurboForm-0.634/inc/Module/Install/Base.pm 0000644 0001750 0001750 00000001766 11455433374 021344 0 ustar thorsten thorsten #line 1
package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
$VERSION = '0.91';
}
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
#line 42
sub new {
my $class = shift;
unless ( defined &{"${class}::call"} ) {
*{"${class}::call"} = sub { shift->_top->call(@_) };
}
unless ( defined &{"${class}::load"} ) {
*{"${class}::load"} = sub { shift->_top->load(@_) };
}
bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
local $@;
my $func = eval { shift->_top->autoload } or return;
goto &$func;
}
#line 75
sub _top {
$_[0]->{_top};
}
#line 90
sub admin {
$_[0]->_top->{admin}
or
Module::Install::Base::FakeAdmin->new;
}
#line 106
sub is_admin {
$_[0]->admin->VERSION;
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
my $fake;
sub new {
$fake ||= bless(\@_, $_[0]);
}
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 154
HTML-TurboForm-0.634/inc/Module/Install/Makefile.pm 0000644 0001750 0001750 00000016003 11455433374 022175 0 ustar thorsten thorsten #line 1
package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing, always use defaults
if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
sub makemaker_args {
my $self = shift;
my $args = ( $self->{makemaker_args} ||= {} );
%$args = ( %$args, @_ );
return $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
my $self = sShift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
? join( ' ', $args->{name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
my %test_dir = ();
sub _wanted_t {
/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
if ( $self->tests ) {
die "tests_recursive will not work if tests are already defined";
}
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
# Make sure we have a new enough MakeMaker
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
# MakeMaker can complain about module versions that include
# an underscore, even though its own version may contain one!
# Hence the funny regexp to get rid of it. See RT #35800
# for details.
$self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
$args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
$args->{NO_META} = 1;
}
if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
# Merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ }
map { @$_ }
grep $_,
($self->configure_requires, $self->build_requires, $self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
# merge both kinds of requires into prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
delete $prereq->{$file};
}
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
$args->{INSTALLDIRS} = $self->installdirs;
my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
my $makefile = do { local $/; };
close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
#line 394
HTML-TurboForm-0.634/inc/Module/Install/Include.pm 0000644 0001750 0001750 00000001015 11455433374 022040 0 ustar thorsten thorsten #line 1
package Module::Install::Include;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub include {
shift()->admin->include(@_);
}
sub include_deps {
shift()->admin->include_deps(@_);
}
sub auto_include {
shift()->admin->auto_include(@_);
}
sub auto_include_deps {
shift()->admin->auto_include_deps(@_);
}
sub auto_include_dependent_dists {
shift()->admin->auto_include_dependent_dists(@_);
}
1;
HTML-TurboForm-0.634/inc/Module/Install/WriteAll.pm 0000644 0001750 0001750 00000002222 11455433374 022201 0 ustar thorsten thorsten #line 1
package Module::Install::WriteAll;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
sub WriteAll {
my $self = shift;
my %args = (
meta => 1,
sign => 0,
inline => 0,
check_nmake => 1,
@_,
);
$self->sign(1) if $args{sign};
$self->admin->WriteAll(%args) if $self->is_admin;
$self->check_nmake if $args{check_nmake};
unless ( $self->makemaker_args->{PL_FILES} ) {
$self->makemaker_args( PL_FILES => {} );
}
# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
# we clean it up properly ourself.
$self->realclean_files('MYMETA.yml');
if ( $args{inline} ) {
$self->Inline->write;
} else {
$self->Makefile->write;
}
# The Makefile write process adds a couple of dependencies,
# so write the META.yml files after the Makefile.
if ( $args{meta} ) {
$self->Meta->write;
}
# Experimental support for MYMETA
if ( $ENV{X_MYMETA} ) {
if ( $ENV{X_MYMETA} eq 'JSON' ) {
$self->Meta->write_mymeta_json;
} else {
$self->Meta->write_mymeta_yaml;
}
}
return 1;
}
1;
HTML-TurboForm-0.634/inc/Module/Install/Metadata.pm 0000644 0001750 0001750 00000035304 11455433374 022205 0 ustar thorsten thorsten #line 1
package Module::Install::Metadata;
use strict 'vars';
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
};
my @scalar_keys = qw{
name
module_name
abstract
author
version
distribution_type
tests
installdirs
};
my @tuple_keys = qw{
configure_requires
build_requires
requires
recommends
bundles
resources
};
my @resource_keys = qw{
homepage
bugtracker
repository
};
my @array_keys = qw{
keywords
};
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys { @array_keys }
foreach my $key ( @boolean_keys ) {
*$key = sub {
my $self = shift;
if ( defined wantarray and not @_ ) {
return $self->{values}->{$key};
}
$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
return $self;
};
}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} = shift;
return $self;
};
}
foreach my $key ( @array_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} ||= [];
push @{$self->{values}->{$key}}, @_;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}->{resources} };
}
return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} unless @_;
my @added;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @added, [ $module, $version ];
}
push @{ $self->{values}->{$key} }, @added;
return map {@$_} @added;
};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
unless ( @_ ) {
warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
return 1;
}
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
# Normalize the version
$version = $self->_perl_version($version);
# We don't support the reall old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
$self->{values}->{perl_version} = $version;
}
#Stolen from M::B
my %license_urls = (
perl => 'http://dev.perl.org/licenses/',
apache => 'http://apache.org/licenses/LICENSE-2.0',
artistic => 'http://opensource.org/licenses/artistic-license.php',
artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
lgpl => 'http://opensource.org/licenses/lgpl-license.php',
lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
bsd => 'http://opensource.org/licenses/bsd-license.php',
gpl => 'http://opensource.org/licenses/gpl-license.php',
gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
mit => 'http://opensource.org/licenses/mit-license.php',
mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
);
sub license {
my $self = shift;
return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$self->{values}->{license} = $license;
# Automatically fill in license URLs
if ( $license_urls{$license} ) {
$self->resources( license => $license_urls{$license} );
}
return 1;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name or die(
"all_from called with no args without setting name() first"
);
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
unless ( -e $file ) {
die("all_from cannot find $file from $name");
}
}
unless ( -f $file ) {
die("The path '$file' does not exist, or is not a file");
}
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
$pod =~ s/\.pm$/.pod/i;
$pod = $file unless -e $pod;
# Pull the different values
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
$self->author_from($pod) unless $self->author;
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
return 1;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
return $self->{values}->{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML::Tiny', 0 );
require YAML::Tiny;
my $data = YAML::Tiny::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
} else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
# Add both distribution and module name
sub name_from {
my ($self, $file) = @_;
if (
Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
\s* ;
/ixms
) {
my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
unless ( $self->module_name ) {
$self->module_name($module_name);
}
} else {
die("Cannot determine name from $file\n");
}
}
sub perl_version_from {
my $self = shift;
if (
Module::Install::_read($_[0]) =~ m/
^
(?:use|require) \s*
v?
([\d_\.]+)
\s* ;
/ixms
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
return;
}
}
sub author_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
$author =~ s{E}{<}g;
$author =~ s{E}{>}g;
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
sub license_from {
my $self = shift;
if (
Module::Install::_read($_[0]) =~ m/
(
=head \d \s+
(?:licen[cs]e|licensing|copyright|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
\z
/ixms ) {
my $license_text = $1;
my @phrases = (
'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
'GNU lesser public license' => 'lgpl', 1,
'GNU library general public license' => 'lgpl', 1,
'GNU library public license' => 'lgpl', 1,
'BSD license' => 'bsd', 1,
'Artistic license' => 'artistic', 1,
'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
if ( $license_text =~ /\b$pattern\b/i ) {
$self->license($license);
return 1;
}
}
}
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
my %links;
@links{@links}=();
@links=keys %links;
return @links;
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
my @links = _extract_bugtracker($content);
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
}
if ( @links > 1 ) {
warn "Found more than on rt.cpan.org link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
# Numify
$v = $v + 0;
}
return $v;
}
######################################################################
# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
sub write_mymeta_yaml {
my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
sub write_mymeta_json {
my $self = shift;
# We need JSON to write the MYMETA.json file
unless ( eval { require JSON; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.json\n";
Module::Install::_write(
'MYMETA.json',
JSON->new->pretty(1)->canonical->encode($meta),
);
}
sub _write_mymeta_data {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return undef unless -f 'META.yml';
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
my $requires = $val->{requires};
# Canonize to three-dot version after Perl 5.6
if ( $perl >= 5.006 ) {
$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
unshift @$requires, [ perl => $perl ];
}
# Load the advisory META.yml file
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashs
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
if ( exists $val->{requires} ) {
$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
}
if ( exists $val->{build_requires} ) {
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
return $meta;
}
1;
HTML-TurboForm-0.634/inc/Module/Install/Scripts.pm 0000644 0001750 0001750 00000001011 11455433374 022100 0 ustar thorsten thorsten #line 1
package Module::Install::Scripts;
use strict 'vars';
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub install_script {
my $self = shift;
my $args = $self->makemaker_args;
my $exe = $args->{EXE_FILES} ||= [];
foreach ( @_ ) {
if ( -f $_ ) {
push @$exe, $_;
} elsif ( -d 'script' and -f "script/$_" ) {
push @$exe, "script/$_";
} else {
die("Cannot find script '$_'");
}
}
}
1;
HTML-TurboForm-0.634/inc/Module/Install.pm 0000644 0001750 0001750 00000024114 11455433374 020462 0 ustar thorsten thorsten #line 1
package Module::Install;
# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
# 3. The installed version of inc::Module::Install loads
# 4. inc::Module::Install calls "require Module::Install"
# 5. The ./inc/ version of Module::Install loads
# } ELSE {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
# 3. The ./inc/ version of Module::Install loads
# }
use 5.005;
use strict 'vars';
use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
# different versions of modules.
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '0.91';
# Storage for the pseudo-singleton
$MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
my $s = (stat($0))[9];
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
my $t = time;
if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
It was impossible to maintain duel backends, and has been deprecated.
Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
return;
} elsif ( $method =~ /^_/ and $self->can($method) ) {
# Dispatch to the root M:I class
return $self->$method(@_);
}
# Dispatch to the appropriate plugin
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
goto &{"$self->{name}::import"};
}
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{"$self->{file}"};
delete $INC{"$self->{path}.pm"};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
@exts = $self->{admin}->load_all_extensions;
}
my %seen;
foreach my $obj ( @exts ) {
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
$args{bundle} ||= 'inc/BUNDLES';
$args{base} ||= $base_path;
$class =~ s/^\Q$args{prefix}\E:://;
$args{name} ||= $class;
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} = delete $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
$pkg = $1;
last;
}
}
}
push @found, [ $file, $pkg ];
}, $path ) if -d $path;
@found;
}
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
if ( $] >= 5.006 ) {
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
} else {
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
}
my $string = do { local $/; };
close FH or die "close($_[0]): $!";
return $string;
}
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
$string =~ s/^\n+//s;
return $string;
}
sub _write {
local *FH;
if ( $] >= 5.006 ) {
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
} else {
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
}
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp ($$) {
_version($_[0]) <=> _version($_[1]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2009 Adam Kennedy.
HTML-TurboForm-0.634/MANIFEST 0000644 0001750 0001750 00000002746 11455433374 015660 0 ustar thorsten thorsten .project
inc/Module/AutoInstall.pm
inc/Module/Install.pm
inc/Module/Install/AutoInstall.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
inc/Module/Install/Include.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/Scripts.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/.project
lib/HTML/.project
lib/HTML/TurboForm.pm
lib/HTML/TurboForm/.project
lib/HTML/TurboForm/Constraint.pm
lib/HTML/TurboForm/Constraint/Date.pm
lib/HTML/TurboForm/Constraint/Email.pm
lib/HTML/TurboForm/Constraint/Equation.pm
lib/HTML/TurboForm/Constraint/Length.pm
lib/HTML/TurboForm/Constraint/Regex.pm
lib/HTML/TurboForm/Constraint/Mintime.pm
lib/HTML/TurboForm/Constraint/Required.pm
lib/HTML/TurboForm/Element.pm
lib/HTML/TurboForm/Element/Captcha.pm
lib/HTML/TurboForm/Element/Checkbox.pm
lib/HTML/TurboForm/Element/Date.pm
lib/HTML/TurboForm/Element/Hidden.pm
lib/HTML/TurboForm/Element/Html.pm
lib/HTML/TurboForm/Element/Image.pm
lib/HTML/TurboForm/Element/Imageupload.pm
lib/HTML/TurboForm/Element/Imagegalerie.pm
lib/HTML/TurboForm/Element/Imageslider.pm
lib/HTML/TurboForm/Element/Radio.pm
lib/HTML/TurboForm/Element/Range.pm
lib/HTML/TurboForm/Element/Select.pm
lib/HTML/TurboForm/Element/Password.pm
lib/HTML/TurboForm/Element/Slider.pm
lib/HTML/TurboForm/Element/Submit.pm
lib/HTML/TurboForm/Element/Text.pm
lib/HTML/TurboForm/Element/Textarea.pm
lib/HTML/TurboForm/Element/Upload.pm
Makefile.PL
MANIFEST This list of files
META.yml
HTML-TurboForm-0.634/.project 0000644 0001750 0001750 00000000556 11455433374 016173 0 ustar thorsten thorsten
TurboFormorg.epic.perleditor.perlbuilderorg.epic.perleditor.perlnature
HTML-TurboForm-0.634/META.yml 0000644 0001750 0001750 00000001112 11455433374 015762 0 ustar thorsten thorsten ---
abstract: 'fast and compact HTML Form Class'
author:
- 'Thorsten Drobnik, camelcase@hotmail.com'
build_requires:
ExtUtils::MakeMaker: 6.42
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
generated_by: 'Module::Install version 0.91'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: HTML-TurboForm
no_index:
directory:
- inc
requires:
Date::Calc: 0
Email::Valid: 0
Imager: 0
UNIVERSAL::require: 0
YAML::Syck: 0
resources:
license: http://dev.perl.org/licenses/
version: 0.628
HTML-TurboForm-0.634/Makefile.PL 0000644 0001750 0001750 00000000413 11455433374 016466 0 ustar thorsten thorsten use inc::Module::Install;
name 'HTML-TurboForm';
all_from 'lib/HTML/TurboForm.pm';
requires 'YAML::Syck';
requires 'Email::Valid';
requires 'UNIVERSAL::require';
requires 'Date::Calc';
requires 'Imager';
install_script glob('script/*.pl');
auto_install;
WriteAll;