creating survey results now works

dr-kd · Apr 7, 2010 · a633dea · a633dea
1 parent f319824
commit a633dea
Show file tree

Hide file tree

Showing 4 changed files with 87 additions and 73 deletions.
diff --git a/Survey-Perl/db/answers.db b/Survey-Perl/db/answers.db
diff --git a/Survey-Perl/lib/Survey/Perl/Controller/Survey.pm b/Survey-Perl/lib/Survey/Perl/Controller/Survey.pm
@@ -3,37 +3,51 @@ use Moose;
 use Config::Any;
 BEGIN { extends 'Catalyst::Controller' }
 use Data::Dumper;
-sub survey_base :Chained("/") :PathPart("survey") :CaptureArgs(0) {
-    my ($self, $c) = @_;
-#     if (! $c->user) {
-#         if ($c->req->params->{'dest'} && ! $c->session->{human}) {
-
-#             $c->forward('/recaptcha/test_user');
-#         }
-#         elsif (! $c->session->{human}) {
-#             $c->detach('/recaptcha/test_user');
-#         }
-#     }
-}
 
-sub get_root :Chained("survey_base") :PathPart("") :Args(0) {
-    my ($self, $c) = @_;
-    my $questions = do($c->path_to('survey/en.pl'));
-    $c->stash(sections => $questions,
-              template => 'survey/index.tt');
+sub survey_base : Chained("/") : PathPart("survey") : CaptureArgs(0) {
+    my ( $self, $c ) = @_;
+
+    #     if (! $c->user) {
+    #         if ($c->req->params->{'dest'} && ! $c->session->{human}) {
+
+    #             $c->forward('/recaptcha/test_user');
+    #         }
+    #         elsif (! $c->session->{human}) {
+    #             $c->detach('/recaptcha/test_user');
+    #         }
+    #     }
 }
 
+sub get_root : Chained("survey_base") : PathPart("") : Args(0) {
+    my ( $self, $c ) = @_;
+    my $questions = do( $c->path_to('survey/en.pl') );
+    $c->stash(
+        sections => $questions,
+        template => 'survey/index.tt'
+    );
+}
 
 sub finish_survey : Chained("survey_base") PathPart("finish") Args(0) {
-	my ($self, $c) = @_;
-	my $answers = $c->req->params;
-	$c->log->debug("Params: " . Dumper $answers);
-	delete $answers->{'submit'};
-	my $rs = $c->model('Answers')->txn_do(sub{
-		$c->model('Answers::Survey')->create($answers)
-		or die "Could not submit survey answers: $!";
-	});
-
+    my ( $self, $c ) = @_;
+    my $answers = $c->req->params;
+    $c->log->debug( "Params: " . Dumper $answers);
+    delete $answers->{'submit'};
+    my @multis;
+    my ( $fields, $industries, $versions, $os );
+    $c->log->debug( "Answers: " . Dumper @{ $answers->{'field'} } );
+    push @multis, { industries => $_ } for @{ $answers->{'industries'} };
+    push @multis, { versions   => $_ } for @{ $answers->{'perl_versions'} };
+    push @multis, { os_dev     => $_ } for @{ $answers->{'os_dev'} };
+    $c->log->debug( "multis: " . Dumper @multis );
+    my $rs = $c->model('Answers')->txn_do(
+        sub {
+            $c->model('Answers::Survey')->populate( \@multis );
+
+            $c->model('Answers::Survey')->create($answers)
+              or die "Could not submit survey answers: $!";
+        }
+    );
+
 }
 
 1;
diff --git a/Survey-Perl/script/survey_csv_matrix.pl b/Survey-Perl/script/survey_csv_matrix.pl
@@ -16,7 +16,7 @@
 while ( my $answer = $answer_rs->next ) {
     print Dumper $answer->columns;
     for my $column ( $answer->columns ) {
-        if ( ref $answer->$column eq "ARRAY" ) {
+        if ( ref eval  $answer->$column  eq "ARRAY" ) {
 	        print "Arrayref found\n";
 	        print $fh $column . "," . @{$answer->$column} . "\n"
               or die "couldn't write row: $!";

diff --git a/Survey-Perl/test.csv b/Survey-Perl/test.csv
@@ -1,35 +1,35 @@
 surveyid,1
 gender,1
-age,2
+age,1
 country_birth,
-country_residence,
-highest_qual,3
-field,ARRAY(0x103804b20)
-perl_formal,2
-other_dynamic_formal,3
-other_dynamic_taught,ruby
-income,1
-industries,Computers - Services>
-prog_length,3
-perl_length,3
-percent_programming,4
-percent_management,4
-percent_perl,4
-spare_time,4
-perl_versions,ARRAY(0x103804c00)
-os_dev,ARRAY(0x100d15700)
+country_residence,adfasdf
+highest_qual,2
+field,ARRAY(0x100d15700)
+perl_formal,3
+other_dynamic_formal,
+other_dynamic_taught,
+income,
+industries,
+prog_length,
+perl_length,
+percent_programming,
+percent_management,
+percent_perl,
+spare_time,
+perl_versions,
+os_dev,
 os_deployment,
 lang,
 lang1,
 lang2,
 lang3,
 lang4,
-perl_freq,4
-pm_list,3
-tech_list,3
-tech_list_non_perl,3
-local_pm,3
-pm_meetings,2
+perl_freq,
+pm_list,
+tech_list,
+tech_list_non_perl,
+local_pm,
+pm_meetings,
 conference,
 cpan_modules,
 handover_modules,
@@ -39,29 +39,29 @@ feature_interpreter,
 cpan_bug,
 cpan_fix_bug,
 cpan_feature,
-legacy,4
-eliminate,4
-startup,4
-unmaintainable,4
-scale,4
-management_encourages,4
-management_outdated,4
-management_unmaintainable,4
-management_scale,4
-first,4
-beginner,4
-early_career,4
-experienced,4
-sysadmins,4
-netengs,4
-embedded,4
-apps,4
-best,asdf
+legacy,
+eliminate,
+startup,
+unmaintainable,
+scale,
+management_encourages,
+management_outdated,
+management_unmaintainable,
+management_scale,
+first,
+beginner,
+early_career,
+experienced,
+sysadmins,
+netengs,
+embedded,
+apps,
+best,
 frustrates,
 words,
-cert_me,3
-cert_other,3
-cert_comments,asdf
+cert_me,
+cert_other,
+cert_comments,
 cpan_important,
 cpan1,
 cpan2,
@@ -71,6 +71,6 @@ run_tests,
 force,
 understand,
 report,
-x_platform,3
-x_comments,324tgegrasg
+x_platform,
+x_comments,
 email,