home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / fcn-mtp.pl < prev    next >
Text File  |  2009-11-06  |  13KB  |  381 lines
  1. # FILE: fcn-mtp.pl
  2. # DESCRIPTION: Functions to manage input from "multipart" (i.e., upload) forms
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### parse_multipart
  20. ###
  21. ### Parse a multipart form (dump regular variables into standard form constructs
  22. ### and store files separately)
  23. ###
  24.  
  25. sub parse_multipart {
  26.     my ($clength) = @_;
  27.     $clength = $ENV{'CONTENT_LENGTH'} if $clength == 0;
  28.     undef my $output;
  29.     my $type = $ENV{'CONTENT_TYPE'}; my $boundary = ""; my $len = 0;
  30.     my $input = ""; my $counter = 0;
  31.     binmode(STDIN);
  32.     if ($type =~ /boundary=(.*)/) {
  33.         $boundary = join("--" , $1);
  34.     } else {
  35.         error_message("Upload Error", "Your browser did not properly encode this form.", 0, 1);
  36.     }
  37.     while ($len < $clength) {
  38.         my $buf = "";
  39.         $len += sysread(STDIN, $buf, $clength);
  40.         $input .= $buf;
  41.         $counter += 1;
  42.         $counter = 0 if $buf ne "";
  43.         error_message("Upload Error", "The upload timed out after reading $len of $clength bytes.  Please try again by hitting your browser's RELOAD button.", 0, 1) if $counter >= 100;
  44.     }
  45.     my @input_pairs = split(/$boundary/, $input);
  46.     my $formname = "";
  47.     my $filename = "";
  48.     foreach my $line (@input_pairs) {
  49.         my ($header, $body) = split(/\r\n\r\n|\n\n/, $line, 2);
  50.         $body =~ s/\r\n-*$//;
  51.         if ($header =~ /name="([^"]+)"/) { $formname = $1; } else { $formname = ""; }
  52.         if ($header =~ /filename="([^"]+)"/) { $filename = $1; } else { $filename = ""; }
  53.         if ($header =~ /Type: (.*)/) {
  54.             $output->{'*files*'}->{$formname}->{content_type} = $1;
  55.             $output->{'*files*'}->{$formname}->{filename} = parse_filename($filename);
  56.             $output->{'*files*'}->{$formname}->{data} = $body;
  57.         } elsif ($header =~ m|filename="|) {
  58.             $output->{'*files*'}->{$formname}->{content_type} = "mac/unknown";
  59.             $output->{'*files*'}->{$formname}->{filename} = parse_filename($filename);
  60.             $output->{'*files*'}->{$formname}->{data} = $body;
  61.         } elsif ($formname =~ /^(\w+)$/) {
  62.             $output->{$formname} .= ",$body" if $output->{$formname} ne "";
  63.             $output->{$formname} = $body if $output->{$formname} eq "";
  64.             $output->{$formname} =~ s/\r//g;
  65.         }
  66.         $output->{'*files*'}->{$formname}->{content_type} = $` if $output->{'*files*'}->{$formname}->{content_type} =~ /;/;
  67.     }
  68.     my $cbuffer = $ENV{'HTTP_COOKIE'};
  69.     if ($ENV{'HTTP_COOKIE'} eq "" && $ENV{'COOKIE'} ne "") {
  70.         $cbuffer = $ENV{'COOKIE'};  #O'Reilly WebSitePro
  71.     }
  72.     my @cpairs = split(/; /, $cbuffer);
  73.     foreach my $cpair (@cpairs) {
  74.         my ($cname, $cvalue) = split(/=/, $cpair);
  75.         $cname =~ s/$DCONF->{COOKIE_ID}$//;
  76.         $output->{'COOKIE'}->{$cname} = unescape($cvalue);
  77.     }
  78.     return $output;
  79. }
  80.  
  81. ###
  82. ### parse_filename
  83. ###
  84. ### Cleans up file names from various operating systems
  85. ###
  86.  
  87. sub parse_filename {
  88.     my ($line_in) = @_;
  89.     if ($line_in =~ m|^(\w+):\\|) {
  90.         $line_in =~ m|(.*)\\|;
  91.         return $';
  92.     }
  93.     if ($line_in =~ m|^/|) {
  94.         $line_in =~ m|(.*)/|;
  95.         return $';
  96.     }
  97.     if ($line_in =~ m|:|) {
  98.         $line_in =~ m|(.*):|;
  99.         return $';
  100.     }
  101.     return $line_in;
  102. }
  103.  
  104. ###
  105. ### multipart_post_upload_control
  106. ###
  107. ### Controls image/attachment uploading features
  108. ###
  109.  
  110. sub multipart_post_upload_control {
  111.     my ($FORMref, $dir_override, $cancel) = @_;
  112.     my $p = post_read_image_tempfile($FORMref->{tempfile});
  113.     if ($p->{var}->{ip} ne $ENV{REMOTE_ADDR} && $GLOBAL_OPTIONS->{images_require_ip_match}) {
  114.         error_message("Upload Security Violation", "Your IP address does not match the IP address from which this message was posted.", 0, 1);
  115.     }
  116.     dreq("mime-PRO") if $DCONF->{pro};
  117.     my @result = ();
  118.     my $errors = scalar @{$p->{upload}};
  119.     my $ctr = 0;
  120.     my @new_x = ();
  121.     my @nf = @{ $p->{fragment} };
  122.     foreach my $u (@{ $p->{upload} }) {
  123.         $ctr++;
  124.         my $f = shift @nf;
  125.         my $q = $FORMref->{'*files*'}->{"attach$ctr"};
  126.         if (defined $q) {
  127.             my $type = post_get_extension_and_tag($q->{content_type}, $u->{type} eq 'i' ? 1 : 0, $q->{filename});
  128.             if (! defined $type) {
  129.                 push @result, { descr => $u->{descr}, error => 2 };
  130.                 push (@new_x, { f => $f } );
  131.                 push (@new_x, { u => $u } );
  132.                 next;
  133.             }
  134.             my $fi = $type->{fi};
  135.             my $maxs = post_is_upload_too_large($p->{var}->{author_status}, length($q->{data}));
  136.             my $height = 0;
  137.             my $width = 0;
  138.             if ($DCONF->{pro} && $fi) {
  139.                 dreq("upload-PRO");
  140.                 ($width, $height) = post_is_upload_too_large_vpr_dimension($p->{var}->{author_status}, $q->{data});
  141.             }
  142.             if ($width != 0 || $height != 0) {
  143.                 push (@result, { descr => $u->{descr}, error => 6, width => $width, height => $height });
  144.             } elsif (length($q->{data}) == 0) {
  145.                 push @result, { descr => $u->{descr}, error => 3 };
  146.             } elsif (! defined $type) {
  147.                 push @result, { descr => $u->{descr}, content => $q->{content_type}, error => 2 };
  148.             } elsif ($maxs != 0) {
  149.                 push (@result, { descr => $u->{descr}, error => 4, maxsize => $maxs, yoursize => sprintf("%.1f", length($q->{data})/1000) });
  150.             } else {
  151.                 my $psua = post_save_uploaded_attachment($q, $q->{content_type}, $fi, $p->{tempfile}, $u->{descr}, $type);
  152.                 if (! $psua) {
  153.                     push @result, { descr => $u->{descr}, error => 5 };
  154.                 } else {
  155.                     $errors -= 1;
  156.                     my $newtag = join("", "\\", $type->{tag}, "{", $psua, "}");
  157.                     push @new_x, { f => join("", $f, $newtag ) };
  158.                     next;
  159.                 }
  160.             }
  161.             push (@new_x, { f => $f } );
  162.             push (@new_x, { u => $u } );
  163.         } else {
  164.             push @result, { descr => $u->{descr}, error => 1 };
  165.             push (@new_x, { f => $f } );
  166.             push (@new_x, { u => $u } );
  167.         }
  168.     }
  169.     while (my $l = shift @nf) {
  170.         push (@new_x, { f => $l });
  171.     }
  172.     if (! $errors) {
  173.         my $src = "";
  174.         while (my $u = shift @new_x) {
  175.             $src .= $u->{f};
  176.         }
  177.         my $tf = $p->{tempfile};
  178.         my $dir = (-e "$DCONF->{message_dir}/$p->{var}->{topic_number}" ? "$DCONF->{message_dir}/$p->{var}->{topic_number}" : "$DCONF->{secdir}/$p->{var}->{topic_number}");
  179.         $dir = "$DCONF->{admin_dir}/queue" if $p->{var}->{queued} == 1;
  180.         $dir = $dir_override if $dir_override ne "";
  181.         opendir(DIR, "$DCONF->{admin_dir}/msg_index/uploads");
  182.         while (my $i = readdir(DIR)) {
  183.             if ($i =~ m|\-$tf$|) {
  184.                 my $fn = $`;
  185.                 open (FILE, "$DCONF->{admin_dir}/msg_index/uploads/$fn-$tf");
  186.                 binmode(FILE);
  187.                 open (DEST, "> $dir/$fn");
  188.                 binmode(DEST);
  189.                 while (<FILE>) {
  190.                     print DEST;
  191.                 }
  192.                 close (DEST);
  193.                 close (FILE);
  194.                 chmod(oct($DCONF->{perms0666}), "$dir/$fn");
  195.                 unlink "$DCONF->{admin_dir}/msg_index/uploads/$fn-$tf";
  196.             }
  197.         }
  198.         close (DIR);
  199.         if ($p->{var}->{queued} && $DCONF->{pro}) {
  200.             dreq("queue1-PRO");
  201.             return queue_finished_upload($p, $src);
  202.         }
  203.         dreq("webtags");
  204.         $PARAMS->{topic_number} = $p->{var}->{topic_number};
  205.         my $GP = GetPage($p->{var}->{topic_number}, $p->{var}->{pagenum}, { lock => 1 });
  206.         foreach my $u (@{ $GP->{messages} }) {
  207.             if ($u->{number} == $p->{var}->{postnum}) {
  208.                 my ($foo, $txt) = webtags($src, 0, 1, 1, 1);
  209.                 while ($txt =~ /alt="([^"]*?)<.*?>([^"]*)"/i) {
  210.                     my ($bef, $one, $two, $aft) = ($`, $1, $2, $');
  211.                     $one =~ s/&#?(\w+);/-/g; $two =~ s/&#?(\w+);/-/g;
  212.                     $txt = join("", $bef, "alt=", '"', $one, $two, '"', $aft);
  213.                 }
  214.                 $u->{text} = $txt;
  215.             }
  216.         }
  217.         $GP->{general}->{messages_raw} = 0;
  218.         SetPage($GP, { unlock => 1 });
  219.         unlink "$DCONF->{admin_dir}/msg_index/temp/$tf.TMP";
  220.         seturl(post_get_result_url($p->{var}));
  221.     }
  222.     post_rewrite_temp_file($p, \@new_x);
  223.     undef my $subst;
  224.     $subst->{attachments} = \@result;
  225.     $subst->{general}->{tempfile} = $FORMref->{tempfile};
  226.     return \@result if $cancel;
  227.     screen_out("upload", $subst);
  228. }
  229.  
  230. ###
  231. ### post_format_attachment_file
  232. ###
  233. ### Gets a file name for the attachment in question
  234. ###
  235.  
  236. sub post_format_attachment_file {
  237.     my ($attachment_info, $content_type, $fi, $descr, $ct) = @_;
  238.     if ($fi) {
  239.         my $gn = get_number();
  240.         my $td = join(",", $gn, $descr);
  241.         return { tagfile => $td, filename => join(".", $gn, $ct->{ext}) };
  242.     }
  243.     return mime_format_file($attachment_info, $content_type, $descr);
  244. }
  245.  
  246. ###
  247. ### post_read_image_tempfile
  248. ###
  249. ### Reads an image/attachment temporary file into a handy format
  250. ###
  251.  
  252. sub post_read_image_tempfile {
  253.     my ($tempfile) = @_;
  254.     $tempfile =~ s/\D//g;
  255.     my $u = readfile("$DCONF->{admin_dir}/msg_index/temp/$tempfile.TMP", "post_read_image_tempfile");
  256.     undef my $r;
  257.     $r->{tempfile} = $tempfile;
  258.     foreach my $x (@{ $u }) {
  259.         if ($x =~ m|^(\w+)=(.*)|) {
  260.             $r->{var}->{$1} = unescape($2);
  261.         } elsif ($x =~ m|^=\[f\](.*)|) {
  262.             push (@{ $r->{fragment} }, unescape($1));
  263.         } elsif ($x =~ m|^=\[u\](.*)|) {
  264.             my @y = split(/&/, $1);
  265.             undef my $h;
  266.             foreach my $l (@y) {
  267.                 if ($l =~ m|(\w+)=>(.*)|) {
  268.                     $h->{$1} = unescape($2);
  269.                 }
  270.             }
  271.             push (@{ $r->{upload} }, $h);
  272.         }
  273.     }
  274.     return $r;
  275. }
  276.  
  277. ###
  278. ### post_get_extension_and_tag
  279. ###
  280. ### Gets the extension and corresponding formatting tag for a file
  281.  
  282. sub post_get_extension_and_tag {
  283.     my ($mime_type, $force_image, $filename) = @_;
  284.     if ($GLOBAL_OPTIONS->{upload_thumbnails_gifs}) {
  285.         return { fi => 1, ext => "gif", tag => "image_alreadyuploaded_t" } if $mime_type eq "image/gif";
  286.     } else {
  287.         return { fi => 1, ext => "gif", tag => "image_alreadyuploaded" } if $mime_type eq "image/gif";
  288.     }
  289.     if ($GLOBAL_OPTIONS->{upload_thumbnails_jpegs}) {
  290.         return { fi => 1, ext => "jpg", tag => "jpeg_alreadyuploaded_t" } if $mime_type =~ m|^image/p?jpeg$|;
  291.     } else {
  292.         return { fi => 1, ext => "jpg", tag => "jpeg_alreadyuploaded" } if $mime_type =~ m|^image/p?jpeg$|;
  293.     }
  294.     if ($GLOBAL_OPTIONS->{upload_thumbnails_pngs}) {
  295.         return { fi => 1, ext => "png", tag => "png_alreadyuploaded_t" } if $mime_type eq "image/x-png";
  296.         return { fi => 1, ext => "png", tag => "png_alreadyuploaded_t" } if $mime_type eq "image/png";
  297.     } else {
  298.         return { fi => 1, ext => "png", tag => "png_alreadyuploaded" } if $mime_type eq "image/x-png";
  299.         return { fi => 1, ext => "png", tag => "png_alreadyuploaded" } if $mime_type eq "image/png";
  300.     }
  301.     return undef if ! $DCONF->{pro};
  302.     return undef if $force_image;
  303.     dreq("mime-PRO");
  304.     return mime_file_extension_and_tag($mime_type, $filename);
  305. }
  306.  
  307. ###
  308. ### post_is_upload_too_large
  309. ###
  310. ### Compares an attachment length to the maximum limit
  311. ###
  312.  
  313. sub post_is_upload_too_large {
  314.     my ($author_status, $filesize) = @_;
  315.     my $u = 0;
  316.     return 0 if $GLOBAL_OPTIONS->{images_admin_unlimited} ne "0" && $author_status == 10;
  317.     $u = $GLOBAL_OPTIONS->{'registered_mod_maxsize'} * 1000 if $author_status >= 9;
  318.     $u = $GLOBAL_OPTIONS->{'registered_maxsize'} * 1000 if $author_status < 9 && $author_status > 2;
  319.     $u = $GLOBAL_OPTIONS->{'public_maxsize'} * 1000 if $author_status < 3;
  320.     return 0 if $u == 0;
  321.     return 0 if $filesize < $u;
  322.     return sprintf("%.1f", $u/1000);
  323. }
  324.  
  325. ###
  326. ### post_save_uploaded_attachment
  327. ###
  328. ### Saves an uploaded attachment in a temporary directory
  329. ###
  330.  
  331. sub post_save_uploaded_attachment {
  332.     my ($attachment_info, $content_type, $fi, $tempfile, $descr, $ct) = @_;
  333.     my $res = post_format_attachment_file($attachment_info, $content_type, $fi, $descr, $ct);
  334.     my $d = (defined $res->{data} ? $res->{data} : $attachment_info->{data});
  335.     if (! -d "$DCONF->{admin_dir}/msg_index/uploads") {
  336.         mkdir("$DCONF->{admin_dir}/msg_index/uploads", oct($DCONF->{perms0777})) || error_message("Create Directory Error", "Could not create 'uploads' directory under 'msg_index'.  Post with image/attachments failed.");
  337.         chmod(oct($DCONF->{perms0777}), "$DCONF->{admin_dir}/msg_index/uploads");
  338.     }
  339.     if (open (FILE, "> $DCONF->{admin_dir}/msg_index/uploads/$res->{filename}-$tempfile")) {
  340.         binmode(FILE);
  341.         print FILE $d;
  342.         close (FILE);
  343.         return $res->{tagfile};
  344.     }
  345.     return undef;
  346. }
  347.  
  348. ###
  349. ### post_rewrite_temp_file
  350. ###
  351. ### Rewrites a temporary file for image uploading
  352. ###
  353.  
  354. sub post_rewrite_temp_file {
  355.     my ($p, $new_x) = @_;
  356.     my @d = ();
  357.     my $fcache = undef;
  358.     foreach my $k (keys(%{ $p->{var} })) {
  359.         push @d, "$k=" . escape($p->{var}->{$k}) . "\n";
  360.     }
  361.     foreach my $l (@{ $new_x }) {
  362.         if (defined $l->{f}) {
  363.             $fcache .= $l->{f};
  364.         } else {
  365.             push @d, "=[f]" . escape($fcache) . "\n";
  366.             my $line = "=[u]";
  367.             foreach my $ll (keys(%{ $l->{u} })) {
  368.                 $line .= "&$ll=>" . escape($l->{u}->{$ll});
  369.             }
  370.             $line .= "\n";
  371.             push @d, "$line";
  372.             $fcache = undef;
  373.         }
  374.     }
  375.     push @d, "=[f]" . escape($fcache) . "\n" if $fcache;
  376.     my $tempfile = $p->{tempfile};
  377.     writefile("$DCONF->{admin_dir}/msg_index/temp/$tempfile.TMP", \@d, "post_rewrite_temp_file");
  378. }
  379.  
  380. 1;
  381.