cgi-bin/insitu/upload/index.pl

   1 #!/usr/bin/perl -w
   2
   3 # This script will print a form so that users may upload a gzipped file of
   4 # insitu images from an experiment and metadata about that experiment.
   5 #
   6 # The data will be loaded into the database, and thumbnail images will be
   7 # created for each uploaded image.
   8 #
   9 # The data will be displayed later on with the insitu_view script.
  10
  11 #####################################################################
  12 #####################################################################
  13 # #include
  14 #####################################################################
  15 #####################################################################
  16
  17 # local packages
  18 use strict;
  19 use CXGN::Page;
  20 use CXGN::Insitu;
  21 use CXGN::People;
  22 use CGI;
  23 use Data::Dumper;
  24 use POSIX qw(strftime);
  25
  26 #####################################################################
  27 #####################################################################
  28 # Configuration
  29 #####################################################################
  30 #####################################################################
  31
  32 our $debug = 1; # higher for more verbosity
  33
  34 my $conf = CXGN::VHost->new();
  35 # directory this script will keep temporary and backup data
  36 our $input_dir =  $conf->get_conf("insitu_input");
  37 # directory this script will move renamed fullsize images to
  38 our $fullsize_dir = $conf->get_conf("insitu_fullsize_dir");
  39 # directory this script will move  shrunken images to
  40 our $display_dir = $conf->get_conf("insitu_display_dir");
  41
  42 # suffix / resolution for thumbnail images
  43 our $thumb_suffix = "_thumb";
  44 our $thumb_size = "200";
  45
  46 # suffix / resolution for large (but not fullsize) images
  47 our $large_suffix = "_mid";
  48 our $large_size = "600";
  49
  50
  51 # set up DB connection
  52 #
  53 #our $tag_table = CXGN::Insitu->new();
  54
  55 my $dbh = CXGN::DB::Connection()->new();
  56
  57 my $page = CXGN::Page->new( "Insitu Upload", "Teri");
  58 $page->header("Insitu Manager", "Insitu Upload");
  59
  60 # check whether there is a user logged in, and if so, what they are allowed
  61 # to do
  62 my $person_id=CXGN::Login->new()->has_session();
  63 if($person_id) {
  64     my $person=CXGN::People::Person->new($person_id);
  65     if($person) {
  66         my $username=$person->get_username();
  67         my $user_type=$person->get_user_type()||'';
  68         if($user_type eq 'curator' or $user_type eq 'submitter') {
  69             $debug and warn "Logged in as $username (uid $person_id)\n";
  70             #my $query = new CGI;
  71
  72             my %args = $page->get_all_encoded_arguments();
  73
  74             if ($args{op})) {
  75                 # the form has been submitted before
  76                 if ($args{op} eq "submit_1") {
  77                     my $uploaded_filename;
  78                     warn "after test op eq submit_1...\n";
  79                     # if an image file has been uploaded, copy it to a temporary
  80                     # location
  81                     if ($args{op} eq 'e_file')) {
  82
  83                         # get remote file name, make it safe, keep it sane
  84                         $uploaded_filename = $query->param('e_file');
  85                         $uploaded_filename =~ s/.*[\/\\](.*)/$1/;
  86                         # generate local file name, including IP and time, to make sure
  87
  88                         # multiple uploads don't clobber each other
  89                         my $date = strftime "\%Y-\%m-\%d", gmtime;
  90                         my $create_time = $args{starttime};
  91                         $uploaded_filename = "${input_dir}/" . $ENV{REMOTE_ADDR} . "_${date}_${create_time}_${uploaded_filename}";
  92                         warn "Uploaded_filename=$uploaded_filename\n";
  93                         my $uploaded_filehandle = $query->upload('e_file');
  94
  95                         # only copy file if it doesn't already exist
  96                         if (!-e $uploaded_filename) {
  97
  98                             # open a filehandle for the uploaded file
  99                             if (!$uploaded_filehandle) {
 100                                 happy_death("Source file wasn't opened as a valid filehandle: $!");
 101                             }
 102                             else {
 103                                 # copy said file to destination, line by line
 104                                 warn "Now uploading file...\n";
 105                                 open UPLOADFILE, ">$uploaded_filename" or die "Could not write to ${uploaded_filename}: $!\n";
 106                                 warn "could open filename...\n";
 107                                 binmode UPLOADFILE;
 108                                 while (<$uploaded_filehandle>) {
 109                                     warn "Read another chunk...\n";
 110                                     print UPLOADFILE;
 111                                 }
 112                                 close UPLOADFILE;
 113                                 warn "Done uploading...\n";
 114                                                         }
 115                         }
 116                         else {
 117                             print STDERR "$uploaded_filename exists, not overwriting...\n";
 118                         }
 119
 120                     } # done worrying about uploaded files, for now
 121
 122                     # validate the default form
 123                     validate_form(
 124                                   $person_id,
 125                                   $query->param('starttime'),
 126                                   $uploaded_filename,
 127                                   $query->param('e_file'),
 128                                   $query->param('e_name'),
 129                                   $query->param('e_date_year'),
 130                                   $query->param('e_date_month'),
 131                                   $query->param('e_date_day'),
 132                                   $query->param('e_organism'),
 133                                   $query->param('e_tissue'),
 134                                   $query->param('e_stage'),
 135                                   $query->param('e_primer'),
 136                                   $query->param('e_primer_link_desc'),
 137                                   $query->param('e_primer_link'),
 138                                   $query->param('e_primer_clone'),
 139                                   $query->param('e_primer_seq'),
 140                                   $query->param('e_primer_p1'),
 141                                   $query->param('e_primer_p1_seq'),
 142                                   $query->param('e_primer_p2'),
 143                                   $query->param('e_primer_p2_seq'),
 144                                   $query->param('e_description'),
 145                                   [$query->param('e_category')]
 146                                   );
 147                 }
 148                 elsif ($query->param('op') eq "submit_2") {
 149                     if ($debug > 1) {
 150                         warn Dumper $query->param;
 151                     }
 152                     # reformat data into useful hash
 153                     my %imgs = ();
 154                     foreach my $img ($query->param) {
 155                         if ($img =~ m/([0-9]+)_(name|description|category)/) {
 156                             my $img_id = $1;
 157                             my $data_type = $2;
 158                             if ($data_type eq 'category') {
 159                                 $imgs{$img_id}{$data_type} = [$query->param($img)];
 160                             }
 161                             else {
 162                                 $imgs{$img_id}{$data_type} = $query->param($img);
 163                             }
 164                         }
 165                     }
 166                     # send submitted image data to a function to process it
 167                     finalize_submission(\%imgs);
 168                 }
 169                 else {
 170                     # unknown operation; this shouldn't happen
 171                     print "<div class=\"error\">An error has occured!</div>";
 172                     print_form();
 173                 }
 174             } else {
 175                 # first run; default operation
 176                 print_form();
 177             }
 178         }
 179         else {
 180             print "You do not currently have rights to submit any data.";
 181         }
 182     }
 183 }
 184 else {
 185     print "You must log in to do that!";
 186 }
 187
 188 $page->footer();
 189
 190
 191
 192
 193
 194
 195 #####################################################################
 196 #####################################################################
 197 # Functions
 198 #####################################################################
 199 #####################################################################
 200
 201 #####################################################################
 202 # default operation; print form
 203 sub print_form {
 204     my ($starttime, $file, $name, $year, $month, $day, $organism, $tissue, $stage, $primer, $primer_link_desc, $primer_link, $primer_clone, $primer_sequence, $primer_p1, $primer_p1_seq, $primer_p2, $primer_p2_seq, $description, $categories) = @_;
 205     $starttime ||= time;
 206     $file ||= "";
 207     $name ||= "";
 208     $year ||= "";
 209     $month ||= "";
 210     $day ||= "";
 211     $organism ||= "";
 212     $tissue ||= "";
 213     $stage ||= "";
 214     $primer ||= "";
 215     $primer_link_desc ||= "";
 216     $primer_link ||= "";
 217     $primer_clone ||= "";
 218     $primer_sequence ||= "";
 219     $primer_p1 ||= "";
 220     $primer_p1_seq ||= "";
 221     $primer_p2 ||= "";
 222     $primer_p2_seq ||= "";
 223     $description ||= "";
 224     my $date = "$year-$month-$day";
 225     if ($debug > 1) {
 226         warn "\nprint_form input: \n";
 227         warn "\tstarttime: $starttime\n";
 228         warn "\tfile: $file\n";
 229
 230         warn "\texperiment name: $name\n";
 231         warn "\tdate: $date\n";
 232         warn "\torganism_id: $organism\n";
 233         warn "\ttissue: $tissue\n";
 234         warn "\tdevelopmental stage: $stage\n";
 235         warn "\tprimer: $primer\n";
 236         warn "\tprimer_link_desc: $primer_link_desc\n";
 237         warn "\tprimer_link: $primer_link\n";
 238         warn "\tprimer_clone: $primer_clone\n";
 239         warn "\tprimer_sequence:\n$primer_sequence\n";
 240         warn "\tprimer_p1: $primer_p1\n";
 241         warn "\tprimer_p1_seq:\n$primer_p1_seq\n";
 242         warn "\tprimer_p2: $primer_p2\n";
 243         warn "\tprimer_p2_seq:\n$primer_p2_seq\n";
 244         warn "\tdescription:\n$description\n";
 245         warn "\tcategories:\n";
 246         warn Dumper @$categories;
 247         warn "\n\n";
 248     }
 249
 250
 251     print "\n<br /><br />\n\n";
 252     print "<div class=\"heading\">Experiment Metadata</div>\n";
 253     print "<p>Please enter information about the experiment these images came from.  All fields are required.  The uploaded file should be a tar file (.tar, .tgz, .tar.gz, or.tar.bz2).</p>\n\n";
 254     print "<p>Please be patient, as after the file is uploaded it will be unpacked and the images will be processed.  This can take quite some time! <strong>Don't hit reload!</strong></p>\n\n";
 255
 256     print "<form method=\"post\" action=\"$script_name\" enctype=\"multipart/form-data\">\n";
 257     print "<input type=\"hidden\" name=\"op\" value=\"submit_1\" />\n";
 258     print "<input type=\"hidden\" name=\"starttime\" value=\"$starttime\" />\n";
 259     print "<table border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n\n";
 260
 261     # file upload
 262     print "<tr><td class=\"fielddef\">\n";
 263     print "File upload:\n";
 264     print "</td><td class=\"fieldinput\">\n";
 265     if ($file) {
 266         print "<input type=\"hidden\" name=\"e_file\" value=\"$file\"/>";
 267         print "<strong>$file</strong>";
 268     }
 269     else {
 270         print "<input class=\"fieldinput\" type=\"file\" name=\"e_file\"/>";
 271     }
 272     print "</td></tr>\n\n";
 273
 274     # experiment name
 275     print "<tr><td class=\"fielddef\">\n";
 276     print "Experiment name:\n";
 277     print "</td><td class=\"fieldinput\">\n";
 278     print "<input class=\"fieldinput\" type=\"text\" name=\"e_name\" value=\"$name\"/>";
 279     print "</td></tr>\n\n";
 280
 281     # date of experiment
 282     print "<tr><td class=\"fielddef\">\n";
 283     print "Experiment date:\n";
 284     print "</td><td class=\"fieldinput\">\n";
 285     print "<select name=\"e_date_year\">\n";
 286     print "<option value=\"\"></option>\n";
 287     for (my $year1=strftime '%Y', gmtime; $year1>=1980; $year1--) {
 288         print "<option value=\"$year1\"";
 289         ($year eq $year1) and print " selected=\"selected\"";
 290         print ">$year1</option>\n";
 291     }
 292     print "</select>\n";
 293     print "<select name=\"e_date_month\">\n";
 294     print "<option value=\"\"></option>\n";
 295     for (my $month1=1; $month1<=12; $month1++) {
 296         my $month2 = sprintf("%02d", $month1);
 297         print "<option value=\"$month2\"";
 298         ($month eq $month2) and print " selected=\"selected\"";
 299         print ">$month2</option>\n";
 300     }
 301     print "</select>\n";
 302     print "<select name=\"e_date_day\">\n";
 303     print "<option value=\"\"></option>\n";
 304     for (my $day1=1; $day1<=31; $day1++) {
 305         my $day2 = sprintf("%02d", $day1);
 306         print "<option value=\"$day2\"";
 307         ($day eq $day2) and print " selected=\"selected\"";
 308         print ">$day2</option>\n";
 309     }
 310     print "</select>\n";
 311     print "(YYYY/MM/DD)\n";
 312     print "</td></tr>\n\n";
 313
 314     # organism
 315     print "<tr><td class=\"fielddef\">\n";
 316     print "Organism:\n";
 317     print "</td><td class=\"fieldinput\">\n";
 318     my %organisms = $tag_table->return_organisms();
 319     print "<select name=\"e_organism\">\n";
 320     print "<option value=\"\"></option>\n";
 321     ($debug > 1) and warn Dumper \%organisms;
 322     foreach my $organism2 (sort keys %organisms) {
 323         my $org_id = $organisms{$organism2}{id};
 324         my $org_name = $organisms{$organism2}{name};
 325         print "<option value=\"$org_id\"";
 326         ($organism eq $org_id) and print " selected=\"selected\"";
 327         print ">$org_name</option>\n";
 328     }
 329     print "</select>\n";
 330     print "</td></tr>\n\n";
 331
 332     # tissue
 333     print "<tr><td class=\"fielddef\">\n";
 334     print "Tissue:\n";
 335     print "</td><td class=\"fieldinput\">\n";
 336     print "<input class=\"fieldinput\" type=\"text\" name=\"e_tissue\" value=\"$tissue\"/>";
 337     print "</td></tr>\n\n";
 338
 339     # developmental stage
 340     print "<tr><td class=\"fielddef\">\n";
 341     print "Developmental Stage:\n";
 342     print "</td><td class=\"fieldinput\">\n";
 343     print "<input class=\"fieldinput\" type=\"text\" name=\"e_stage\" value=\"$stage\"/>";
 344     print "</td></tr>\n\n";
 345
 346     # primer
 347     print "<tr><td class=\"fielddef\">\n";
 348     print "Probe Name:\n";
 349     print "<div style=\"font-weight:normal; font-size:x-small; color: #000000\">\n";
 350     print "<br />If you enter the name of an existing probe, the<br />information for that probe will be used for the<br />optional fields.\n";
 351     print "<br /><a href=\"/cgi-bin/insitu_view.pl?op=probes\">Existing Probes...</a>\n";
 352     print "</div>\n";
 353     print "</td><td class=\"fieldinput\" valign=\"top\">\n";
 354     print "<input class=\"fieldinput\" type=\"text\" name=\"e_primer\" value=\"$primer\"/><br />";
 355     print "<span class=\"subfield\">Optional probe fields...</span> (<a style=\"font-size:smaller; text-decoration:underline; cursor: pointer;\" onclick=\"toggle('primer_optional'); return false;\" onfocus=\"blur()\">show/hide</a>)<br />\n";
 356     print "<div id=\"primer_optional\">\n";
 357     print "<br />\n";
 358     print "<span class=\"subfield\">Primer One:</span><br />&nbsp;<input class=\"fieldinput\" type=\"text\" name=\"e_primer_p1\" value=\"$primer_p1\"/><br />\n";
 359     print "<span class=\"subfield\">Primer One Sequence:</span><br />&nbsp;\n";
 360     print "<textarea name=\"e_primer_p1_seq\" class=\"fieldtext\">$primer_p1_seq</textarea><br />\n";
 361     print "<span class=\"subfield\">Primer Two:</span><br />&nbsp;<input class=\"fieldinput\" type=\"text\" name=\"e_primer_p2\" value=\"$primer_p2\"/><br />\n";
 362     print "<span class=\"subfield\">Primer Two Sequence:</span><br />&nbsp;\n";
 363     print "<textarea name=\"e_primer_p2_seq\" class=\"fieldtext\">$primer_p2_seq</textarea><br />\n";
 364     print "<br />\n";
 365     print "<span class=\"subfield\">Probe Sequence:</span><br />&nbsp;\n";
 366     print "<textarea name=\"e_primer_seq\" class=\"fieldtext\">$primer_sequence</textarea><br />\n";
 367     print "<br />\n";
 368     print "<span class=\"subfield\">Clone:</span> (<a href=\"http://pgn.cornell.edu\">PGN</a> clones)<br />&nbsp;<input class=\"fieldinput\" type=\"text\" name=\"e_primer_clone\" value=\"$primer_clone\"/><br />\n";
 369     print "<span class=\"subfield\">Source Description:</span> (non-<a href=\"http://pgn.cornell.edu\">PGN</a>)<br />&nbsp;<input class=\"fieldinput\" type=\"text\" name=\"e_primer_link_desc\" value=\"$primer_link_desc\"/><br />\n";
 370     print "<span class=\"subfield\">Source Link:</span> (non-<a href=\"http://pgn.cornell.edu\">PGN</a>)<br />&nbsp;<input class=\"fieldinput\" type=\"text\" name=\"e_primer_link\" value=\"$primer_link\"/><br />\n";
 371     print "</div>\n";
 372     if (!$primer_link_desc && !$primer_link && !$primer_clone && !$primer_sequence && !$primer_p1 && !$primer_p1_seq && !$primer_p2 && !$primer_p2_seq) {
 373         print "<script language=\"JavaScript\" type=\"text/javascript\">\n<!--\ncontract('primer_optional');\n//-->\n</script>\n";
 374     }
 375     print "</td></tr>\n\n";
 376
 377     # description of experiment
 378     print "<tr><td class=\"fielddef\">\n";
 379     print "Other information / Description:\n";
 380     print "</td><td class=\"fieldinput\">\n";
 381     print "<textarea name=\"e_description\" class=\"fieldtext\">$description</textarea>\n";
 382     print "</td></tr>\n\n";
 383
 384     # categories
 385     print "<tr><td class=\"fielddef\">\n";
 386     print "Categories:<br /><a style=\"font-weight: normal; font-size:smaller;\" href=\"edit_cats.pl\">Add/Edit Categories...</a>\n";
 387     print "</td><td class=\"fieldinput\">\n";
 388     # previously checked tags
 389     my %checked_cats;
 390     foreach (@$categories) {
 391         $checked_cats{$_} = 1;
 392     }
 393     # get tags from database and load them into a hash of arrays
 394     my %tags = $tag_table->return_tags();
 395     ($debug > 2) and warn "print_form tags from database:\n";
 396     ($debug > 2) and warn Dumper \%tags;
 397     # print out tags
 398     foreach my $tag_name (sort keys %tags) {
 399         my $tag_desc = $tags{$tag_name}[2];
 400         my $tag_id = $tags{$tag_name}[0];
 401         my $checked = "";
 402         $checked_cats{$tag_id} and $checked="checked=\"checked\"";
 403         print "<input class=\"fieldcheck\" type=\"checkbox\" name=\"e_category\" value=\"$tag_id\" $checked /> $tag_name";
 404         $tag_desc and print " - $tag_desc";
 405         print "<br />\n";
 406     }
 407     print "</td></tr>\n\n";
 408
 409     # submit button
 410     print "<tr><td class=\"fielddef\" style=\"text-align:center\" colspan=\"2\">\n";
 411     print "<input class=\"fieldinput\" type=\"submit\" value=\"Upload data\" />\n";
 412     print "</td></tr>\n\n";
 413
 414     print "</table>\n";
 415     print "</form>\n\n";
 416 }
 417
 418 #####################################################################
 419 # validate form data
 420 sub validate_form {
 421     my ($person_id, $starttime, $local_file, $file, $name, $year, $month, $day, $organism, $tissue, $stage, $primer, $primer_link_desc, $primer_link, $primer_clone, $primer_sequence, $primer_p1, $primer_p1_seq, $primer_p2, $primer_p2_seq, $description, $categories) = @_;
 422     my $date = "$year-$month-$day";
 423     if ($debug > 1) {
 424         warn "\nvalidate_form input: \n";
 425         warn "\tperson_id: $person_id\n";
 426         warn "\tstarttime: $starttime\n";
 427         warn "\tfile: $file\n";
 428         warn "\tlocal filename: $local_file\n";
 429         warn "\texperiment name: $name\n";
 430         warn "\tdate: $date\n";
 431         warn "\torganism_id: $organism\n";
 432         warn "\ttissue: $tissue\n";
 433         warn "\tdevelopmental stage: $stage\n";
 434         warn "\tprimer: $primer\n";
 435         warn "\tprimer_link_desc: $primer_link_desc\n";
 436         warn "\tprimer_link: $primer_link\n";
 437         warn "\tprimer_clone: $primer_clone\n";
 438         warn "\tprimer_sequence:\n$primer_sequence\n";
 439         warn "\tprimer_p1: $primer_p1\n";
 440         warn "\tprimer_p1_seq:\n$primer_p1_seq\n";
 441         warn "\tprimer_p2: $primer_p2\n";
 442         warn "\tprimer_p2_seq:\n$primer_p2_seq\n";
 443         warn "\tdescription:\n$description\n";
 444         warn "\tcategories:\n";
 445         warn Dumper @$categories;
 446         warn "\n\n";
 447     }
 448
 449     # by default everything is correct, increment this value as errors
 450     # are found
 451     my $failure = 0;
 452
 453     print "<div class=\"error\">\n";
 454
 455     # perform checks to make sure that all required data was submitted
 456     if (!$file) {
 457         $failure++;
 458         print "Please select a file to upload.<br />\n";
 459     }
 460     if (!$name) {
 461         $failure++;
 462         print "Please enter a name for this experiment<br />\n";
 463     }
 464     if (!$year) {
 465         $failure++;
 466         print "Please select the year this experiment was performed in.<br />\n";
 467     }
 468     if (!$month) {
 469         $failure++;
 470         print "Please select the month this experiment was performed in.<br />\n";
 471     }
 472     if (!$day) {
 473         $failure++;
 474         print "Please select the day this experiment was performed on.<br />\n";
 475     }
 476     if (!$organism) {
 477         $failure++;
 478         print "Please select an organism.<br />\n";
 479     }
 480     if (!$tissue) {
 481         $failure++;
 482         print "Please enter the tissue for this experiment.<br />\n";
 483     }
 484     if (!$stage) {
 485         $failure++;
 486         print "Please enter the developmental stage.<br />\n";
 487     }
 488     if (!$primer) {
 489         $failure++;
 490         print "Please enter the primer.<br />\n";
 491     }
 492     if (($primer_p1 && !$primer_p1_seq) || ($primer_p1_seq && !$primer_p1)) {
 493         $failure++;
 494         print "Please enter both the primer name and sequence for primer one.<br />\n";
 495     }
 496     if (($primer_p2 && !$primer_p2_seq) || ($primer_p2_seq && !$primer_p2)) {
 497         $failure++;
 498         print "Please enter both the primer name and sequence for primer two.<br />\n";
 499     }
 500     if ($primer_link_desc && !$primer_link) {
 501         $failure++;
 502         print "If you enter something for the source description, you must enter something for the source link.<br />\n";
 503     }
 504     if ($primer_link && $primer_link !~ /^http:\/\/.+/) {
 505         $failure++;
 506         print "Please ensure that the source link you entered is a full URL (i.e., that it starts with a 'http://').<br />\n";
 507     }
 508     if ($primer_clone && $primer_clone !~ /^[A-Za-z]{3}[0-9]{2}-[0-9a-zA-Z]+-[a-z0-9]+$/) {
 509         $failure++;
 510         print "Please ensure that the clone you entered is a PGN EST.<br />\n";
 511     }
 512 #       if (@$categories < 1) {
 513 #               $failure++;
 514 #               print "Please select the categories that apply to this experiment.<br />\n";
 515 #       }
 516
 517     print "</div>\n";
 518
 519     if ($failure>0) {
 520         # start over, retaining all data it is possible to retain
 521         print_form(
 522                    $starttime,
 523                    $file,
 524                    $name,
 525                    $year,
 526                    $month,
 527                    $day,
 528                    $organism,
 529                    $tissue,
 530                    $stage,
 531                    $primer,
 532                    $primer_link_desc,
 533                    $primer_link,
 534                    $primer_clone,
 535                    $primer_sequence,
 536                    $primer_p1,
 537                    $primer_p1_seq,
 538                    $primer_p2,
 539                    $primer_p2_seq,
 540                    $description,
 541                    $categories
 542                    );
 543     }
 544     else {
 545         # go to the next step
 546         process_submission(
 547                            $person_id,
 548                            $starttime,
 549                            $local_file,
 550                            $file,
 551                            $name,
 552                            $year,
 553                            $month,
 554                            $day,
 555                            $organism,
 556                            $tissue,
 557                            $stage,
 558                            $primer,
 559                            $primer_link_desc,
 560                            $primer_link,
 561                            $primer_clone,
 562                            $primer_sequence,
 563                            $primer_p1,
 564                            $primer_p1_seq,
 565                            $primer_p2,
 566                            $primer_p2_seq,
 567                            $description,
 568                            $categories
 569                            );
 570     }
 571 }
 572
 573 #####################################################################
 574 # do prep grunt work, and acquire some more metadata
 575 sub process_submission {
 576     my ($person_id, $starttime, $local_file, $file, $name, $year, $month, $day, $organism, $tissue, $stage, $primer, $primer_link_desc, $primer_link, $primer_clone, $primer_sequence, $primer_p1, $primer_p1_seq, $primer_p2, $primer_p2_seq, $description, $categories) = @_;
 577     my $date = "$year-$month-$day";
 578     if ($debug) {
 579         warn "\nprocess_submission input: \n";
 580         warn "\tperson_id: $person_id\n";
 581         warn "\tstarttime: $starttime\n";
 582         warn "\tfile: $file\n";
 583         warn "\tlocal filename: $local_file\n";
 584         warn "\texperiment name: $name\n";
 585         warn "\tdate: $date\n";
 586         warn "\torganism_id: $organism\n";
 587         warn "\ttissue: $tissue\n";
 588         warn "\tdevelopmental stage: $stage\n";
 589         warn "\tprimer: $primer\n";
 590         warn "\tprimer_link_desc: $primer_link_desc\n";
 591         warn "\tprimer_link: $primer_link\n";
 592         warn "\tprimer_clone: $primer_clone\n";
 593         warn "\tprimer_sequence:\n$primer_sequence\n";
 594         warn "\tprimer_p1: $primer_p1\n";
 595         warn "\tprimer_p1_seq:\n$primer_p1_seq\n";
 596         warn "\tprimer_p2: $primer_p2\n";
 597         warn "\tprimer_p2_seq:\n$primer_p2_seq\n";
 598         warn "\tdescription:\n$description\n";
 599         warn "\tcategories:\n";
 600         #warn Dumper @$categories;
 601         warn "\n\n";
 602     }
 603
 604     # figure out what type of file this is, unpack it
 605     my @images = ();
 606         my $error_msg;
 607     if ($local_file =~ m/(\.tgz)|(\.tar\.gz)$/i ) { # gzipped tar file
 608         $debug and warn "Unpacking gzipped tar file...\n";
 609         @images = unpack_tgz($local_file);
 610     }
 611     elsif ($local_file =~ m/(\.tar.bz2)|(\.bz2)$/i ) { # bzipped tar file
 612         $debug and warn "Unpacking bzip2ed tar file...\n";
 613         @images = unpack_tbz2($local_file);
 614     }
 615     elsif ($local_file =~ m/\.tar$/i ) { # uncompressed tar file
 616         $debug and warn "Unpacking tar file...\n";
 617         @images = unpack_tar($local_file);
 618     }
 619     elsif ($local_file =~ m/\.zip$/i ) { # zip file
 620         $debug and warn "Unpacking zip file...\n";
 621         @images = unpack_zip($local_file);
 622     }
 623     elsif ($local_file =~ m/\.bz2$/i ) { # bzip2ed file
 624         $debug and warn "Unpacking bz2 file...\n";
 625         @images = unpack_bz2($local_file);
 626     }
 627     elsif ($local_file =~ m/\.gz$/i ) { # gzipped file
 628         $debug and warn "Unpacking gz file...\n";
 629         @images = unpack_gz($local_file);
 630     }
 631     else { # unknown file type
 632         $debug and warn "Unknown file type!\n";
 633
 634         $error_msg .= "<div class=\"error\">Unknown file type!</div>\n";
 635         $error_msg .= "Please go <a href=\"javascript:history.back(1)\">back</a> and upload a different file- this program is unable to unpack files of this file type.\n";
 636         happy_death($error_msg);
 637     }
 638
 639     # make sure we have at least one image
 640     if (@images<1) {
 641         $error_msg .= "<div class=\"error\">Error unpacking file!</div>\n";
 642         $error_msg .= "We were unable to extract any image files from the file you uploaded.  Please ensure that the file you submitted was of a supported file type.\n";
 643         happy_death($error_msg);
 644     }
 645
 646     # insert experiment info into database so that we can get an
 647     # experiment_id to associate with the uploaded images
 648     my $experiment_id = $tag_table->insert_experiment($name, $date, $organism, $tissue, $stage, $primer, $primer_link_desc, $primer_link, $primer_clone, $primer_sequence, $primer_p1, $primer_p1_seq, $primer_p2, $primer_p2_seq, $description, $categories, $person_id);
 649     $debug and warn "experiment has been inserted into database with experiment_id $experiment_id\n";
 650
 651     # do all the work in moving, copying, resizing, databasing, etc., images
 652     process_images(\@images, $experiment_id);
 653
 654     print "<p>Please enter any additional information you may have about these images.</p><p>All of this information is optional, and each image will already be associated with the categories selected for this experiment.</p>\n\n";
 655
 656     # get all the images that were just inserted, print them all so that
 657     # any additional information for them can be entered
 658     my %images = $tag_table->return_images($experiment_id);
 659     if ($debug > 2) {
 660         warn "\n\nprocess: images info:\n ";
 661         warn Dumper \%images;
 662         warn "\n\n";
 663     }
 664
 665     # print off the start of the form
 666     print "<form method=\"post\" action=\"$script_name\">\n";
 667     print "<input type=\"hidden\" name=\"op\" value=\"submit_2\" />\n";
 668     print "<table border=\"1\" cellpadding=\"10\" cellspacing=\"5\">\n\n";
 669
 670     # alternate bg color for image rows to make things more legible
 671     my $row = 1;
 672     foreach my $image (keys %images) {
 673         my $color = "#FFFFFF";
 674         if ($row%2) {
 675             $color = "#DDDDDD";
 676         }
 677
 678         # print form elements to modify this images data
 679         print "<tr bgcolor=\"$color\"><td class=\"fielddef\" style=\"text-align:center\" width=\"250\" valign=\"top\">\n";
 680
 681         # print a thumnail of the image, which will open the fullsized image
 682         # in a new window when clicked
 683         print "<a href=\"/thumbnail_images/${experiment_id}/$images{$image}[2].jpg\" onclick=\"javascript: window.open('/fullsize_images/${experiment_id}/$images{$image}[2]$images{$image}[3]', 'blank', 'toolbar=no'); return false;\"><img src=\"/thumbnail_images/${experiment_id}/$images{$image}[2]_${thumb_suffix}.jpg\" border=\"0\" width=\"$thumb_size\" alt=\"image id: $image\" /></a><br /><em>$images{$image}[2]</em>\n\n";
 684
 685         print "</td><td width=\"100%\">\n";
 686
 687         # print form elements to update data for this image
 688         #       name
 689         print "<strong>Name</strong><br />\n";
 690         print "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<input class=\"fieldinput\" type=\"text\" name=\"${image}_name\" value=\"\"/>\n";
 691         print "<br />\n";
 692
 693         #       description
 694         print "<strong>Description</strong><br />\n";
 695         print "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<textarea name=\"${image}_description\" class=\"fieldtext\"></textarea>\n";
 696         print "<br />\n";
 697
 698         #       tags
 699         print "<strong>Additional Categories</strong> (<a style=\"font-size:smaller; text-decoration:underline; cursor: pointer;\" onclick=\"toggle('${image}_taglist'); return false;\" onfocus=\"blur()\">show/hide</a>)<br />\n";
 700         print "<div id=\"${image}_taglist\">\n";
 701         my %tags = $tag_table->return_tags();
 702         ($debug > 2) and warn "process_submission tags from database:\n";
 703         ($debug > 2) and warn Dumper \%tags;
 704         # get previously applied tags for this experiment, those should
 705         # already be selected here and impossible to deselect
 706         my %expr_tags = $tag_table->return_relevant_tags("ex", $experiment_id);
 707         ($debug > 2) and warn "process_submission experiment tags from database:\n";
 708         ($debug > 2) and warn Dumper \%expr_tags;
 709         # print out tags
 710         foreach my $tag_name (sort keys %tags) {
 711             my $tag_desc = $tags{$tag_name}[2];
 712             my $tag_id = $tags{$tag_name}[0];
 713             if ($expr_tags{$tag_name}) {
 714                 print "<div class=\"greyed_out\">";
 715                 print "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<input class=\"fieldcheck\" type=\"checkbox\" name=\"preselected\" value=\"$tag_id\" checked=\"checked\" disabled=\"disabled\" /> $tag_name";
 716             }
 717             else {
 718                 print "<div>";
 719                 print "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<input class=\"fieldcheck\" type=\"checkbox\" name=\"${image}_category\" value=\"$tag_id\"/> $tag_name";
 720             }
 721             $tag_desc and print " - $tag_desc";
 722             print "</div>\n";
 723         }
 724         print "</div>\n";
 725         print "<script language=\"JavaScript\" type=\"text/javascript\">\n<!--\ncontract('${image}_taglist');\n//-->\n</script>\n";
 726
 727         print "</td></tr>\n\n";
 728
 729         $row++;
 730     }
 731     # print submit button, close out form
 732     my $color = "#FFFFFF";
 733     if ($row%2) {
 734         $color = "#DDDDDD";
 735     }
 736     print "<tr bgcolor=\"$color\"><td class=\"fielddef\" style=\"text-align:center\" colspan=\"2\">\n";
 737     print "<input class=\"fieldinput\" type=\"submit\" value=\"Update image data\" />\n";
 738     print "</td></tr>\n\n";
 739
 740     print "</table>\n";
 741     print "</form>\n\n";
 742
 743 }
 744
 745 #####################################################################
 746 # enter additional image data
 747 sub finalize_submission {
 748     my $img_data = shift;
 749     ($debug > 0) and warn Dumper $img_data;
 750     foreach my $img_id (keys %$img_data) {
 751         $tag_table->update_image_data($img_id, $img_data->{$img_id}{'name'}, $img_data->{$img_id}{'description'}, $img_data->{$img_id}{'category'});
 752     }
 753     print "<p>Your images have been updated successfully.</p><p>Thanks!</p>\n";
 754 }
 755
 756 #####################################################################
 757 # given a file, break it open and return an array containing the
 758 # unpacked file locations/names
 759
 760 sub unpack_bz2 {
 761     #FIXME: can't unpack bz2 yet
 762 }
 763
 764 sub unpack_gz {
 765     #FIXME: can't unpack gz yet
 766 }
 767
 768 sub unpack_tar {
 769     my $input_file = shift;
 770     $debug and warn "Incoming file: $input_file\n";
 771     chdir $input_dir;
 772     my @output_files = ();
 773     my $safe_tar_options = "--mode 644 -k --force-local";
 774     my $command = "tar vxf ${input_file} $safe_tar_options";
 775     $debug and warn "Executing command:\n\t$command\n";
 776     my $output = `$command`;
 777     @output_files = split /\n/, $output;
 778     return @output_files;
 779 }
 780
 781 sub unpack_tbz2 {
 782     my $input_file = shift;
 783     $debug and warn "Incoming file: $input_file\n";
 784     chdir $input_dir;
 785     my @output_files = ();
 786     my $safe_tar_options = "--mode 644 -k --force-local";
 787     my $command = "tar vxjf ${input_file} $safe_tar_options";
 788     $debug and warn "Executing command:\n\t$command\n";
 789     my $output = `$command`;
 790     @output_files = split /\n/, $output;
 791     return @output_files;
 792 }
 793
 794 sub unpack_tgz {
 795     my $input_file = shift;
 796     $debug and warn "Incoming file: $input_file\n";
 797     chdir $input_dir;
 798     my @output_files = ();
 799     my $safe_tar_options = "--mode 644 -k --force-local";
 800     my $command = "tar vxzf ${input_file} $safe_tar_options";
 801     $debug and warn "Executing command:\n\t$command\n";
 802     my $output = `$command`;
 803     @output_files = split /\n/, $output;
 804     return @output_files;
 805 }
 806
 807 sub unpack_zip {
 808     my $input_file = shift;
 809     $debug and warn "Incoming file: $input_file\n";
 810     chdir $input_dir;
 811     my @output_files = ();
 812     my $safe_zip_options = "-n";
 813     my $command = "unzip $safe_zip_options ${input_file}";
 814     $debug and warn "Executing command:\n\t$command\n";
 815     my $output = `$command`;
 816     ($debug > 2) and warn "output of unzip:\n$output\n";
 817     @output_files = split /\n/, $output;
 818     my @output_filenames = ();
 819     foreach (@output_files) {
 820         if (($_ !~ /Archive:/) && ($_ =~ /inflating: (.+\.[A-Za-z0-9]{3,4})\b\s+?$/)) {
 821             ($debug > 2) and warn "processing $_ ($1)...\n";
 822             push @output_filenames, $1;
 823         }
 824         else { ($debug > 2) and warn "skipping $_...\n"; }
 825     }
 826     return @output_filenames;
 827 }
 828
 829 #####################################################################
 830 # given a list of unpacked files, create thumbnail and midsize images
 831 # and copy all files to the correct places.
 832 # $display_dir is for resized images
 833 # $fullsize_dir is for original high resolution images
 834 sub process_images {
 835     my ($original_files, $experiment_id) = @_;
 836     # create subdirectories for these images to live in
 837     my ($fullsize_path, $display_path);
 838     $fullsize_path = "${fullsize_dir}/$experiment_id";
 839     $display_path = "${display_dir}/$experiment_id";
 840     $debug and warn "Creating:\n\tfullsize directory: $fullsize_path\n\tdisplay directory: $display_path\n";
 841     # these commands shouldn't do any harm if these directories already exist
 842     system("mkdir $fullsize_path");
 843     system("chmod 775 '$fullsize_path'");
 844     system("mkdir $display_path");
 845     system("chmod 775 '$display_path'");
 846
 847     # process each image
 848     foreach my $file (@$original_files) {
 849         my ($safe_file, $safe_ext, $unix_file);
 850         $safe_file = $file;
 851         $safe_file =~ m/(.*)(\.[a-zA-Z0-9]{3,4})$/i;
 852         $safe_file = $1;
 853         $safe_ext = $2;
 854         $unix_file = $safe_file;
 855         $unix_file =~ s/\s/_/g;
 856
 857         $debug and warn "filename: $file\n\tsafe name: $safe_file\n\tunix name: $unix_file\n\textension: $safe_ext\n";
 858
 859         # copy unmodified image to be fullsize image
 860         system("mv '${input_dir}/$file' '${fullsize_path}/${unix_file}${safe_ext}'");
 861         system("chmod 664 '${fullsize_path}/${unix_file}${safe_ext}'");
 862
 863         # convert to jpg if format is different
 864         if ($safe_ext !~ /jpg/i || $safe_ext !~ /jpeg/i) {
 865             system("/usr/bin/convert ${fullsize_path}${safe_ext} ${fullsize_path}.jpg");
 866             $safe_ext = ".jpg";
 867         }
 868
 869         # create small thumbnail for each image
 870         copy_image_resize("${fullsize_path}/${unix_file}${safe_ext}", "${display_path}/${unix_file}_${thumb_suffix}.jpg", "$thumb_size");
 871
 872         # create midsize image for each image
 873         copy_image_resize("${fullsize_path}/${unix_file}${safe_ext}", "${display_path}/${unix_file}_${large_suffix}.jpg", "$large_size");
 874
 875         # enter preliminary image data into database
 876         $tag_table->insert_image($experiment_id, $unix_file, ${safe_ext});
 877     }
 878 }
 879
 880 #####################################################################
 881 # given an image file, and a size (see configuration),
 882 # copy the image to a resized version
 883 sub copy_image_resize {
 884     my ($original_image, $new_image, $width) = @_;
 885
 886     $debug and warn "\tCopying $original_image to $new_image and resizing it to $width px wide\n";
 887
 888     # first copy the file
 889     system("cp '$original_image' '$new_image'");
 890     system("chmod 664 '$new_image'");
 891
 892     # now resize the new file, and ensure it is a jpeg
 893     my $resize = `mogrify -geometry $width '$new_image'`;
 894     my $jpeg = `mogrify -format jpg '$new_image'`;
 895
 896     if ($resize || $jpeg) {
 897         happy_death("An error occurred while rezising $original_image:<div class=\"error\">$resize</div> <div class=\"error\">$jpeg</div>")
 898         }
 899     else {
 900         return 1;
 901     }
 902
 903 }
 904
 905 #####################################################################
 906 # Print error and exit, closing the page
 907 sub happy_death {
 908     my $message = shift;
 909     print $message;
 910     $page->footer();
 911     exit;
 912 }
 913