#!/opt/local/bin/perl -w # Copyright © 2008-2013 Jamie Zawinski # # Permission to use, copy, modify, distribute, and sell this software and its # documentation for any purpose is hereby granted without fee, provided that # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation. No representations are made about the suitability of this # software for any purpose. It is provided "as is" without express or # implied warranty. # =========================================================================== # # This is how I post to my blog via email. It takes an incoming mail # message, extracts the images and saves them to a directory of your # choice, then constructs HTML from those images and the rest of the # message, and posts that. If there are images and they have location # data in them, it marks the post with that location. It also allows # you to write your text using Markdown instead of HTML. # # Attached images are resized, thumbnailed, and hosted on your own server. # The code supports posting to WordPress, Livejournal and/or Twitter. # # It also handles attached videos, saving them locally and embedding them # with . (Possibly posting them to Youtube first would be # preferable, but that's not implemented.) # # =========================================================================== # Installation: # =========================================================================== # # When the mail server runs this script, you need to arrange for it to run # as a user who can create files in $image_dir. To make this work with # Postfix: # # /etc/postfix/main.cf: # alias_maps = hash:/etc/aliases, hash:/etc/postfix/aliases-jwz # alias_database = hash:/etc/aliases, hash:/etc/postfix/aliases-jwz # # /etc/postfix/aliases-jwz: # ljpost: "|/Users/jwz/www/hacks/ljpost.pl --wp USER" # # chown root:wheel /etc/postfix/aliases-jwz* # newaliases # chown jwz /etc/postfix/aliases-jwz* # (this must be done after newaliases!) # # # To post, you would send email to the address "ljpost+XYZ@example.com" # where "XYZ" is the password in "~/.ljpost-pass" on the server. Keep # that secret, as anyone who knows it can post as you. However, if you # trust the sanctity of your address book, you might want to save it there. # # # =========================================================================== # Configuration: # =========================================================================== # # To post to a WordPress blog, invoke this script with "--wp WPUSER". # This will run my "wppost.php" script to do the actual hosting (which see). # This assumes that your blog is on the same host as your mail server; # and that the user this script is running as has access to WordPress's # SQL database. # # To post to LiveJournal, set up "post by email" on LJ and invoke this # script with "--lj LJUSER". To post to a Livejournal community instead # of a user account, use "--lj LJUSER.COMMUNITY". # # To post to Twitter, use "--twit TWITUSER". It will convert HTML to # plain text and truncate things sensibly. # # The password that protects *this* script is read from ~/.ljpost-pass. # # The password for the LJ account for user FOO is read from ~/.FOO-lj-pass. # Likewise, the Twitter API keys are read from ~/.FOO-twitter-pass. # # All of those files should be readable by the user running this script # and nobody else, so make them have the proper owner and "chmod og-w". # # The twitter-pass file needs to have four lines in it, the keys needed to # drive your Twitter API Oauth Application thingy (see dev.twitter.com). # # consumer = ...DATA... # consumer_secret = ...DATA... # access = ...DATA... # access_secret = ...DATA... # # Created: 27-Apr-2008. # # =========================================================================== require 5; use diagnostics; use strict; use POSIX; use MIME::Parser; use MIME::Entity; use Encode qw/decode/; use Image::Magick; use Text::Markdown; use Net::Twitter; my $progname = $0; $progname =~ s@.*/@@g; my $version = q{ $Revision: 1.83 $ }; $version =~ s/^[^\d]+([\d.]+).*/$1/; $ENV{PATH} = "/opt/local/bin:$ENV{PATH}"; # macports my $verbose = 0; my $debug_p = 0; my $image_max_size = 800; # create a thumb if bigger than this. my $image_quality = 90; my $image_dir = '/home/jwz/www/images'; my $image_url = 'http://www.jwz.org/images/'; my $exec_dir = $0; $exec_dir =~ s@/[^/]+$@@s; my $wp_post = "$exec_dir/wppost.php"; # What directory do you need to be in for wppost.php to work? my $wp_dir = $ENV{HOME} . "/www/blog"; # If set, this cmd is run on each image to rotate the JPEG data according # to the EXIF rotation values, so that things post right-side-up. # my $rotimg_cmd = ((-d '/Users' ? '/Users' : '/home') . '/jwz/www/hacks/rotimg'); # If set, run this command on an image to extract its GPS location from # the EXIF data, and send that as a LiveJournal "location" header. # #my $location_cmd = ("exiftool -s -s -s -c %f -GPSPosition"); my $location_cmd = ("identify -define jpeg:size=1x1 -format " . "'%[EXIF:GPSLatitude] %[EXIF:GPSLatitudeRef], " . "%[EXIF:GPSLongitude] %[EXIF:GPSLongitudeRef]'"); my $default_lj_tags = 'firstperson, sf'; my $default_lj_photo_tags = 'photography'; #$default_lj_tags = 'firstperson, sxsw'; #$default_lj_photo_tags = 'photography, music'; my $upload_images_cmd = "cd $image_dir ; make -s commitq"; my $sendmail = "/usr/sbin/sendmail -t -oi"; my $twitter_json_url = 'https://api.twitter.com/1/statuses/update.json'; sub url_quote($) { my ($u) = @_; $u =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge; return $u; } sub url_unquote($) { my ($u) = @_; $u =~ s/[+]/ /g; $u =~ s/%([a-z0-9]{2})/chr(hex($1))/ige; return $u; } sub html_quote($) { my ($u) = @_; $u =~ s/&/&/g; $u =~ s//>/g; # $u =~ s/\"/"/g; return $u; } # Check and print error status from various Image::Magick commands, # and die if it's not just a warning. # sub imagemagick_check_error($) { my ($err) = @_; return unless $err; my ($n) = ($err =~ m/(\d+)/); if ($n && $n == 395 && $err =~ m/unable to open module file/) { # # This error is bullshit: ignore it: # # Exception 395: unable to open module file # `/opt/local/lib/ImageMagick-6.3.0/modules-Q16/coders/008d1bed.la': # No such file or directory # return; } print STDERR "$progname: $err\n"; print STDERR "$progname: maybe \$TMPDIR (". ($ENV{TMPDIR} || "/tmp") . ") filled up?\n" if ($err =~ m/pixel cache/i); exit (1) if ($n >= 400); } sub save_image($$$) { my ($name, $ct, $data) = @_; $name = lc($name); $name =~ s/[^-_.a-z\d]/_/gsi; # map stupid characters to underscores # "Photo 1.jpg" => "photo.jpg", since iPhone 3.x always names the first # attachment "Photo.jpg", the second "Photo 2.jpg", etc. This numbers # them in order ("photo_37.jpg", "photo_38.jpg") instead of in a dumb # order like e.g. "photo-37.jpg", "photo_2-14.jpg". # # Likewise, iPhone 4.x names them "image.jpeg". # OSX Mail.app sometimes names them "JPG.JPG"! # if (! $debug_p) { $name =~ s/^(image|jpe?g)\./photo./si; $name =~ s/^(photo)[-_]*\d*(\.[a-z]+)$/$1$2/gsi; $name =~ s/\.p?jpe?g$/.jpg/si; } my $video_p = ($ct =~ m@^video/@si); my ($img, $fw, $fh); if ($video_p) { ($fw, $fh) = (320, 240); #### Wild-assed guess. } else { $img = Image::Magick->new; $img->BlobToImage ($data); ($fw, $fh) = $img->Get ('width', 'height'); error ("$name: unparsable") unless ($fw > 0 && $fh > 0); } my ($w, $h) = ($fw, $fh); my $big = $name; # Add a numeric suffix before the extension until we have a unique one. # while (-f "$image_dir/$big") { my ($head, $n, $tail) = ($big =~ m@^(.*?)(-\d+)?(\.[^.]+)$@s); $n = ($n || 0) - 1; $big = "$head$n$tail"; } # error ("$image_dir/$big already exists") # if (-f "$image_dir/$big" && !$debug_p); my $file = "$image_dir/$big"; if ($debug_p) { print STDERR "$progname: not writing $file ($w x $h)\n" if ($verbose); $file = sprintf ("%s/msg%08x", ($ENV{TMPDIR} || "/tmp"), rand(0xFFFFFFFF)); unlink $file; } umask 022; open (my $out, '>', "$file") || error ("$big: $!"); (print $out $data) || error ("$big: $!"); close $out || error ("$big: $!"); print STDERR "$progname: wrote $file ($w x $h)\n" if ($verbose); my $loc = undef; if (!$video_p && defined ($location_cmd)) { my $cmd = "$location_cmd '$file'"; print STDERR "$progname: exec: $cmd\n" if ($verbose); $loc = `$cmd`; # For some insane reason, ImageMagick reports GPS coordinates like this: # # 37/1, 4625/100, 0/1 N, 122/1, 2477/100, 0/1 W # # This regexp converts that to # # 37.770833 N, 122.412833 W # $loc =~ s@\b (\d+) / (\d+), \s+ (\d+) / (\d+), \s+ (\d+) / (\d+) \b @{ sprintf ("%.6f", ($1 / $2) + ($3 / $4 / 60) + ($5 / $6 / 3600)); }@gsex; $loc =~ s/(^\s+|\s+$)//gs; $loc = undef unless ($loc =~ m/\d/); # Avoid ", ". $loc = undef unless $loc; } if (!$video_p && defined ($rotimg_cmd)) { my @cmd = ($rotimg_cmd); push @cmd, ($verbose ? "--verbose" : "--quiet"); push @cmd, "$file"; print STDERR "$progname: exec: " . join(' ', @cmd) . "\n" if ($verbose); system (@cmd); # Re-read the file to get its new width/height after possible rotation. $img = Image::Magick->new; $img->Read ("$file"); my ($nw, $nh) = $img->Get ('width', 'height'); if ($nw != $fw || $nh != $fh) { print STDERR "$progname: image rotated: ${fw}x$fh => ${nw}x$nh\n" if ($verbose); ($fw, $fh) = ($nw, $nh); ($w, $h) = ($fw, $fh); } elsif ($verbose) { print STDERR "$progname: image size unchanged\n"; } } unlink $file if $debug_p; my $thumb = $big; if ($video_p) { # Nothing to do here. } elsif ($fw > $image_max_size || $fh > $image_max_size) { $thumb =~ s/(\.[^.]+)$/-thumb$1/s; error ("$thumb already exists") if (-f "$image_dir/$thumb" && !$debug_p); my $wscale = $image_max_size / $fw; my $hscale = $image_max_size / $fh; my $scale = ($wscale < $hscale ? $wscale : $hscale); my $status = $img->Scale (width => int ($fw * $scale), height => int ($fh * $scale)); imagemagick_check_error ($status); $status = $img->Set (quality => $image_quality); imagemagick_check_error ($status); ($w, $h) = $img->Get ('width', 'height'); error ("$thumb: resize didn't work") unless ($w > 0 && $h > 0); if ($debug_p) { print STDERR "$progname: not writing $image_dir/$thumb ($w x $h)\n" if ($verbose); } else { $status = $img->Write (filename => "$image_dir/$thumb"); imagemagick_check_error ($status); print STDERR "$progname: wrote $image_dir/$thumb ($w x $h)\n" if ($verbose); } undef $img; } $big = $image_url . url_quote($big); $thumb = $image_url . url_quote($thumb); return ($big, $thumb, $w, $h, $loc); } sub trim_signature($) { my ($s) = @_; if ($s =~ s@@@si) { $s =~ s@\s*(<(p|br)>\s*)+$@@si; } elsif ($s =~ s@
\s*
\s*--\s*
.*$@@si) { } else { $s =~ s/(^|\n)-- *\n.*$//s; $s = '' if ($s =~ m/^\s+$/s); } return $s; } # Extend Markdown's syntax with two additional ways of typing links. # sub jwz_markdown($) { my ($md) = @_; # If there is a URL following a bracketed phrase, convert it from # "abc[def]ghi URL" to "abc[def](URL)ghi". Be careful not to mess # with text already in "[anchor](URL)" form. # $md =~ s@ ( \[ [^][]+ \] ) # 1 [anchor] ( [^(] ) # 2 not ( ( [^][()]*? ) # 3 stuff \b ((https?|mailto)://[^\s\[\]()<>\"\']+[a-z\d/]) # 4 url @$1($4)$2$3@gsix; # If there is a naked URL (not in parens) convert it to be a markdown # anchor on the preceding text on the source line, e.g., # "abc def! URL ghi" => "[abc def](URL)! ghi". # $md =~ s@ ^[ \t]* (.*?) # 1 anchor ([^a-z\d\s*;]*)[ \t]+ # 2 punc. \b ((https?|mailto)://[^\s\[\]()<>\"\']+[a-z\d/]) # 3 url @[$1]($3)$2@gmix; # Now process everything else using the normal Markdown rules. # return Text::Markdown::markdown($md); } sub split_tag_headers($) { my ($txt) = @_; my $head = ''; my $tags = ''; $txt =~ s/^\s*//s; if ($txt =~ m/^ ( (?: \s* <[^<>]*> )+ ) ( .* )$/six) { ($head, $txt) = ($1, $2); } while ($txt =~ m/^ ( (?: lj-)? (?: tags?|security) : [^\n]* \n ) (.*) $/six) { $tags .= $1; $txt = $2; } $txt = $head . $txt; return ($tags, $txt); } sub clean_html($) { my ($html) = @_; # Lose the multipart/related inline image stubs: we handle images manually. $html =~ s@]*>\s*@@gsi; # What I would like is: if I have typed Markdown text into the mail # composition window, but the app has chosen to send that as HTML, # interpret it as Markdown anyway -- but, if there happens to be # "real" HTML in there ( or whatnot) then pass that through. # # But, the HTML generated by the iPhone is just too much of a pain # in the ass to deal with, so instead, we'll just convert the HTML # to plain-text and then interpret *that* as Markdown. This means # that if you type raw HTML into the compose window, it will work, # but if you use a rich-text editor or cut-and-paste from a web # browser, it will strip out the markup. Oh well, I can live with # that. $html = html_to_text($html); $html = trim_signature($html); my $tags; ($tags, $html) = split_tag_headers ($html); $html = jwz_markdown ($html); $html =~ s@\s*

\s*@

@gsi; $html =~ s@(\s*

)+@

@gsi; $html = "$tags\n$html" if $tags; return $html; } sub html_to_text($) { my ($html) = @_; my $txt = $html; $txt =~ s/ / /gs; $txt =~ s/\s+/ /g; $txt =~ s@\s*

@\n@gsi; # join adjascent DIVs $txt =~ s@[ \t]*]*>[ \t]*@\n\n@gsi; #

$txt =~ s@[ \t]*]*>[ \t]*@\n@gsi; #
$txt =~ s@[ \t]*]*>[ \t]*@\n@gsi; #

