mourningdove/cgi-bin/DW/Controller/EditIcons.pm

1013 lines
34 KiB
Perl
Raw Normal View History

2026-05-24 01:03:05 +00:00
#!/usr/bin/perl
#
# DW::Controller::EditIcons
#
# This controller is for creating and managing icons.
#
# Authors:
# Mark Smith <mark@dreamwidth.org>
# Jen Griffin <kareila@livejournal.com>
#
# Copyright (c) 2016-2017 by Dreamwidth Studios, LLC.
#
# This program is free software; you may redistribute it and/or modify it under
# the same terms as Perl itself. For a copy of the license, please reference
# 'perldoc perlartistic' or 'perldoc perlgpl'.
#
package DW::Controller::EditIcons;
use strict;
use v5.10;
use Log::Log4perl;
my $log = Log::Log4perl->get_logger(__PACKAGE__);
use Digest::MD5;
use File::Type;
use DW::BlobStore;
use LJ::Userpic;
use LJ::Global::Constants;
use DW::Controller;
use DW::Routing;
use DW::Template;
DW::Routing->register_string( "/manage/icons", \&editicons_handler, app => 1 );
DW::Routing->register_string( "/tools/userpicfactory", \&factory_handler, app => 1 );
DW::Routing->register_string( "/misc/mogupic", \&mogupic_handler, app => 1, formats => 1 );
sub editicons_handler {
# don't automatically check form_auth: causes problems with
# processing multipart/form-data where the post arguments
# have to be parsed out of $r->uploads
my ( $ok, $rv ) = controller( authas => 1, form_auth => 0 );
return $rv unless $ok;
my $u = $rv->{u}; # authas || remote
my $r = $rv->{r}; # DW::Request
# error pages must be returned from handler context, not subroutines!
# this is basically error_ml without the implicit ML call
my $err = sub {
return DW::Template->render_template( 'error.tt', { message => $_[0] } );
};
return $err->($LJ::MSG_READONLY_USER) if $u->is_readonly;
# update this user's activated pics
$u->activate_userpics;
# get userpics and count 'em
my @userpics = LJ::Userpic->load_user_userpics($u);
# get the maximum number of icons for this user
my $max = $u->count_max_userpics;
# keep track of fatal errors vs. non-fatal/informative messages
my $errors = DW::FormErrors->new;
my @info;
if ( $r->did_post ) {
my $post = $r->post_args;
return error_ml("error.utf8") unless LJ::text_in($post);
LJ::Hooks::run_hooks( 'spam_check', $u, $post, 'icons' );
### save changes to existing pics
if ( $post->{'action:save'} ) {
# form being posted isn't multipart, so check form_auth
return error_ml('error.invalidform')
unless LJ::check_form_auth( $post->{lj_form_auth} );
my $refresh = update_userpics( $post, \@info, \@userpics, $u );
# reload the pictures to account for deleted
@userpics = LJ::Userpic->load_user_userpics($u) if $refresh;
}
unless (%$post) {
### no post data, so we'll parse the multipart data -
### this means that we have a new pic to handle.
my $size = $r->header_in("Content-Length");
return error_ml("error.editicons.contentlength") unless $size;
my $MAX_UPLOAD = LJ::Userpic->max_allowed_bytes($u);
my $parsetomogile = $size > $MAX_UPLOAD + 2048;
# array of map references
my @uploaded_userpics;
# Three possibilities here: (a) small upload, in which case we
# just parse it; (b) large upload, in which case we save the
# files to temp storage; or (c) coming from the factory.
unless ($parsetomogile) { # for options (a) and (c)
my $uploads = eval { $r->uploads }; # multipart/form-data
return $err->($@) if $@;
$post->{ $_->{name} } = $_->{body} foreach @$uploads;
# parse the post parameters into an array of new pics
@uploaded_userpics = parse_post_uploads( $post, $u, $MAX_UPLOAD );
LJ::Hooks::run_hooks( 'spam_check', $u, $post, 'icons' );
}
# if we're (c) coming from the factory, then we don't
# need to save the image to temporary storage again
my $used_factory = $post->{src} && $post->{src} eq 'factory';
$parsetomogile = 0 if $used_factory;
if ($parsetomogile) {
# (b) save large images to temporary storage and populate %$post
my $error;
parse_large_upload( $post, \$error, $u );
# was there an error parsing the multipart form?
return $err->($error) if $error;
# parse the post parameters into an array of new pics
@uploaded_userpics = parse_post_uploads( $post, $u, $MAX_UPLOAD );
}
elsif ($used_factory) {
# (c) parse the data submitted from the factory
my $scaledsizemax = $post->{'scaledSizeMax'};
my ( $x1, $x2, $y1, $y2 ) = map { $_ + 0 } @$post{qw( x1 x2 y1 y2 )};
return error_ml("error.editicons.parse.factory")
unless $scaledsizemax && $x2;
my $picinfo = eval {
LJ::Userpic->get_upf_scaled(
x1 => $x1,
y1 => $y1,
x2 => $x2,
y2 => $y2,
border => $post->{border},
userid => $u->userid,
mogkey => mogkey( $u, $post->{index} ),
);
};
return error_ml( "error.editicons.get_upf_scaled", { err => $@ } )
unless $picinfo;
# create image data hash for userpic array
my %current_upload = (
key => 'userpic_0',
image => \${ $picinfo->[0] },
index => 0,
);
$current_upload{$_} = $post->{$_}
foreach qw/ keywords default comments descriptions make_default /;
push @uploaded_userpics, \%current_upload;
}
# throw an error if @uploaded_userpics is still empty
return error_ml(
$post->{src}
? "error.editicons.empty." . $post->{src}
: "error.editicons.parse.nodata"
) unless @uploaded_userpics;
# count how many icons the user already has
my $userpic_count = scalar @userpics;
my $factory_redirect;
my $success_count = 0;
my $index_sort = sub { $a->{index} cmp $b->{index} };
my $current_index = 0;
my $message_prefix = sub {
my $idx = $_[0];
return "" unless scalar @uploaded_userpics > 1;
return LJ::Lang::ml( "/edit/icons.tt.icon.msgprefix", { num => $idx } ) . " ";
};
# go through each userpic and try to create it
foreach my $cur_upload_ref ( sort $index_sort @uploaded_userpics ) {
$current_index++;
my %current_upload = %$cur_upload_ref;
## see if they are trying to go over their limit
if ( $userpic_count >= $max ) {
$errors->add( undef, "error.editicons.toomanyicons", { num => $max } );
last;
}
my $mp = $message_prefix->($current_index);
my $err_add = sub { $errors->add_string( undef, $mp . $_[0] ) };
my $info_add = sub { push( @info, $mp . $_[0] ) };
if ( $current_upload{error} ) {
# error returned from parse_post_uploads
$err_add->( $current_upload{error} );
next;
}
if ( $current_upload{requires_factory} ) {
$factory_redirect = factory_prepare( \%current_upload, $u );
# go ahead and add this error message to @info; it
# will get displayed only if we can't do the redirect.
$info_add->( LJ::Lang::ml("error.editicons.toolarge") );
next;
}
# save this userpic
my $userpic = eval { LJ::Userpic->create( $u, data => $current_upload{image} ); };
if ( !$userpic ) {
$@ = $@->as_html if $@->isa('LJ::Error');
$err_add->($@);
}
else {
$info_add->( LJ::Lang::ml("/edit/icons.tt.upload.success") );
$success_count++;
set_userpic_info( $userpic, \%current_upload );
$userpic_count++;
}
}
# yay we (probably) created new pics, reload the @userpics
@userpics = LJ::Userpic->load_user_userpics($u);
# did we designate an image to redirect to the factory?
if ( $factory_redirect && !$errors->exist ) {
$factory_redirect->{successcount} = $success_count
if $success_count;
return $r->redirect(
LJ::create_url(
"/tools/userpicfactory",
keep_args => ['authas'],
args => $factory_redirect
)
);
}
}
# make the processed post data accessible to the template
# in case there was an error and they need to resubmit
$rv->{formdata} = $post if $errors->exist;
}
# finished post processing
$rv->{errors} = $errors;
$rv->{messages} = \@info;
my $args = $r->get_args;
$rv->{sort_by_kw} = $args->{'keywordSort'} ? 1 : 0;
$rv->{selflink} = sub {
my $want_kw = $_[0] // $args->{'keywordSort'};
my $keyword_sort = $want_kw ? { 'keywordSort' => 1 } : {};
return LJ::create_url(
"/manage/icons",
keep_args => ['authas'],
args => $keyword_sort
);
};
$rv->{icons} =
$args->{'keywordSort'}
? [ LJ::Userpic->sort( \@userpics ) ]
: \@userpics;
$rv->{num_icons} = scalar @userpics;
$rv->{max_icons} = $max;
# Check for default userpic keywords
foreach my $pic (@userpics) {
if ( substr( $pic->keywords, 0, 4 ) eq "pic#" ) {
$rv->{uses_default_keywords} = 1;
last;
}
}
$rv->{display_rename} = LJ::is_enabled("icon_renames") ? 1 : 0;
$rv->{help_icon} = sub { LJ::help_icon_html(@_) };
$rv->{alttext_faq} = sub { LJ::Hooks::run_hook( 'faqlink', 'alttext', $_[0] ) };
$rv->{maxlength} = {
comment => LJ::CMAX_UPIC_COMMENT,
description => LJ::CMAX_UPIC_DESCRIPTION
};
return DW::Template->render_template( 'edit/icons.tt', $rv );
}
sub factory_handler {
my ( $ok, $rv ) = controller( authas => 1 );
return $rv unless $ok;
my $u = $rv->{u}; # authas || remote
my $args = $rv->{r}->get_args;
my $w = int( $args->{'imageWidth'} // 0 );
my $h = int( $args->{'imageHeight'} // 0 );
my $mogkey = mogkey( $u, $args->{index} );
# make sure index is given and points to a valid file
my $has_index = defined $args->{index} && length $args->{index} ? 1 : 0;
$has_index &&= DW::BlobStore->exists( temp => $mogkey );
$rv->{no_index} = $has_index ? 0 : 1;
if ( $has_index && !( $w && $h ) ) {
# we do not have the width and height passed in, must compute it
my $upf = LJ::Userpic->get_upf_scaled(
userid => $u->id,
mogkey => $mogkey
);
( $w, $h ) = ( $upf->[2], $upf->[3] )
if $upf && $upf->[2];
}
$rv->{upf_w} = $w;
$rv->{upf_h} = $h;
$rv->{scaledSizeMax} = 640;
$rv->{successcount} = $args->{successcount};
my %keepargs =
map { $_ => $args->{$_} } qw( keywords comments descriptions make_default index );
$rv->{form_keepargs} = LJ::html_hidden(%keepargs);
return DW::Template->render_template( 'tools/userpicfactory.tt', $rv );
}
sub mogupic_handler {
my ( $ok, $rv ) = controller( authas => 1 );
return $rv unless $ok;
my $u = $rv->{u}; # authas || remote
my $r = $rv->{r}; # DW::Request
my $args = $r->get_args;
return $r->FORBIDDEN
unless $r->header_in("Referer") # can't load page directly
&& LJ::check_referer('/tools/userpicfactory');
my $mogkey = mogkey( $u, $args->{index} );
my $size = int( $args->{size} // 0 );
$size = 640 if $size <= 0 || $size > 640;
my $upf = LJ::Userpic->get_upf_scaled(
size => $size,
userid => $u->id,
mogkey => $mogkey
);
return $r->NOT_FOUND unless $upf;
my $blob = $upf->[0];
my $mime = $upf->[1];
# return the image
$r->content_type($mime);
$r->print($$blob);
return $r->OK;
}
sub mogkey {
my ( $u, $index ) = @_;
$log->logcroak("No user given") unless LJ::isu($u);
my $key = 'upf';
$key .= "_$index" if defined $index && length $index;
$key .= ':' . $u->id;
return $key;
}
sub set_userpic_info {
my ( $userpic, $upload ) = @_;
$userpic->make_default if $upload->{make_default};
$userpic->set_keywords( $upload->{keywords} )
if defined $upload->{keywords};
$userpic->set_comment( $upload->{comments} )
if $upload->{comments};
$userpic->set_description( $upload->{descriptions} )
if $upload->{descriptions};
$userpic->set_fullurl( $upload->{url} ) if $upload->{url};
}
# prepare to send a particular upload to the factory
sub factory_prepare {
my ( $upload, $u ) = @_;
# save the file
DW::BlobStore->store(
temp => mogkey( $u, $upload->{index} ),
$upload->{image}
);
# save the arguments for the factory URL
my $args = {
imageWidth => $upload->{imagew},
imageHeight => $upload->{imageh}
};
$args->{$_} = $upload->{$_} foreach qw/ keywords comments descriptions
make_default index /;
return $args;
}
# save changes to existing userpics
sub update_userpics {
my ( $POST, $errors, $userpicsref, $u ) = @_;
my @userpics = @$userpicsref;
my $display_rename = LJ::is_enabled("icon_renames") ? 1 : 0;
my @delete; # userpic objects to delete
my @inactive_picids;
my %picid_of_kwid;
my %used_keywords;
# we need to count keywords based on what the user provided, in order
# to find duplicates. $up->keywords doesn't work, because re-using a
# keyword will remove it from the other userpic without our knowing
my $count_keywords = sub {
my $kwlist = $_[0];
$used_keywords{$_}++ foreach split( /,\s*/, $kwlist );
};
foreach my $up (@userpics) {
my $picid = $up->id;
# delete this pic
if ( $POST->{"delete_$picid"} ) {
push @delete, $up;
next;
}
# we're only going to modify keywords/comments on active pictures
if ( $up->inactive || $POST->{"pic_inactive_$picid"} ) {
# use 'orig' because we don't POST disabled fields
$count_keywords->( $POST->{"kw_orig_$picid"} );
next;
}
$count_keywords->( $POST->{"kw_$picid"} );
# only modify if changing the data, make sure not colliding with other edits, etc
if ( $POST->{"kw_$picid"} ne $POST->{"kw_orig_$picid"} ) {
my $kws = $POST->{"kw_$picid"};
if ( $POST->{"rename_keyword_$picid"} ) {
if ( $display_rename && $u->userpic_have_mapid ) {
eval { $up->set_and_rename_keywords( $kws, $POST->{"kw_orig_$picid"} ); }
or push @$errors, $@->as_html;
}
else {
push @$errors, LJ::Lang::ml('error.iconkw.rename.disabled');
}
}
else {
eval { $up->set_keywords($kws); } or push @$errors, $@->as_html;
}
}
eval {
$up->set_comment( $POST->{"com_$picid"} )
unless ( $POST->{"com_$picid"} // '' ) eq ( $POST->{"com_orig_$picid"} // '' );
} or push @$errors, $@;
eval {
$up->set_description( $POST->{"desc_$picid"} )
unless ( $POST->{"desc_$picid"} // '' ) eq ( $POST->{"desc_orig_$picid"} // '' );
} or push @$errors, $@;
}
foreach my $kw ( keys %used_keywords ) {
next unless $used_keywords{$kw} > 1;
push @$errors, LJ::Lang::ml( 'error.iconkw.rename.multiple', { ekw => $kw } );
}
if (@delete) {
# delete pics
foreach my $up (@delete) {
eval { $up->delete; } or push @$errors, $@;
}
# if any of the userpics they want to delete are active, then we want to
# re-run activate_userpics() - turns out it's faster to not check to
# see if we need to do this
$u->activate_userpics;
}
my $new_default = $POST->{'defaultpic'} + 0;
if ( $POST->{"delete_${new_default}"} ) {
# deleting default
$new_default = 0;
}
if ( $new_default && $new_default != $u->{'defaultpicid'} ) {
my ($up) = grep { $_->id == $new_default } @userpics;
# see if they are trying to make an inactive userpic their default
if ( $up && !$up->inactive ) {
$up->make_default;
}
}
elsif ( $new_default eq '0' && $u->{'defaultpicid'} ) {
# selected the "no default picture" option
$u->update_self( { defaultpicid => 0 } );
$u->{'defaultpicid'} = 0;
}
return scalar @delete;
}
# parse the post parameters into an array of new pics
sub parse_post_uploads {
my ( $POST, $u, $MAX_UPLOAD ) = @_;
my @uploads;
# if we find a userpic that requires the factory, save it here.
# we can only have one.
my $requires_factory;
# go through each key and create a %current_upload for it, then
# put it in @uploads.
foreach my $userpic_key ( keys %$POST ) {
next unless $userpic_key =~ /^(?:userpic|urlpic)_\d+$/;
my @tokens = split( /_/, $userpic_key );
my $counter = $tokens[1];
my $make_default = $POST->{make_default} // '';
my %current_upload = (
comments => $POST->{"comments_$counter"},
descriptions => $POST->{"descriptions_$counter"},
index => $counter,
key => $userpic_key,
keywords => $POST->{"keywords_$counter"},
make_default => $make_default eq $counter,
);
# check input text for comments, descriptions, and keywords
unless ( LJ::text_in( \%current_upload ) ) {
$current_upload{error} = LJ::Lang::ml("error.utf8");
push @uploads, \%current_upload;
next;
}
# uploaded pics
if ( $userpic_key =~ /userpic_.*/ ) {
# only use userpic_0 if we selected file for the source
next if $userpic_key eq "userpic_0" && $POST->{"src"} ne "file";
# Some callers to the function pass data, others pass
# a reference to data. Figure out which type we got.
$current_upload{image} =
ref $POST->{$userpic_key}
? $POST->{$userpic_key}
: \$POST->{$userpic_key};
my $size = length ${ $current_upload{image} };
if ( $size == 0 ) {
$current_upload{error} = LJ::Lang::ml('error.editicons.empty.file');
push @uploads, \%current_upload;
next;
}
my ( $imagew, $imageh, $filetype ) =
Image::Size::imgsize( $current_upload{image} );
# couldn't parse the file
if ( !$imagew || !$imageh ) {
$current_upload{error} = LJ::Lang::ml(
'error.editicons.unsupportedtype',
{
filetype => $filetype,
}
);
# file is too big, no matter what.
}
elsif ( $imagew > 5000 || $imageh > 5000 ) {
$current_upload{error} = LJ::Lang::ml('error.editicons.dimstoolarge');
# let's try to use the factory
}
elsif ( int($imagew) > 100 || int($imageh) > 100 || $size > $MAX_UPLOAD ) {
# file wrong type for factory
if ( $filetype ne 'JPG' && $filetype ne 'PNG' ) {
# factory only works on jpegs and pngs
# because Image::Magick has issues
if ( int($imagew) > 100 || int($imageh) > 100 ) {
$current_upload{error} = LJ::Lang::ml('error.editicons.giffiledimensions');
}
else {
$current_upload{error} = LJ::Lang::ml(
'error.editicons.filetoolarge',
{
maxsize => int( $MAX_UPLOAD / 1024 ),
}
);
}
# if it's the right size, just too large a file,
# see if we can resize it down
}
elsif ( $imagew <= 100 && $imageh <= 100 ) {
# have to store the file, this is the interface that
# the userpic factory uses to get files between
# the N different web processes you might talk to
my $mogkey = mogkey( $u, $counter );
my $rv = DW::BlobStore->store(
temp => $mogkey,
$current_upload{image}
);
unless ($rv) {
$current_upload{error} = LJ::Lang::ml('error.editicons.blobstore');
push @uploads, \%current_upload;
next;
}
eval {
my $picinfo = LJ::Userpic->get_upf_scaled(
mogkey => $mogkey,
size => 100,
u => $u,
);
# success! don't go to the factory, and
# pretend the user just uploaded the file
# and continue on normally
$current_upload{image} = $picinfo->[0];
};
if ( $@ || length ${ $current_upload{image} } > $MAX_UPLOAD ) {
$current_upload{error} = LJ::Lang::ml(
'error.editicons.filetoolarge',
{
maxsize => int( $MAX_UPLOAD / 1024 ),
}
);
}
# this is a candidate for the userpicfactory.
}
else {
# we can only do a single pic in the factory, so if there are two,
# then error out for both.
if ($requires_factory) {
$requires_factory->{error} = $current_upload{error} =
LJ::Lang::ml('error.editicons.multipleresize');
$requires_factory->{requires_factory} = 0;
}
else {
$current_upload{requires_factory} = 1;
$current_upload{imageh} = $imageh;
$current_upload{imagew} = $imagew;
if ( $POST->{"spool_data_$counter"} ) {
$current_upload{spool_data} = $POST->{"spool_data_$counter"};
}
$requires_factory = \%current_upload;
}
}
}
push @uploads, \%current_upload;
}
elsif ( $userpic_key =~ /urlpic_.*/ ) {
# go through the URL uploads
next if $userpic_key eq "urlpic_0" && $POST->{src} ne "url";
if ( !$POST->{$userpic_key} ) {
$current_upload{error} = LJ::Lang::ml('error.editicons.empty.url');
}
elsif ( $POST->{$userpic_key} !~ /^https?:\/\// ) {
$current_upload{error} = LJ::Lang::ml('error.editicons.url.format');
}
else {
my $ua = LJ::get_useragent(
role => 'userpic',
max_size => $MAX_UPLOAD + 1024,
timeout => 10,
);
my $res = $ua->get( $POST->{$userpic_key} );
$current_upload{image} = \$res->content
if $res && $res->is_success;
$current_upload{error} = LJ::Lang::ml('error.editicons.url.fetch')
unless $current_upload{image};
$current_upload{error} = LJ::Lang::ml('error.editicons.url.filetoolarge')
if $current_upload{image}
&& length ${ $current_upload{image} } > $MAX_UPLOAD;
$current_upload{url} = $POST->{$userpic_key};
}
push @uploads, \%current_upload;
}
}
return @uploads;
}
# save large images to temporary storage and populate post parameters
sub parse_large_upload {
my ( $POST, $errref, $u ) = @_;
my %upload = (); # { spool_data, spool_file_name, filename, bytes, md5sum, md5ctx, mime }
my @uploaded_files = ();
my $curr_name;
# subref to set $$errref and return false
my $err = sub { $$errref = LJ::Lang::ml(@_); return 0 };
# called when the beginning of an upload is encountered
my $hook_newheaders = sub {
my ( $name, $filename ) = @_;
$curr_name = $name;
$POST->{$curr_name} = '';
return 1 unless $curr_name =~ /userpic.*/;
# new file, need to create a filehandle, etc
%upload = ();
$upload{filename} = $filename;
$upload{md5ctx} = new Digest::MD5;
my @tokens = split( /_/, $curr_name );
my $counter = $tokens[1];
$upload{spool_file_name} = mogkey( $u, $counter );
$upload{spool_data} = '';
push @uploaded_files, $upload{spool_file_name};
return 1;
};
# called as data is received
my $hook_data = sub {
my ( $len, $data ) = @_;
unless ( $curr_name =~ /userpic.*/ ) {
$POST->{$curr_name} .= $data;
return 1;
}
# check that we've not exceeded the max read limit
my $max_read = ( 1 << 20 ) * 5; # 5 MiB
$upload{bytes} += $len;
if ( $upload{bytes} > $max_read ) {
return $err->(
"error.editicons.parse.maxread",
{ max_read => $max_read, bytes => $upload{bytes} }
);
}
$upload{md5ctx}->add($data);
$upload{spool_data} .= $data;
return 1;
};
# called when the end of an upload is encountered
my $hook_enddata = sub {
return 1 unless $curr_name =~ /userpic.*/;
# since we've just finished a potentially slow upload, we need to
# make sure the database handles in DBI::Role's cache haven't expired,
# so we'll just trigger a revalidation now so that subsequent database
# calls will be safe.
$LJ::DBIRole->clear_req_cache();
# don't try to operate on 0-length spoolfiles
unless ( $upload{bytes} ) {
%upload = ();
return 1;
}
unless ( length $upload{spool_data} > 0 ) {
return $err->("error.editicons.parse.nosize");
}
# Get MIME type from magic bytes
$upload{mime} = File::Type->new->mime_type( $upload{spool_data} );
unless ( $upload{mime} ) {
return $err->("error.editicons.parse.unknowntype");
}
# finished adding data for md5, create digest (but don't destroy original)
$upload{md5sum} = $upload{md5ctx}->digest;
$POST->{$curr_name} = \$upload{spool_data};
return 1;
};
# parse multipart-mime submission, one chunk at a time, calling
# our hooks as we go to put uploads in temporary file storage
my $retval = eval {
parse_multipart_interactive(
$errref,
{
newheaders => $hook_newheaders,
data => $hook_data,
enddata => $hook_enddata,
}
);
};
unless ($retval) {
# if we hit a parse error, delete the uploaded files
foreach my $mogkey (@uploaded_files) {
DW::BlobStore->delete( temp => $mogkey );
}
# $errref is already set by parse_multipart_interactive
return 0;
}
return $retval;
}
sub parse_multipart_interactive {
my ( $errref, $hooks ) = @_;
my $apache_r = DW::Request->get;
# subref to set $@ and $$errref, then return false
my $err = sub { $$errref = $@ = $_[0]; return 0 };
my $run_hook = sub {
my $name = shift;
my $ret = eval { $hooks->{$name}->(@_) };
return $err->($@) if $@;
# return a default hook error if the hook didn't set $$errref
return $err->( $$errref ? $$errref : "Hook: '$name' returned false" )
unless $ret;
return 1;
};
my $mimetype = $apache_r->header_in("Content-Type");
my $size = $apache_r->header_in("Content-length");
unless ( $mimetype =~ m!^multipart/form-data;\s*boundary=(\S+)! ) {
return $err->( LJ::Lang::ml( "error.editicons.parse.boundary", { type => $mimetype } ) );
}
my $sep = "--$1";
my $seplen = length($sep) + 2; # plus \r\n
my $window = '';
my $to_read = $size;
my $max_read = 8192;
my $seen_chunk = 0; # have we seen any chunk yet?
my $state = 0; # what we last parsed
# 0 = nothing (looking for a separator)
# 1 = separator (looking for headers)
# 0 = headers (looking for data)
# 0 = data (looking for a separator)
while (1) {
my $read = -1;
if ($to_read) {
$read = $apache_r->read( $window, $to_read < $max_read ? $to_read : $max_read,
length($window) );
$to_read -= $read;
# prevent loops. Opera, in particular, alerted us to
# this bug, since it doesn't upload proper MIME on
# reload and its Content-Length header is correct,
# but its body tiny
if ( $read == 0 ) {
return $err->( LJ::Lang::ml("error.editicons.parse.nodata") );
}
}
# starting case, or data-reading case (looking for separator)
if ( $state == 0 ) {
my $idx = index( $window, $sep );
# didn't find a separator. emit the previous data
# which we know for sure is data and not a possible
# new separator
if ( $idx == -1 ) {
# bogus if we're done reading and didn't find what we're
# looking for:
if ( $read == -1 ) {
return $err->(
LJ::Lang::ml( "error.editicons.parse.notfound", { what => 'separator' } ) );
}
if ($seen_chunk) {
# data hook is required
my $len = length($window) - $seplen;
$run_hook->( 'data', $len, substr( $window, 0, $len, '' ) )
or return 0;
}
next;
}
# we found a separator. emit the previous read's
# data and enddata.
if ($seen_chunk) {
my $len = $idx - 2;
if ( $len > 0 ) {
# data hook is required
$run_hook->( 'data', $len, substr( $window, 0, $len ) )
or return 0;
}
# enddata hook is required
substr( $window, 0, $idx, '' );
$run_hook->('enddata')
or return 0;
}
# we're now looking for a header
$seen_chunk = 1;
$state = 1;
# have we hit the end?
return 1 if $to_read <= 2 && length($window) <= $seplen + 4;
}
# read a separator, looking for headers
if ( $state == 1 ) {
my $idx = index( $window, "\r\n\r\n" );
if ( $idx == -1 ) {
if ( length($window) > 8192 ) {
return $err->(
LJ::Lang::ml( "error.editicons.parse.window", { len => length($window) } )
);
}
# bogus if we're done reading and didn't find what we're
# looking for:
if ( $read == -1 ) {
return $err->(
LJ::Lang::ml( "error.editicons.parse.notfound", { what => 'headers' } ) );
}
next;
}
# +4 is \r\n\r\n
my $header = substr( $window, 0, $idx + 4, '' );
my @lines = split( /\r\n/, $header );
my %hdval;
my $lasthd;
foreach (@lines) {
if (/^(\S+?):\s*(.+)/) {
$lasthd = lc($1);
$hdval{$lasthd} = $2;
}
elsif (/^\s+.+/) {
$hdval{$lasthd} .= $&;
}
}
my ( $name, $filename );
if ( $hdval{'content-disposition'} =~ /\bNAME=\"(.+?)\"/i ) {
$name = $1;
}
if ( $hdval{'content-disposition'} =~ /\bFILENAME=\"(.+?)\"/i ) {
$filename = $1;
}
# newheaders hook is required
$run_hook->( 'newheaders', $name, $filename )
or return 0;
$state = 0;
}
}
return 1;
}
1;