cgi-bin/ljuserpics.pl

   1 package LJ;
   2 use strict;
   3
   4 use Digest::MD5 qw(md5_hex);
   5 use HTTP::Request::Common qw/GET/;
   6
   7 # <LJFUNC>
   8 # name: LJ::fetch_userpic
   9 # des: Fetch source content of userpic by url or post
  10 # args: userpic, src, urlpic
  11 # return: hashref: { content, size }
  12 # </LJFUNC>
  13 sub fetch_userpic {
  14     my %args = @_;
  15
  16     my $size = 0;
  17     my $content = undef;
  18     if ($args{userpic}){
  19         ## Read uploaded image
  20         my $upload = LJ::Request->upload('userpic');
  21
  22         return { undef, -1 }
  23             unless $upload;
  24
  25         $size = $upload->size;
  26
  27         # upload image as temp file to mogileFS. this file is used in lj_upf_resize worker.
  28         seek $upload->fh, 0,0;
  29         read $upload->fh, $content, $upload->size; # read content
  30
  31         return {
  32             content => $content,
  33             size    => $upload->size,
  34         }
  35
  36     } elsif ($args{'src'} eq "url") {
  37         ## Get image somewhere from internet
  38
  39         my $ua = LJ::get_useragent(
  40                                    role     => 'userpic',
  41                                    max_size => $args{maxupload} + 1024,
  42                                    timeout  => 10,
  43                                    );
  44
  45         my $res = $ua->get($args{urlpic});
  46         if ($res && $res->is_success) {
  47             # read downloaded file
  48             $content = $res->content;
  49             $size    = length $content;
  50         }
  51
  52         return {
  53             content => $content,
  54             size    => $size,
  55         }
  56     }
  57 }
  58
  59 # <LJFUNC>
  60 # name: LJ::load_userpics
  61 # des: Loads a bunch of userpics at once.
  62 # args: dbarg?, upics, idlist
  63 # des-upics: hashref to load pictures into, keys being the picids.
  64 # des-idlist: [$u, $picid] or [[$u, $picid], [$u, $picid], +] objects
  65 #             also supports deprecated old method, of an array ref of picids.
  66 # </LJFUNC>
  67 sub load_userpics
  68 {
  69     &nodb;
  70     my ($upics, $idlist) = @_;
  71
  72     return undef unless ref $idlist eq 'ARRAY' && $idlist->[0];
  73
  74     # deal with the old calling convention, just an array ref of picids eg. [7, 4, 6, 2]
  75     if (! ref $idlist->[0] && $idlist->[0]) { # assume we have an old style caller
  76         my $in = join(',', map { $_+0 } @$idlist);
  77         my $dbr = LJ::get_db_reader();
  78         my $sth = $dbr->prepare("SELECT userid, picid, width, height " .
  79                                 "FROM userpic WHERE picid IN ($in)");
  80
  81         $sth->execute;
  82         while ($_ = $sth->fetchrow_hashref) {
  83             my $id = $_->{'picid'};
  84             undef $_->{'picid'};
  85             $upics->{$id} = $_;
  86         }
  87         return;
  88     }
  89
  90     # $idlist needs to be an arrayref of arrayrefs,
  91     # HOWEVER, there's a special case where it can be
  92     # an arrayref of 2 items:  $u (which is really an arrayref)
  93     # as well due to 'fields' and picid which is an integer.
  94     #
  95     # [$u, $picid] needs to map to [[$u, $picid]] while allowing
  96     # [[$u1, $picid1], [$u2, $picid2], [etc...]] to work.
  97     if (scalar @$idlist == 2 && ! ref $idlist->[1]) {
  98         $idlist = [ $idlist ];
  99     }
 100
 101     ## avoid requesting upic multiple times.
 102     ## otherwise memcached returns it multiple times too.
 103     ##
 104     ## don't load (non-existent) upics with negative id
 105     ## see also LJSUP-5502 and hook 'control_default_userpic'
 106     my %uniq = ();
 107     $idlist = [ grep {
 108                         my $u = $_->[0];
 109                         my $upicid = $_->[1];
 110                         $upicid>0 && not $uniq{$u}->{$upicid}++
 111                     } @$idlist ];
 112
 113     my @load_list;
 114     foreach my $row (@{$idlist})
 115     {
 116         my ($u, $id) = @$row;
 117         next unless ref $u;
 118
 119         if ($LJ::CACHE_USERPIC{$id}) {
 120             $upics->{$id} = $LJ::CACHE_USERPIC{$id};
 121         } elsif ($id+0) {
 122             push @load_list, [$u, $id+0];
 123         }
 124     }
 125     return unless @load_list;
 126
 127     if (@LJ::MEMCACHE_SERVERS) {
 128         my @mem_keys = map { [$_->[1],"userpic.$_->[1]"] } @load_list;
 129         my $mem = LJ::MemCacheProxy::get_multi(@mem_keys) || {};
 130         while (my ($k, $v) = each %$mem) {
 131             next unless $v && $k =~ /(\d+)/;
 132             my $id = $1;
 133             $upics->{$id} = LJ::MemCache::array_to_hash("userpic", $v);
 134         }
 135         @load_list = grep { ! $upics->{$_->[1]} } @load_list;
 136         return unless @load_list;
 137     }
 138
 139     my %db_load;
 140     my @load_list_d6;
 141     foreach my $row (@load_list) {
 142         # ignore users on clusterid 0
 143         next unless $row->[0]->{clusterid};
 144
 145         if ($row->[0]->{'dversion'} > 6) {
 146             push @{$db_load{$row->[0]->{'clusterid'}}}, $row;
 147         } else {
 148             push @load_list_d6, $row;
 149         }
 150     }
 151
 152     foreach my $cid (keys %db_load) {
 153         my $dbcr = LJ::get_cluster_def_reader($cid);
 154         unless ($dbcr) {
 155             print STDERR "Error: LJ::load_userpics unable to get handle; cid = $cid\n";
 156             next;
 157         }
 158
 159         my (@bindings, @data);
 160         foreach my $row (@{$db_load{$cid}}) {
 161             push @bindings, "(userid=? AND picid=?)";
 162             push @data, ($row->[0]->{userid}, $row->[1]);
 163         }
 164         next unless @data && @bindings;
 165
 166         my $sth = $dbcr->prepare("SELECT userid, picid, width, height, fmt, state, ".
 167                                  "       UNIX_TIMESTAMP(picdate) AS 'picdate', location, flags ".
 168                                  "FROM userpic2 WHERE " . join(' OR ', @bindings));
 169         $sth->execute(@data);
 170
 171         while (my $ur = $sth->fetchrow_hashref) {
 172             my $id = delete $ur->{'picid'};
 173             $upics->{$id} = $ur;
 174
 175             # force into numeric context so they'll be smaller in memcache:
 176             foreach my $k (qw(userid width height flags picdate)) {
 177                 $ur->{$k} += 0;
 178             }
 179             $ur->{location} = uc(substr($ur->{location}, 0, 1));
 180
 181             $LJ::CACHE_USERPIC{$id} = $ur;
 182             LJ::MemCacheProxy::set([$id,"userpic.$id"], LJ::MemCache::hash_to_array("userpic", $ur));
 183         }
 184     }
 185
 186     # following path is only for old style d6 userpics... don't load any if we don't
 187     # have any to load
 188     return unless @load_list_d6;
 189
 190     my $dbr = LJ::get_db_writer();
 191     my $picid_in = join(',', map { $_->[1] } @load_list_d6);
 192     my $sth = $dbr->prepare("SELECT userid, picid, width, height, contenttype, state, ".
 193                             "       UNIX_TIMESTAMP(picdate) AS 'picdate' ".
 194                             "FROM userpic WHERE picid IN ($picid_in)");
 195     $sth->execute;
 196     while (my $ur = $sth->fetchrow_hashref) {
 197         my $id = delete $ur->{'picid'};
 198         $upics->{$id} = $ur;
 199
 200         # force into numeric context so they'll be smaller in memcache:
 201         foreach my $k (qw(userid width height picdate)) {
 202             $ur->{$k} += 0;
 203         }
 204         $ur->{location} = "?";
 205         $ur->{flags} = undef;
 206         $ur->{fmt} = {
 207             'image/gif' => 'G',
 208             'image/jpeg' => 'J',
 209             'image/png' => 'P',
 210         }->{delete $ur->{contenttype}};
 211
 212         $LJ::CACHE_USERPIC{$id} = $ur;
 213         LJ::MemCacheProxy::set([$id,"userpic.$id"], LJ::MemCache::hash_to_array("userpic", $ur));
 214     }
 215 }
 216
 217 # <LJFUNC>
 218 # name: LJ::expunge_userpic
 219 # des: Expunges a userpic so that the system will no longer deliver this userpic.  If
 220 #      your site has off-site caching or something similar, you can also define a hook
 221 #      "expunge_userpic" which will be called with a picid and userid when a pic is
 222 #      expunged.
 223 # args: u, picid
 224 # des-picid: ID of the picture to expunge.
 225 # des-u: User object
 226 # returns: undef on error, or the userid of the picture owner on success.
 227 # </LJFUNC>
 228 sub expunge_userpic {
 229     # take in a picid and expunge it from the system so that it can no longer be used
 230     my ($u, $picid) = @_;
 231     $picid += 0;
 232     return undef unless $picid && ref $u;
 233
 234     # get the pic information
 235     my $state;
 236
 237     if ($u->{'dversion'} > 6) {
 238         my $dbcm = LJ::get_cluster_master($u);
 239         return undef unless $dbcm && $u->writer;
 240
 241         $state = $dbcm->selectrow_array('SELECT state FROM userpic2 WHERE userid = ? AND picid = ?',
 242                                         undef, $u->{'userid'}, $picid);
 243         return undef unless $state; # invalid pic
 244         return $u->{'userid'} if $state eq 'X'; # already expunged
 245
 246         # else now mark it
 247         $u->do("UPDATE userpic2 SET state='X' WHERE userid = ? AND picid = ?", undef, $u->{'userid'}, $picid);
 248         return LJ::error($dbcm) if $dbcm->err;
 249         $u->do("DELETE FROM userpicmap2 WHERE userid = ? AND picid = ?", undef, $u->{'userid'}, $picid);
 250     } else {
 251         my $dbr = LJ::get_db_reader();
 252         return undef unless $dbr;
 253
 254         $state = $dbr->selectrow_array('SELECT state FROM userpic WHERE picid = ?',
 255                                        undef, $picid);
 256         return undef unless $state; # invalid pic
 257         return $u->{'userid'} if $state eq 'X'; # already expunged
 258
 259         # else now mark it
 260         my $dbh = LJ::get_db_writer();
 261         return undef unless $dbh;
 262         $dbh->do("UPDATE userpic SET state='X' WHERE picid = ?", undef, $picid);
 263         return LJ::error($dbh) if $dbh->err;
 264         $dbh->do("DELETE FROM userpicmap WHERE userid = ? AND picid = ?", undef, $u->{'userid'}, $picid);
 265     }
 266
 267     # now clear the user's memcache picture info
 268     LJ::Userpic->delete_cache($u);
 269     LJ::MemCacheProxy::delete([$picid, "userpic.$picid"]);
 270
 271     ## if this was the default userpic, "undefault" it
 272     if ($u->{'defaultpicid'} && $u->{'defaultpicid'}==$picid) {
 273         LJ::update_user($u, { defaultpicid => 0 });
 274     }
 275
 276     # call the hook and get out of here
 277     my @rval = LJ::run_hooks('expunge_userpic', $picid, $u->{'userid'});
 278     return ($u->{'userid'}, map {$_->[0]} grep {$_ && @$_ && $_->[0]} @rval);
 279 }
 280
 281 # <LJFUNC>
 282 # name: LJ::activate_userpics
 283 # des: des: Wrapper around [func[LJ::User::activate_userpics]] for compatibility.
 284 # args: uuserid
 285 # returns: undef on failure 1 on success
 286 # </LJFUNC>
 287 sub activate_userpics
 288 {
 289     my $u = shift;
 290     return undef unless LJ::isu($u);
 291
 292     # if a userid was given, get a real $u object
 293     $u = LJ::load_userid($u, "force") unless isu($u);
 294
 295     # should have a $u object now
 296     return undef unless isu($u);
 297
 298     return $u->activate_userpics;
 299 }
 300
 301 # <LJFUNC>
 302 # name: LJ::get_userpic_info
 303 # des: Given a user, gets their userpic information.
 304 # args: uuid, opts?
 305 # des-uuid: userid, or user object.
 306 # des-opts: Optional; hash of options, 'load_comments'.
 307 # returns: hash of userpicture information;
 308 #          for efficiency, we store the userpic structures
 309 #          in memcache in a packed format.
 310 # info: memory format:
 311 #       [
 312 #       version number of format,
 313 #       userid,
 314 #       "packed string", which expands to an array of {width=>..., ...}
 315 #       "packed string", which expands to { 'kw1' => id, 'kw2' => id, ...}
 316 #       ]
 317 # </LJFUNC>
 318
 319 sub get_userpic_info
 320 {
 321     my ($uuid, $opts) = @_;
 322     return undef unless $uuid;
 323     my $userid = LJ::want_userid($uuid);
 324     my $u = LJ::want_user($uuid); # This should almost always be in memory already
 325     return undef unless $u && $u->{clusterid};
 326
 327     # in the cache, cool, well unless it doesn't have comments or urls
 328     # and we need them
 329     if (my $cachedata = $LJ::CACHE_USERPIC_INFO{$userid}) {
 330         my $good = 1;
 331         if ($u->{'dversion'} > 6) {
 332             $good = 0 if $opts->{'load_comments'} && ! $cachedata->{'_has_comments'};
 333             $good = 0 if $opts->{'load_urls'} && ! $cachedata->{'_has_urls'};
 334         }
 335         return $cachedata if $good;
 336     }
 337
 338     my $VERSION_PICINFO = 3;
 339
 340     my $memkey = [$u->{'userid'},"upicinf:$u->{'userid'}"];
 341     my ($info, $minfo);
 342
 343     if ($minfo = LJ::MemCacheProxy::get($memkey)) {
 344         # the pre-versioned memcache data was a two-element hash.
 345         # since then, we use an array and include a version number.
 346
 347         if (ref $minfo eq 'HASH' ||
 348             $minfo->[0] != $VERSION_PICINFO) {
 349             # old data in the cache.  delete.
 350             LJ::MemCacheProxy::delete($memkey);
 351         } else {
 352             my (undef, $picstr, $kwstr) = @$minfo;
 353             $info = {
 354                 'pic' => {},
 355                 'kw' => {},
 356             };
 357             while (length $picstr >= 7) {
 358                 my $pic = { userid => $u->{'userid'} };
 359                 ($pic->{picid},
 360                  $pic->{width}, $pic->{height},
 361                  $pic->{state}) = unpack "NCCA", substr($picstr, 0, 7, '');
 362                 $info->{pic}->{$pic->{picid}} = $pic;
 363             }
 364
 365             my ($pos, $nulpos);
 366             $pos = $nulpos = 0;
 367             while (($nulpos = index($kwstr, "\0", $pos)) > 0) {
 368                 my $kw = substr($kwstr, $pos, $nulpos-$pos);
 369                 my $id = unpack("N", substr($kwstr, $nulpos+1, 4));
 370                 $pos = $nulpos + 5; # skip NUL + 4 bytes.
 371                 $info->{kw}->{$kw} = $info->{pic}->{$id} if $info;
 372             }
 373         }
 374
 375         if ($u->{'dversion'} > 6) {
 376
 377             # Load picture comments
 378             if ($opts->{'load_comments'}) {
 379                 my $commemkey = [$u->{'userid'}, "upiccom:$u->{'userid'}"];
 380                 my $comminfo = LJ::MemCacheProxy::get($commemkey);
 381
 382                 if (defined $comminfo) {
 383                     my ($pos, $nulpos);
 384                     $pos = $nulpos = 0;
 385                     while (($nulpos = index($comminfo, "\0", $pos)) > 0) {
 386                         my $comment = substr($comminfo, $pos, $nulpos-$pos);
 387                         my $id = unpack("N", substr($comminfo, $nulpos+1, 4));
 388                         $pos = $nulpos + 5; # skip NUL + 4 bytes.
 389                         $info->{'pic'}->{$id}->{'comment'} = $comment;
 390                         $info->{'comment'}->{$id} = $comment;
 391                     }
 392                     $info->{'_has_comments'} = 1;
 393                 } else { # Requested to load comments, but they aren't in memcache
 394                          # so force a db load
 395                     undef $info;
 396                 }
 397             }
 398
 399             # Load picture urls
 400             if ($opts->{'load_urls'} && $info) {
 401                 my $urlmemkey = [$u->{'userid'}, "upicurl:$u->{'userid'}"];
 402                 my $urlinfo = LJ::MemCache::get($urlmemkey);
 403
 404                 if (defined $urlinfo) {
 405                     my ($pos, $nulpos);
 406                     $pos = $nulpos = 0;
 407                     while (($nulpos = index($urlinfo, "\0", $pos)) > 0) {
 408                         my $url = substr($urlinfo, $pos, $nulpos-$pos);
 409                         my $id = unpack("N", substr($urlinfo, $nulpos+1, 4));
 410                         $pos = $nulpos + 5; # skip NUL + 4 bytes.
 411                         $info->{'pic'}->{$id}->{'url'} = $url;
 412                     }
 413                     $info->{'_has_urls'} = 1;
 414                 } else { # Requested to load urls, but they aren't in memcache
 415                          # so force a db load
 416                     undef $info;
 417                 }
 418             }
 419         }
 420     }
 421
 422     my %minfocom; # need this in this scope
 423     my %minfourl;
 424     unless ($info) {
 425         $info = {
 426             'pic' => {},
 427             'kw' => {},
 428         };
 429         my ($picstr, $kwstr);
 430         my $sth;
 431         my $dbcr = LJ::get_cluster_def_reader($u);
 432         my $db = @LJ::MEMCACHE_SERVERS ? LJ::get_db_writer() : LJ::get_db_reader();
 433         return undef unless $dbcr && $db;
 434
 435         if ($u->{'dversion'} > 6) {
 436             $sth = $dbcr->prepare("SELECT picid, width, height, state, userid, comment, url ".
 437                                   "FROM userpic2 WHERE userid=?");
 438         } else {
 439             $sth = $db->prepare("SELECT picid, width, height, state, userid ".
 440                                 "FROM userpic WHERE userid=?");
 441         }
 442         $sth->execute($u->{'userid'});
 443         my @pics;
 444         while (my $pic = $sth->fetchrow_hashref) {
 445             next if $pic->{state} eq 'X'; # no expunged pics in list
 446             push @pics, $pic;
 447             $info->{'pic'}->{$pic->{'picid'}} = $pic;
 448             $minfocom{int($pic->{picid})} = $pic->{comment} if $u->{'dversion'} > 6
 449                 && $opts->{'load_comments'} && $pic->{'comment'};
 450             $minfourl{int($pic->{'picid'})} = $pic->{'url'} if $u->{'dversion'} > 6
 451                 && $opts->{'load_urls'} && $pic->{'url'};
 452         }
 453
 454
 455         $picstr = join('', map { pack("NCCA", $_->{picid},
 456                                  $_->{width}, $_->{height}, $_->{state}) } @pics);
 457
 458         if ($u->{'dversion'} > 6) {
 459             $sth = $dbcr->prepare("SELECT k.keyword, m.picid FROM userpicmap2 m, userkeywords k ".
 460                                   "WHERE k.userid=? AND m.kwid=k.kwid AND m.userid=k.userid");
 461         } else {
 462             $sth = $db->prepare("SELECT k.keyword, m.picid FROM userpicmap m, keywords k ".
 463                                 "WHERE m.userid=? AND m.kwid=k.kwid");
 464         }
 465         $sth->execute($u->{'userid'});
 466         my %minfokw;
 467         while (my ($kw, $id) = $sth->fetchrow_array) {
 468             next unless $info->{'pic'}->{$id};
 469             next if $kw =~ /[\n\r\0]/;  # used to be a bug that allowed these to get in.
 470             $info->{'kw'}->{$kw} = $info->{'pic'}->{$id};
 471             $minfokw{$kw} = int($id);
 472         }
 473         $kwstr = join('', map { pack("Z*N", $_, $minfokw{$_}) } keys %minfokw);
 474
 475         $memkey = [$u->{'userid'},"upicinf:$u->{'userid'}"];
 476         $minfo = [ $VERSION_PICINFO, $picstr, $kwstr ];
 477         LJ::MemCache::set($memkey, $minfo);
 478
 479         if ($u->{'dversion'} > 6) {
 480
 481             if ($opts->{'load_comments'}) {
 482                 $info->{'comment'} = \%minfocom;
 483                 my $commentstr = join('', map { pack("Z*N", $minfocom{$_}, $_) } keys %minfocom);
 484
 485                 my $memkey = [$u->{'userid'}, "upiccom:$u->{'userid'}"];
 486                 LJ::MemCache::set($memkey, $commentstr);
 487
 488                 $info->{'_has_comments'} = 1;
 489             }
 490
 491             if ($opts->{'load_urls'}) {
 492                 my $urlstr = join('', map { pack("Z*N", $minfourl{$_}, $_) } keys %minfourl);
 493
 494                 my $memkey = [$u->{'userid'}, "upicurl:$u->{'userid'}"];
 495                 LJ::MemCache::set($memkey, $urlstr);
 496
 497                 $info->{'_has_urls'} = 1;
 498             }
 499         }
 500     }
 501
 502     $LJ::CACHE_USERPIC_INFO{$u->{'userid'}} = $info;
 503     return $info;
 504 }
 505
 506 # <LJFUNC>
 507 # name: LJ::get_pic_from_keyword
 508 # des: Given a userid and keyword, returns the pic row hashref.
 509 # args: u, keyword
 510 # des-keyword: The keyword of the userpic to fetch.
 511 # returns: hashref of pic row found
 512 # </LJFUNC>
 513 sub get_pic_from_keyword
 514 {
 515     my ($u, $kw) = @_;
 516     my $info = LJ::get_userpic_info($u) or
 517         return undef;
 518
 519     if (my $pic = $info->{'kw'}{$kw}) {
 520         return $pic;
 521     }
 522
 523     # the lame "pic#2343" thing when they didn't assign a keyword
 524     if ($kw =~ /^pic\#(\d+)$/) {
 525         my $picid = $1;
 526         if (my $pic = $info->{'pic'}{$picid}) {
 527             return $pic;
 528         }
 529     }
 530
 531     return undef;
 532 }
 533
 534 sub get_picid_from_keyword
 535 {
 536     my ($u, $kw, $default) = @_;
 537     $default ||= (ref $u ? $u->{'defaultpicid'} : 0);
 538
 539     LJ::run_hook('control_default_userpic', \$default);
 540
 541     return $default unless $kw;
 542
 543     my $pic = LJ::get_pic_from_keyword($u, $kw)
 544         or return $default;
 545     return $pic->{'picid'};
 546 }
 547
 548 # this will return a user's userpicfactory image stored in mogile scaled down.
 549 # if only $size is passed, will return image scaled so the largest dimension will
 550 # not be greater than $size. If $x1, $y1... are set then it will return the image
 551 # scaled so the largest dimension will not be greater than 100
 552 # all parameters are optional, default size is 640.
 553 #
 554 # if maxfilesize option is passed, get_upf_scaled will decrease the image quality
 555 # until it reaches maxfilesize, in kilobytes. (only applies to the 100x100 userpic)
 556 #
 557 # returns [imageref, mime, width, height] on success, undef on failure.
 558 #
 559 # note: this will always keep the image's original aspect ratio and not distort it.
 560 sub get_upf_scaled {
 561     my @args = @_;
 562
 563     my $gc = LJ::gearman_client();
 564
 565     # no gearman, do this in-process
 566     return LJ::_get_upf_scaled(@args)
 567         unless $gc;
 568
 569     # invoke gearman
 570     my $u = LJ::get_remote()
 571         or die "No remote user";
 572     unshift @args, "userid" => $u->id;
 573
 574     my $result;
 575     my $arg = Storable::nfreeze(\@args);
 576     my $task = Gearman::Task->new('lj_upf_resize', \$arg,
 577                                   {
 578                                       uniq => '-',
 579                                       on_complete => sub {
 580                                           my $res = shift;
 581                                           return unless $res;
 582                                           $result = Storable::thaw($$res);
 583                                       }
 584                                   });
 585
 586     my $ts = $gc->new_task_set();
 587     $ts->add_task($task);
 588     $ts->wait(timeout => 30); # 30 sec timeout;
 589
 590     # job failed ... error reporting?
 591     die "Could not resize image down\n" unless $result;
 592
 593     return $result;
 594 }
 595
 596 # <LJFUNC>
 597 # name: _get_upf_scaled
 598 # des: Crop and scale images
 599 # agrs:
 600 #   size - max width of target image or [ width x height, ...]
 601 #   x1, x2, y1, y2 - coords in a source image for crop
 602 #   border (bool) - is it need to add border to target image
 603 #   save_to_FB (bool) - is it need to save to FB (FotoBilder)
 604 #   fb_gallery - gallery to save target image
 605 #   auto_crop - is it need to auto_crop image
 606 #   cancel_size - if size of picture is equal or smaller => cancel processing, caller will not use such small picture
 607 #                 returns status 'small'
 608 #####
 609 # Sample for use as auto-crop:
 610 #
 611 #    my $res = LJ::get_upf_scaled(
 612 #            source      => \$content,
 613 #            size        => [ "140x105" ],
 614 #            save_to_FB  => 1,
 615 #            fb_gallery  => 'test_gal',
 616 #            auto_crop   => 1,
 617 #    );
 618 #####
 619 # </LJFUNC>
 620 sub _get_upf_scaled
 621 {
 622     my %opts = @_;
 623     my $dataref = delete $opts{source};
 624     my $size = delete $opts{size} || 640;
 625     my $x1 = delete $opts{x1};
 626     my $y1 = delete $opts{y1};
 627     my $x2 = delete $opts{x2};
 628     my $y2 = delete $opts{y2};
 629     my $border = delete $opts{border} || 0;
 630     my $maxfilesize = delete $opts{maxfilesize} || 38;
 631     my $u = LJ::want_user(delete $opts{userid} || delete $opts{u}) || LJ::get_remote();
 632     my $mogkey = delete $opts{mogkey};
 633     my $downsize_only = delete $opts{downsize_only};
 634     my $save_to_FB = delete $opts{save_to_FB} || 0;
 635     my $fb_gallery = delete $opts{fb_gallery};
 636     my $fb_username = delete $opts{fb_username};
 637     my $fb_password = delete $opts{fb_password};
 638     my $auto_crop = delete $opts{auto_crop};
 639     my $cancel_size = delete $opts{cancel_size};
 640     croak "No userid or remote" unless $u || $mogkey || $dataref;
 641
 642     $maxfilesize *= 1024;
 643
 644     croak "Invalid parameters to get_upf_scaled\n" if scalar keys %opts;
 645
 646     my $mode = ($x1 || $y1 || $x2 || $y2 || $auto_crop) ? "crop" : "scale";
 647
 648     eval { require Image::Magick }
 649         or return undef;
 650
 651     eval { require Image::Size }
 652         or return undef;
 653
 654     $mogkey ||= 'upf:' . $u->{userid};
 655     $dataref = LJ::mogclient()->get_file_data($mogkey)
 656         unless $dataref;
 657
 658     return undef
 659         unless $dataref;
 660
 661     # original width/height
 662     my ($ow, $oh) = Image::Size::imgsize($dataref);
 663     return undef unless $ow && $oh;
 664
 665     my @cancel_size = split /x/, $cancel_size;
 666     return { status => 'small' }
 667         if $cancel_size[0] and $ow < $cancel_size[0] or $cancel_size[1] and $oh < $cancel_size[1];
 668
 669     # converts an ImageMagick object to the form returned to our callers
 670     my $imageParams = sub {
 671         my $im = shift;
 672         my $blob = $im->ImageToBlob;
 673         return [\$blob, $im->Get('MIME'), $im->Get('width'), $im->Get('height')];
 674     };
 675
 676     # compute new width and height while keeping aspect ratio
 677     my $getSizedCoords = sub {
 678         my $newsize = shift;
 679
 680         my $fromw = $ow;
 681         my $fromh = $oh;
 682
 683         my $img = shift;
 684         if ($img) {
 685             $fromw = $img->Get('width');
 686             $fromh = $img->Get('height');
 687         }
 688
 689         return (int($newsize * $fromw/$fromh), $newsize) if $fromh > $fromw;
 690         return ($newsize, int($newsize * $fromh/$fromw));
 691     };
 692
 693     # get the "medium sized" width/height.  this is the size which
 694     # the user selects from
 695     my @sizes = split /x/, $size;
 696     my ($medw, $medh) = scalar @sizes > 1 ? @sizes : $getSizedCoords->($size);
 697     return undef unless $medw && $medh;
 698
 699     # simple scaling mode
 700     if ($mode eq "scale") {
 701         my $image = Image::Magick->new(size => "${medw}x${medh}")
 702             or return undef;
 703
 704         $image->BlobToImage($$dataref);
 705         unless ($downsize_only && ($medw > $ow || $medh > $oh)) {
 706             $image->Resize(width => $medw, height => $medh);
 707         }
 708         return $imageParams->($image);
 709     }
 710
 711     # else, we're in 100x100 cropping mode
 712
 713     # scale user coordinates  up from the medium pixelspace to full pixelspace
 714     $x1 *= ($ow/$medw);
 715     $x2 *= ($ow/$medw);
 716     $y1 *= ($oh/$medh);
 717     $y2 *= ($oh/$medh);
 718
 719     # cropping dimensions from the full pixelspace
 720     my $tw = $x2 - $x1;
 721     my $th = $y2 - $y1;
 722
 723     # but if their selected region in full pixelspace is 800x800 or something
 724     # ridiculous, no point decoding the JPEG to its full size... we can
 725     # decode to a smaller size so we get 100px when we crop
 726     my $min_dim = $tw < $th ? $tw : $th;
 727     my ($decodew, $decodeh) = ($ow, $oh);
 728     if ($auto_crop) {
 729         $decodew = $sizes[0];
 730         $decodeh = $sizes[1];
 731     } else {
 732         my $wanted_size = 100;
 733         if ($min_dim > $wanted_size) {
 734             # then let's not decode the full JPEG down from its huge size
 735             my $de_scale = $wanted_size / $min_dim;
 736
 737             $decodew = int($de_scale * $decodew);
 738             $decodeh = int($de_scale * $decodeh);
 739
 740             $_ *= $de_scale foreach ($x1, $x2, $y1, $y2);
 741         }
 742     }
 743
 744     $_ = int($_) foreach ($x1, $x2, $y1, $y2, $tw, $th);
 745
 746     # make the pristine (uncompressed) 100x100 image
 747     my $timage = $auto_crop ? Image::Magick->new() : Image::Magick->new(size => "${decodew}x${decodeh}");
 748     return undef unless $timage;
 749
 750     $timage->BlobToImage($$dataref);
 751     $timage->Set(magick => 'PNG');
 752
 753     if ($auto_crop) {
 754         my ($crop_w, $crop_h) = ();
 755         if ($oh <= $decodeh and $ow <= $decodew) {
 756             ; # nothing to do
 757         # else one (or two) size is bigger
 758         } elsif ($oh < $decodeh) { # than ow > decodew
 759             $crop_h = $oh;
 760             $crop_w = $decodew;
 761             $x1 = ($ow - $crop_w) / 2;
 762             $y1 = 0;
 763         } elsif ($ow < $decodew) { # than oh > decodeh
 764             $crop_w = $ow;
 765             $crop_h = $decodeh;
 766             $y1 = ($oh - $crop_h) / 2;
 767             $x1 = 0;
 768         } elsif ($ow / $decodew >= $oh / $decodeh) {
 769             $crop_w = $oh * $decodew / $decodeh;
 770             $crop_h = $oh;
 771             $x1 = ($ow - $crop_w) / 2;
 772             $y1 = 0;
 773         } else {
 774             $crop_w = $ow;
 775             $crop_h = $ow * $decodeh / $decodew;
 776             $y1 = ($oh - $crop_h) / 2;
 777             $x1 = 0;
 778         }
 779         if ($oh > $decodeh or $ow > $decodew) {
 780             $timage->Crop($crop_w."x".$crop_h."+$x1+$y1");
 781             if ($crop_h > $decodeh or $crop_w > $decodew) {
 782                 $timage->Scale(width => $decodew, height => $decodeh);
 783             }
 784         }
 785     } else {
 786         my $w = ($x2 - $x1);
 787         my $h = ($y2 - $y1);
 788         $timage->Scale(width => $decodew, height => $decodeh);
 789         $timage->Mogrify(crop => "${w}x${h}+$x1+$y1");
 790     }
 791
 792     if ($save_to_FB) {
 793         my $im_blob = $timage->ImageToBlob;
 794         my $res = upload_to_fb (
 795             dataref  => $im_blob,
 796             gals     => $fb_gallery,
 797             username => $fb_username,
 798             password => $fb_password,
 799         );
 800         return $res;
 801     }
 802
 803     my $targetSize = $border ? 98 : 100;
 804
 805     my ($nw, $nh) = $getSizedCoords->($targetSize, $timage);
 806     $timage->Scale(width => $nw, height => $nh);
 807
 808     # add border if desired
 809     $timage->Border(geometry => "1x1", color => 'black') if $border;
 810
 811     # we are PNG here
 812     # test, if we can skip compression
 813     my $piccopy = $timage->Clone();
 814     my $ret = $imageParams->($piccopy);
 815     unless ( length(${ $ret->[0] }) < $maxfilesize ) {
 816         $timage->Set(magick => 'JPG'); # need compression
 817     }
 818
 819     foreach my $qual (qw(100 90 85 75)) {
 820         # work off a copy of the image so we aren't recompressing it
 821         $piccopy = $timage->Clone();
 822         $piccopy->Set('quality' => $qual);
 823         $ret = $imageParams->($piccopy);
 824         last if length(${ $ret->[0] }) < $maxfilesize;
 825     }
 826
 827     return $ret;
 828 }
 829
 830 sub format_magic {
 831     my $magic = shift;
 832     my $default = shift;
 833
 834     my $magic_ref = (ref $magic) ? $magic : \$magic;
 835     my $mime = $default || 'text/plain'; # default value
 836     # image formats
 837     $mime = 'image/jpeg' if $$magic_ref =~ /^\xff\xd8/; # JPEG
 838     $mime = 'image/gif'  if $$magic_ref =~ /^GIF8/;     # GIF
 839     $mime = 'image/png'  if $$magic_ref =~ /^\x89PNG/;  # PNG
 840
 841     return $mime;
 842 }
 843
 844 sub get_challenge
 845 {
 846     my $username = shift;
 847
 848     my $ua = LWP::UserAgent->new;
 849     $ua->agent("FotoBilder_Uploader/0.2");
 850
 851     my $req = HTTP::Request->new(GET => "$LJ::FB_SITEROOT/interface/simple");
 852     $req->push_header("X-FB-Mode" => "GetChallenge");
 853     $req->push_header("X-FB-User" => $username);
 854
 855     my $res = $ua->request($req);
 856     die "HTTP error: " . $res->content . "\n"
 857         unless $res->is_success;
 858
 859     my $xmlres = XML::Simple::XMLin($res->content);
 860     my $methres = $xmlres->{GetChallengeResponse};
 861
 862     if (my $err = $xmlres->{Error} || $methres->{Error}) {
 863         use Data::Dumper;
 864         die Dumper $err;
 865     }
 866
 867     return $methres->{Challenge};
 868 }
 869
 870 sub make_auth
 871 {
 872     my $chal = shift;
 873     my $password = shift;
 874     return "crp:$chal:" . md5_hex($chal . md5_hex($password));
 875 }
 876
 877 sub upload_to_fb {
 878     my %opts = @_;
 879
 880     my $dataref = $opts{dataref};
 881     my $gals    = $opts{gals} || [];
 882
 883     my $username = $opts{username} || $LJ::FB_USER;
 884     my $password = $opts{password} || $LJ::FB_PASS;
 885
 886     my $chal = "";
 887     unless ($chal) {
 888         $chal = get_challenge($username)
 889             or die "No challenge string available.\n";
 890     }
 891
 892     my $ua = LWP::UserAgent->new;
 893     $ua->agent("FotoBilder_Uploader/0.2");
 894
 895     # Create a request
 896     my $req = HTTP::Request->new(PUT => "$LJ::FB_SITEROOT/interface/simple");
 897     $req->push_header("X-FB-Mode" => "UploadPic");
 898     $req->push_header("X-FB-User" => $username);
 899     $req->push_header("X-FB-Auth" => make_auth($chal, $password));
 900     $req->push_header("X-FB-GetChallenge" => 1);
 901
 902     # picture security
 903     my $sec = 255; ## public
 904     $req->push_header("X-FB-UploadPic.PicSec" => $sec);
 905
 906     # add to galleries
 907     if (@$gals) {
 908
 909         # initialize galleries struct array
 910         $req->push_header(":X-FB-UploadPic.Gallery._size" => scalar(@$gals));
 911
 912         # add individual galleries
 913         foreach my $idx (0..@$gals-1) {
 914             my $gal = $gals->[$idx];
 915
 916             my @path = split(/\0/, $gal);
 917             my $galname = pop @path;
 918
 919             $req->push_header
 920                 ("X-FB-UploadPic.Gallery.$idx.GalName" => $galname);
 921             $req->push_header
 922                 ("X-FB-UploadPic.Gallery.$idx.GalDate" => time());
 923             $req->push_header
 924                 ("X-FB-UploadPic.Gallery.$idx.GalSec" => $sec);
 925
 926             if (@path) {
 927                 $req->push_header
 928                     (":X-FB-UploadPic.Gallery.$idx.Path._size" => scalar(@path));
 929                 foreach (0..@path-1) {
 930                     $req->push_header
 931                         (":X-FB-UploadPic.Gallery.$idx.Path.$_" => $path[$_]);
 932                 }
 933
 934             }
 935         }
 936     }
 937
 938     $req->push_header("X-FB-UploadPic.ImageLength" => length($dataref));
 939     $req->push_header("Content-Length" => length($dataref));
 940     $req->content($dataref);
 941
 942     my $res = $ua->request($req);
 943     die "HTTP error: " . $res->content . "\n"
 944         unless $res->is_success;
 945
 946     my $xmlres = XML::Simple::XMLin($res->content);
 947     my $methres = $xmlres->{UploadPicResponse};
 948     my $chalres = $xmlres->{GetChallengeResponse};
 949
 950     $chal = $chalres->{Challenge};
 951
 952     if (my $err = $xmlres->{Error} || $methres->{Error} || $chalres->{Error}) {
 953         return {
 954             picid  => -1,
 955             url    => undef,
 956             status => 'error',
 957             errstr => ref $err eq 'HASH' ? $err->{content} : (ref $err eq 'ARRAY' ? $err->[0] : $err),
 958             opts => \%opts,
 959         }
 960     }
 961
 962     return {
 963         picid  => $methres->{PicID},
 964         url    => $methres->{URL},
 965         status => 'ok',
 966     }
 967 }
 968
 969 # get picture from internet $opts{source} and crop it to $opts{size},
 970 # than save result into $opts{galleries} (arrayref) of scrapbook of $opts{username}, using $opts{password}
 971 # returns result of &upload_to_fb
 972 sub crop_picture_from_web {
 973     my %opts = @_;
 974     my $data;
 975
 976     my $source = LJ::trim($opts{source});
 977
 978     if ($source) {
 979         return {
 980             url    => '',
 981             status => 'ok',
 982         } unless $source;
 983
 984         ## fetch a photo from Net
 985         my $ua = LJ::get_useragent( role     => 'crop_picture',
 986                                     max_size => 10 * 1024 * 1024,
 987                                     timeout  => 10,
 988                                   );
 989         my $result = $ua->request(GET($source));
 990         unless ($result and $result->is_success) {
 991             return {
 992                 picid  => -1,
 993                 url    => undef,
 994                 status => 'error',
 995                 errstr => $result ? $result->status_line : 'unknown error in downloading',
 996             };
 997         }
 998         $data       = $result->content;
 999         $opts{data} = $result->content;
1000     } else {
1001         $data = ${$opts{'dataref'}};
1002     }
1003     my $res = LJ::_get_upf_scaled(
1004                     source      => \$data,
1005                     size        => $opts{size},
1006                     cancel_size => $opts{cancel_size},
1007                     save_to_FB  => 1,
1008                     auto_crop   => 1,
1009                     fb_username => $opts{username},
1010                     fb_password => $opts{password},
1011                     fb_gallery  => $opts{galleries},
1012               );
1013     unless ($res) {
1014         return {
1015             picid  => -1,
1016             url    => undef,
1017             status => 'error',
1018             errstr => 'probably bad picture',
1019         };
1020     }
1021     # need to repeat? (because of bad auth in CentOS-32 ScrapBook)
1022     # DELETE THIS IN FUTURE!!!
1023     if ($res->{picid} == -1) {
1024         warn $res->{errstr} if $LJ::IS_DEV_SERVER;
1025         return upload_to_fb(%{$res->{opts}});
1026     }
1027     return $res;
1028 }
1029
1030 1;
1031