$txt =~ s@\s*]*?SRC=[\"']?([^<>\"']+)[^<>]*>\s*@ $1 @gsi; # ]*?HREF=[\"']?([^<>\"']+)[^<>]*>\s*@ $1 @gsi; # ]*>@@gs; # all other tags $txt =~ s@<@<@gs; $txt =~ s@>@>@gs; $txt =~ s@ @ @gs; $txt =~ s@&@&@gs; return $txt; } # Run the URL through http://tinyurl.com/ and return the shortened one. # sub tinyurlify($) { my ($url) = @_; return $url if ($url =~ m@^http://tinyurl@s); my $ua = LWP::UserAgent->new; $ua->agent ("$progname/$version"); # See if the URL has a tag. # (This doesn't work if there's an #anchor). if ($url !~ m/#/s) { my $body = LWP::Simple::get($url) || ''; if ($body =~ m@]*? \b REL \s* = \s* [\"\']? shortlink [\"\']? [^<>]*? \b HREF \s* = \s* [\"\']? ([^\"\'<>]+)@six) { return $1 if (length ($1) < length($body)); } } # Otherwise use tinyurl.com. # For some reason we have to post for it to preserve the #anchor in the URL. my $res = $ua->post ('http://tinyurl.com/api-create.php', { 'url' => $url }); my $url2 = ($res->is_success ? $res->decoded_content : ''); print STDERR "tinyurl: $url\n ==> $url2\n" if ($verbose); return $url unless $url2; return $url2 if (length($url2) < length($url)); return $url; } # Run URLs in the text through http://tinyurl.com/ until the text is less # than 140 characters. Only shrink URLs until the text is short enough; # leave remaining URLs un-shrunk as soon as the text is short enough. # sub shorten_urls($) { my ($txt) = @_; my $max_length = 140 - 10; # slack for re-twits #$max_length = 10; # always shrink 'em return $txt if (length($txt) <= $max_length); my @chunks = split(m@(\bhttps?://[^\s<>]+[A-Za-z\d/])@s, $txt); foreach my $chunk (@chunks) { next unless ($chunk =~ m@^https?://@s); $chunk = tinyurlify ($chunk); $txt = join ('', @chunks); last if (length($txt) <= $max_length); } return $txt; } sub ljpost_1($$$$$) { my ($user, $from, $subj, $loc, $html) = @_; my $tags; ($tags, $html) = split_tag_headers ($html); my $def = $default_lj_tags; if ($html =~ m/; chop ($pass); close $in; error ("$passfile: no password") unless $pass; } elsif (!$debug_p) { error ("$passfile: $!"); } my $tags; ($html, $tags) = ljpost_1 ($user, $from, $subj, $loc, $html); $html = "$tags\n$html" if $tags; # The HTML has to have long lines, since LJ interprets \n in HTML as BR. # Therefore, we need to QP-encode, else SMTP inserts random newlines. my $to = "${user}+${pass}\@post.livejournal.com"; my $msg = MIME::Entity->build (Type =>"text/html", Encoding => "quoted-printable", From => $from, To => $to, Subject => $subj, Data => $html); if ($debug_p) { print STDERR ("#" x 72) . "\nResultant message:\n" . ("#" x 72) . "\n"; $msg->print(\*STDERR); print "\n"; } else { open my $mail, "| $sendmail" || error ("sendmail: $!"); $msg->print($mail); close $mail; } } sub wppost($$$$$$) { my ($user, $from, $subj, $date, $loc, $html) = @_; my $tags; ($html, $tags) = ljpost_1 ($user, $from, $subj, $loc, $html); my $priv_p = ($tags && $tags =~ m/^(lj-)?security:/mi); if ($tags && $tags =~ s/^ (?:lj-)? tags?: \s* (.*?) \s* $/$1/mix) { $tags = $1; } else { $tags = undef; # maybe other lj-crud, but not lj-tags. } my @cmd = ($wp_post, "--user", $user, "--body", $html); push @cmd, ("--subject", $subj) if $subj; push @cmd, ("--date", $date) if $date; push @cmd, ("--tags", $tags) if $tags; push @cmd, ("--location", $loc) if $loc; push @cmd, ("--draft") if $priv_p; chdir ($wp_dir) || error ("cd $wp_dir/: $!") if defined ($wp_dir); if ($debug_p) { print STDERR ("#" x 72) . "\nWould have run:\n" . ("#" x 72) . "\n"; foreach my $a (@cmd) { $a =~ s/^\s+|\s+$//gs; if ($a =~ m%[^-a-z\d/_.,]%si) { $a =~ s/'/\\'/gs; $a = "'$a'"; } } print STDERR join(' ', @cmd) . "\n"; } else { # Discard stdout since wppost prints the post-id. open (my $o, '>&', \*STDOUT); open (STDOUT, '>', '/dev/null') unless ($verbose); system (@cmd); open (STDOUT, '>&', $o); } } sub load_keys($) { my ($user) = @_; my $consumer = 'UNKNOWN'; my $consumer_secret = 'UNKNOWN'; my $access = 'UNKNOWN'; my $access_secret = 'UNKNOWN'; # Read our twitter tokens my $twitter_pass_file = "$ENV{HOME}/.$user-twitter-pass"; if (open (my $in, '<', $twitter_pass_file)) { print STDERR "$progname: read $twitter_pass_file\n" if ($verbose); while (<$in>) { s/#.*$//s; if (m/^\s*$/s) { } elsif (m/^consumer\s*=\s*(.*?)\s*$/) { $consumer = $1; } elsif (m/^consumer_secret\s*=\s*(.*?)\s*$/) { $consumer_secret = $1; } elsif (m/^access\s*=\s*(.*?)\s*$/) { $access = $1; } elsif (m/^access_secret\s*=\s*(.*?)\s*$/) { $access_secret = $1; } else { error ("$twitter_pass_file: unparsable line: $_"); } } close $in; } elsif ($debug_p) { print STDERR "$progname: $twitter_pass_file: $!\n"; } else { error ("$twitter_pass_file: $!"); } return ($consumer, $consumer_secret, $access, $access_secret); } sub twitter_status_update($$$$) { my ($user, $txt, $lat, $long) = @_; my ($consumer, $consumer_secret, $access, $access_secret) = load_keys($user); $txt = shorten_urls ($txt); print STDERR "$progname: twit [" . length($txt) . "]: $txt\n" if ($verbose); my $nt = Net::Twitter->new ( traits => [qw/OAuth API::REST WrapError/], consumer_key => $consumer, consumer_secret => $consumer_secret, access_token => $access, access_token_secret => $access_secret, ); if ($debug_p) { print STDERR "$progname: debug: not twitting\n"; return; } my $retries = 3; my $err; for (my $i = 0; $i < $retries; $i++) { my $ret = $nt->update ({status => $txt, lat => $lat, long => $long, display_coordinates => 1}); last if defined ($ret); $err = $nt->get_error()->{error}; } error ("twitter: $err (after $retries tries)") if $err; } sub twit($$$$) { my ($user, $subj, $loc, $html) = @_; my $txt = html_to_text ($html); # Lose all newlines. $txt =~ s/\s+/ /gsi; $txt =~ s/^\s+|\s+$//gsi; $subj =~ s/^\s+|\s+$//gsi; if ($subj) { $subj .= "." unless ($subj =~ m/[^\sA-Z\d]\s*$/si); $txt = "$subj $txt"; $txt =~ s/\.\.\.+\s+\.+/.../g; # conv "subj... ...body" to "subj... body" } $txt = shorten_urls ($txt); # Last resort: if the text is still too long, and there are URLs at the # end, truncate before the URLs instead of after. # 1 while (length($txt) >= 140 && $txt =~ s/^(.*?).((\s+http:[^\s]+)+)\s*$/$1$2/s); # If that fails, just truncate. $txt =~ s/^(.{140}).*$/$1/si; my ($lat, $long); if ($loc) { # Convert "122.412694 W" to "-122.412694". $loc =~ s@\b(\d+\.\d+)\s*([NSEW])\b@{ my ($n, $c) = ($1, uc($2)); $n = -$n if ($c eq 'S' || $c eq 'W'); "$n"; }@gsexi; # Extract the two floats. ($lat, $long) = ($loc =~ m/^\s*(-?\d+\.\d+),?\s+(-?\d+\.\d+)\s*$/s); } twitter_status_update ($user, $txt, $lat || '', $long || ''); } sub cvs(@) { my @files = @_; my $files = join (' ', sort(@files)); return unless $files; my $cmd = ("cd $image_dir" . " && cvs -Q add -kb $files" . " && cvs -Q commit -m '' $files"); if ($debug_p) { print STDERR "$progname: not running: $cmd\n" if ($verbose); } else { print STDERR "$progname: exec: $cmd\n" if ($verbose); system ($cmd); } } # In a multipart/related, there will be an HTML part with IMG tags in it # refering to "cid:" URLs, then a bunch of parts with those IDs. This # divides up the HTML part and interleaves the images in a list. So # we start with something like (HTML, IMG-1, IMG-2, IMG-3) and end up # with (HTML-1, IMG-1, HTML-2, IMG-2, HTML-3, IMG-3, HTML-4). # sub splice_related($$) { my ($main, $imgs) = @_; my @result = (""); foreach my $s (split (m/(]*>)/si, $main)) { if ($s =~ m@^]*? \b src=[\"\'] cid: ([^\"\'<>]+) @six) { my $id = $1; my $img = $imgs->{$id}; error ("unmatched cid: $id") unless $img; push @result, ($img, ""); } else { $result[$#result] .= $s; } } return @result; } # Recursively processes the MIME::Entity, handling multipart entities. # Returns a list of text-chunks and images, in the order encountered. # sub process_part($$@); sub process_part($$@) { my ($part, $depth, @imgs) = @_; my $type = lc($part->effective_type); my $body = $part->bodyhandle; my @result = (); print STDERR "$progname: " . (" " x $depth) . "Content-Type: $type\n" if ($verbose > 1); if ($type eq 'text/plain') { $body = html_quote($body->as_string()); $body =~ s/\n/
\n/gsi; $body .= "

\n"; push @result, $body; } elsif ($type eq 'text/html') { $body = $body->as_string() . '

'; push @result, $body; } elsif ($type =~ m@^(image|video)/@) { push @result, $part; } elsif ($type eq 'multipart/mixed') { foreach my $subpart ($part->parts) { push @result, process_part ($subpart, $depth+1, @imgs); } } elsif ($type eq 'multipart/related') { my $main; my %imgs; foreach my $subpart ($part->parts) { my @p = process_part ($subpart, $depth+1, @imgs); error ("unparsable $type") if ($#p != 0); my $p = $p[0]; if (ref($p) =~ m/^MIME/s) { # It's an image my $id = $subpart->head->get('Content-ID'); error ("no Content-ID in $p") unless $id; $id =~ s/^[\s<]*|[\s>]*$//gsi; $imgs{$id} = $p; } elsif ($main) { error ("multiple roots in $type"); } else { $main = $p; } } push @result, splice_related ($main, \%imgs); } elsif ($type eq 'multipart/alternative') { # # multipart/alternative types are sorted from least to most preferred. # Take the last one in the list that is plain-text, html, or an image. # Ignore all others. # my $prev = undef; foreach my $subpart ($part->parts) { my $subtype = lc($subpart->effective_type); print STDERR "$progname: " . (" " x $depth) . "Subtype: $subtype\n" if ($verbose > 1); if ($subtype =~ m@^text/(plain|html)$@ || $subtype =~ m@^(image|multipart)/@) { $prev = $subpart; } else { print STDERR "$progname: " . (" " x $depth) . " SKIP: $subtype\n" if ($verbose > 1); } } error ("no known subtypes in $type") unless $prev; push @result, process_part ($prev, $depth+1, @imgs); } else { error ("unknown type $type"); } return @result; } # If the HTML contains two or more, assume the layout is two per line. # If any two on the same line mix portrait and landscape orientation, # adjust their width percentages until they are roughly the same height. # sub adjust_image_layout($$) { my ($total_images, $html) = @_; $html =~ s@()\s*( $h)]; $i++; } for (my $j = 0; $j < $i; $j += 2) { if (! defined($imgs[$j+1])) { # single image on line my $w = ($total_images == 1 ? 90 : # only image on page $sizes[$j][2] ? 60 : # portrait, on last line 45); # landscape, on last line $imgs[$j] =~ s/(width:\s*)\d+%/$1${w}%/s; } elsif ($sizes[$j][2] != $sizes[$j+1][2]) { # orientation differs my $r = ($sizes[$j][0] / # ratio of scaled width ($sizes[$j][0] + ($sizes[$j][1] * ($sizes[$j+1][0] / $sizes[$j+1][1])))); my $ww = 90; my $w1 = sprintf("%.1f", $ww * $r); my $w2 = sprintf("%.1f", $ww * (1 - $r)); $imgs[$j] =~ s/(width:\s*)\d+%/$1${w1}%/s; $imgs[$j+1] =~ s/(width:\s*)\d+%/$1${w2}%/s; } else { # same orientation, same width my $w = 45; $imgs[$j] =~ s/(width:\s*)\d+%/$1${w}%/s; $imgs[$j+1] =~ s/(width:\s*)\d+%/$1${w}%/s; } } return join ('', @imgs); } sub post($$$) { my ($lj, $wp, $twit) = @_; my $pass; my $passfile = "$ENV{HOME}/.ljpost-pass"; if (open (my $in, "<$passfile")) { $pass = <$in>; chop ($pass); close $in; } elsif ($debug_p) { print STDERR "$progname: $passfile: $!\n"; $pass = 'DEBUG'; } else { error ("$passfile: $!"); } error ("$passfile: no password") unless ($pass); my $ent; { my $parser = new MIME::Parser; $parser->ignore_errors(1); $parser->tmp_to_core(1); $parser->output_to_core(1); eval { $ent = $parser->parse(\*STDIN); }; my $err = ($@ || $parser->last_error); $parser->filer->purge; error ("parse failed: $err") if ($err); } if ($debug_p > 1) { print STDERR ("#" x 72) . "\nSource message:\n" . ("#" x 72) . "\n"; $ent->print(\*STDERR); print STDERR "\n" . ("#" x 72) . "\n"; } my $head = $ent->head; my $from = $head->get('From'); my $date = $head->get('Date'); my $to = $head->get('To'); my $dto = $head->get('Delivered-To'); my $subj = $head->get('Subject') || ''; my ($topass) = ($to =~ m/^[^\+@]+\+([^\+@]+)\@/s); ($topass) = ($dto =~ m/^[^\+@]+\+([^\+@]+)\@/s) if ($dto && !defined($topass)); error ("no posting password provided: $to") unless ($debug_p || defined($topass)); error ("password mismatch") unless ($debug_p || $pass eq $topass); $subj = decode ('MIME-Header', $subj); # Fucking Unicrud. # Sadly, sending photos with SMS to this address causes the URL on # Sprint's site to reveal my phone number. Avoid mistakenly sending # an SMS instead of an email by just refusing messages from Sprint's # gateway. # error ("no SMS to this address!") if ($from =~ m/sprintpcs\.com/); my $html = ""; my $img_count = 0; my $loc; my %files; foreach my $part (process_part ($ent, 0, ())) { if (ref($part) =~ m/^MIME/s) { # It's an image $img_count++; my $name = $part->head->recommended_filename; my $ct = $part->head->mime_type; my ($big, $thumb, $w, $h, $loc2) = save_image ($name, $ct, $part->bodyhandle->as_string()); my $video_p = ($ct =~ m@video/@si); $files{$1} = 1 if ($big && $big =~ m@([^/]+)$@si); $files{$1} = 1 if ($thumb && $thumb =~ m@([^/]+)$@si); if ($w < $h) { # if it's portrait, shrink it by 1/3rd $w = int($w * 0.666 + 0.5); $h = int($h * 0.666 + 0.5); } my $hh = $h + 16; # for controller $part = ($video_p ? (" \n" . " \n" . " \n" . " \n" . " \n" . " \n" . " " ) : ("" . "" . "")); $part = ("

" . $part . "
\n"); $loc = $loc2 if $loc2; } else { $part = trim_signature($part); $part = clean_html($part); } $html .= $part; } # Group adjacent images together into the same DIV. # 1 while ($html =~ s@( ]*> \s* ) (( ]*> \s* ]*> \s* \s* )+ )
\s* \1 @$1$2@gsix); # If two adjascent images are portrait+landscape, adjust their target widths. # $html =~ s@( ]*> \s* ) ( (?: ]*> \s* ]*> \s* \s* )+ ) ( \s*
) @{ $1 . adjust_image_layout ($img_count, $2) . $3 }@gsexi; if ($img_count > 0) { system ($upload_images_cmd) if (defined($upload_images_cmd) && !$debug_p); } my $tags; ($tags, $html) = split_tag_headers ($html); # Trim newlines since LJ preformats that shit. $html =~ s/\s+/ /gsi; $html =~ s@\s+(= 0) { $_ = shift @ARGV; if (m/^--?verbose$/) { $verbose++; } elsif (m/^-v+$/) { $verbose += length($_)-1; } elsif (m/^--?debug$/) { $debug_p++; } elsif (m/^--?(lj|livejournal)$/) { $lj = shift @ARGV; } elsif (m/^--?(wp|wordpress)$/) { $wp = shift @ARGV; } elsif (m/^--?twit(ter)?$/) { $twit = shift @ARGV; } elsif (m/^-./) { usage; } else { usage; } } if ($debug_p > 1) { my $f = "/tmp/ljpost.log"; unlink $f; print STDERR "$progname: logging to $f\n"; open (STDOUT, ">$f") || error ("$f: $!"); *STDERR = *STDOUT; } usage unless (defined($lj) || defined($wp) || defined($twit)); post ($lj, $wp, $twit); } main(); POSIX::_exit(0); # Something is causing a SEGV at exit! exit 0;