diff options
| author | Silvio Rhatto <rhatto@riseup.net> | 2014-01-27 16:40:54 -0200 |
|---|---|---|
| committer | Silvio Rhatto <rhatto@riseup.net> | 2014-01-27 16:40:54 -0200 |
| commit | 74d5f3ab1c1a7f53b6f66905d0d3304dd7b31de0 (patch) | |
| tree | fed7c8be7453915810194e1c05443f7ef8927a1e | |
| parent | 379e2842c4eaf005ed9a799ce9840d6735a339b2 (diff) | |
| download | scripts-74d5f3ab1c1a7f53b6f66905d0d3304dd7b31de0.tar.gz scripts-74d5f3ab1c1a7f53b6f66905d0d3304dd7b31de0.tar.bz2 | |
Removing ttytter (already on wheezy)
| -rwxr-xr-x | ttytter | 7989 |
1 files changed, 0 insertions, 7989 deletions
diff --git a/ttytter b/ttytter deleted file mode 100755 index eda7a1b..0000000 --- a/ttytter +++ /dev/null @@ -1,7989 +0,0 @@ -#!/usr/bin/perl -s -######################################################################### -# -# TTYtter v2.1 (c)2007-2012 cameron kaiser (and contributors). -# all rights reserved. -# http://www.floodgap.com/software/ttytter/ -# -# distributed under the floodgap free software license -# http://www.floodgap.com/software/ffsl/ -# -# After all, we're flesh and blood. -- Oingo Boingo -# If someone writes an app and no one uses it, does his code run? -- me -# -######################################################################### - -require 5.005; - -BEGIN { - # ONLY STUFF THAT MUST RUN BEFORE INITIALIZATION GOES HERE! - # THIS FUNCTION HAS GOTTEN TOO DAMN CLUTTERED! - -# @INC = (); # wreck intentionally for testing - # dynamically changing PERL_SIGNALS doesn't work in Perl 5.14+ (bug - # 92246). we deal with this by forcing -signals_use_posix if the - # environment variable wasn't already set. - if ($] >= 5.014000 && $ENV{'PERL_SIGNALS'} ne 'unsafe') { - $signals_use_posix = 1; - } else { - $ENV{'PERL_SIGNALS'} = 'unsafe'; - } - - $command_line = $0; $0 = "TTYtter"; - $TTYtter_VERSION = "2.1"; - $TTYtter_PATCH_VERSION = 0; - $TTYtter_RC_NUMBER = 0; # non-zero for release candidate - # this is kludgy, yes. - $LANG = $ENV{'LANG'} || $ENV{'GDM_LANG'} || $ENV{'LC_CTYPE'} || - $ENV{'ALL'}; - $my_version_string = "${TTYtter_VERSION}.${TTYtter_PATCH_VERSION}"; - (warn ("$my_version_string\n"), exit) if ($version); - - $space_pad = " " x 1024; - $background_is_ready = 0; - - # for multi-module extension handling - $multi_module_mode = 0; - $multi_module_context = 0; - $muffle_server_messages = 0; - undef $master_store; - undef %push_stack; - - $padded_patch_version = substr($TTYtter_PATCH_VERSION . " ", 0, 2); - - %opts_boolean = map { $_ => 1 } qw( - ansi noansi verbose superverbose ttytteristas noprompt - seven silent hold daemon script anonymous readline ssl - newline vcheck verify noratelimit notrack nonewrts notimeline - synch exception_is_maskable mentions simplestart - location readlinerepaint nocounter notifyquiet - signals_use_posix dostream nostreamreplies streamallreplies - nofilter - ); %opts_sync = map { $_ => 1 } qw( - ansi pause dmpause ttytteristas verbose superverbose - url rlurl dmurl newline wrap notimeline lists dmidurl - queryurl track colourprompt colourme notrack - colourdm colourreply colourwarn coloursearch colourlist idurl - notifies filter colourdefault backload searchhits dmsenturl - nostreamreplies mentions wtrendurl atrendurl filterusers - filterats filterrts filteratonly filterflags nofilter - ); %opts_urls = map {$_ => 1} qw( - url dmurl uurl rurl wurl frurl rlurl update shorturl - apibase queryurl idurl delurl dmdelurl favsurl - favurl favdelurl followurl leaveurl - dmupdate credurl blockurl blockdelurl friendsurl - modifyliurl adduliurl delliurl getliurl getlisurl getfliurl - creliurl delliurl deluliurl crefliurl delfliurl - getuliurl getufliurl dmsenturl rturl rtsbyurl dmidurl - statusliurl followliurl leaveliurl followersurl - oauthurl oauthauthurl oauthaccurl oauthbase wtrendurl - atrendurl frupdurl lookupidurl rtsofmeurl - ); %opts_secret = map { $_ => 1} qw( - superverbose ttytteristas - ); %opts_comma_delimit = map { $_ => 1 } qw( - lists notifytype notifies filterflags filterrts filterats - filterusers filteratonly - ); %opts_space_delimit = map { $_ => 1 } qw( - track - ); - - %opts_can_set = map { $_ => 1 } qw( - url pause dmurl dmpause superverbose ansi verbose - update uurl rurl wurl avatar ttytteristas frurl track - rlurl noprompt shorturl newline wrap verify autosplit - notimeline queryurl colourprompt colourme - colourdm colourreply colourwarn coloursearch colourlist idurl - urlopen delurl notrack dmdelurl favsurl - favurl favdelurl slowpost notifies filter colourdefault - followurl leaveurl dmupdate mentions backload - lat long location searchhits blockurl blockdelurl woeid - nocounter linelength friendsurl followersurl lists - modifyliurl adduliurl delliurl getliurl getlisurl getfliurl - creliurl delliurl deluliurl crefliurl delfliurl atrendurl - getuliurl getufliurl dmsenturl rturl rtsbyurl wtrendurl - statusliurl followliurl leaveliurl dmidurl nostreamreplies - frupdurl filterusers filterats filterrts filterflags - filteratonly nofilter rtsofmeurl - ); %opts_others = map { $_ => 1 } qw( - lynx curl seven silent maxhist noansi hold status - daemon timestamp twarg user anonymous script readline - leader ssl rc norc vcheck apibase notifytype exts - nonewrts synch runcommand authtype oauthkey oauthsecret - tokenkey tokensecret credurl keyf readlinerepaint - simplestart exception_is_maskable oldperl notco - notify_tool_path oauthurl oauthauthurl oauthaccurl oauthbase - signals_use_posix dostream eventbuf streamallreplies - ); %valid = (%opts_can_set, %opts_others); - $rc = (defined($rc) && length($rc)) ? $rc : ""; - unless ($norc) { - my $rcf = - ($rc =~ m#^/#) ? $rc : "$ENV{'HOME'}/.ttytterrc${rc}"; - if (open(W, $rcf)) { - # 5.14 sets this lazily, so this gives us a way out - eval 'binmode(W, ":utf8")' unless ($seven); - while(<W>) { - chomp; - next if (/^\s*$/ || /^#/); - s/^-//; - ($key, $value) = split(/\=/, $_, 2); - if ($key eq 'rc') { - warn "** that's stupid, setting rc in an rc file\n"; - } elsif ($key eq 'norc') { - warn "** that's dumb, using norc in an rc file\n"; - } elsif (length $$key) { - ; # carry on - } elsif ($valid{$key} && !length($$key)) { - $$key = $value; - } elsif ($key =~ /^extpref_/) { - $$key = $value; - } elsif (!$valid{$key}) { - warn "** setting $key not supported in this version\n"; - } - } - close(W); - } elsif (length($rc)) { - die("couldn't access rc file $rcf: $!\n". - "to use defaults, use -norc or don't specify the -rc option.\n\n"); - } - } - warn "** -twarg is deprecated\n" if (length($twarg)); - $seven ||= 0; - $oldperl ||= 0; - $parent = $$; - $script = 1 if (length($runcommand)); - $supreturnto = $verbose + 0; - $postbreak_time = 0; - $postbreak_count = 0; - - # our minimum official support is now 5.8.6. - if ($] < 5.008006 && !$oldperl) { - die(<<"EOF"); - -*** you are using a version of Perl in "extended" support: $] *** -the minimum tested version of Perl now required by TTYtter is 5.8.6. - -Perl 5.005 thru 5.8.5 probably can still run TTYtter, but they are not -tested with it. if you want to suppress this warning, specify -oldperl on -the command line, or put oldperl=1 in your .ttytterrc. bug patches will -still be accepted for older Perls; see the TTYtter home page for info. - -for Perl 5.005, remember to also specify -seven. - -EOF - } - - # defaults that our extensions can override - $last_id = 0; - $last_dm = 0; - # a correct fix for -daemon would make this unlimited, but this - # is good enough for now. - $print_max ||= ($daemon) ? 999999 : 250; # shiver - - $suspend_output = -1; - - # try to find an OAuth keyfile if we haven't specified key+secret - # no worries if this fails; we could be Basic Auth, after all - $whine = (length($keyf)) ? 1 : 0; - $keyf ||= "$ENV{'HOME'}/.ttytterkey"; - $keyf = "$ENV{'HOME'}/.ttytterkey${keyf}" if ($keyf !~ m#/#); - $attempted_keyf = $keyf; - if (!length($oauthkey) && !length($oauthsecret) # set later - && !length($tokenkey) - && !length($tokensecret) && !$oauthwizard) { - my $keybuf = ''; - if(open(W, $keyf)) { - while(<W>) { - chomp; - s/\s+//g; - $keybuf .= $_; - } - close(W); - my (@pairs) = split(/\&/, $keybuf); - foreach(@pairs) { - my (@pair) = split(/\=/, $_, 2); - $oauthkey = $pair[1] - if ($pair[0] eq 'ck'); - $oauthsecret = $pair[1] - if ($pair[0] eq 'cs'); - $tokenkey = $pair[1] - if ($pair[0] eq 'at'); - $tokensecret = $pair[1] - if ($pair[0] eq 'ats'); - } - die("** tried to load OAuth tokens from $keyf\n". - " but it seems corrupt or incomplete. please see the documentation,\n". - " or delete the file so that we can try making your keyfile again.\n") - if ((!length($oauthkey) || - !length($oauthsecret) || - !length($tokenkey) || - !length($tokensecret))); - } else { - die("** couldn't open keyfile $keyf: $!\n". - "if you want to run the OAuth wizard to create this file, add ". - "-oauthwizard\n") - if ($whine); - $keyf = ''; # i.e., we loaded nothing from a key file - } - } - - # try to init Term::ReadLine if it was requested - # (shakes fist at @br3nda, it's all her fault) - %readline_completion = (); - if ($readline && !$silent && !$script) { - $ENV{"PERL_RL"} = "TTYtter" if (!length($ENV{'PERL_RL'})); - eval -'use Term::ReadLine; $termrl = new Term::ReadLine ("TTYtter", \*STDIN, \*STDOUT)' - || die( - "$@\nthis perl doesn't have ReadLine. don't use -readline.\n"); - $stdout = $termrl->OUT || \*STDOUT; - $stdin = $termrl->IN || \*STDIN; - $readline = '' if ($readline eq '1'); - $readline =~ s/^"//; # for optimizer - $readline =~ s/"$//; - #$termrl->Attribs()->{'autohistory'} = undef; # not yet - (%readline_completion) = map {$_ => 1} split(/\s+/, $readline); - %original_readline = %readline_completion; - # readline repaint can't be tested here. we cache our - # result later. - } else { - $stdout = \*STDOUT; - $stdin = \*STDIN; - } - $wrapseq = 0; - $lastlinelength = -1; - - print $stdout "$leader\n" if (length($leader)); - - # state information - $lasttwit = ''; - $lastpostid = 0; - - # stub namespace for multimodules and (eventually) state saving - undef %store; - $store = \%store; - - $pack_magic = ($] < 5.006) ? '' : "U0"; - $utf8_encode = sub { ; }; - $utf8_decode = sub { ; }; - unless ($seven) { - eval -'use utf8;binmode($stdin,":utf8");binmode($stdout,":utf8");return 1' || - die("$@\nthis perl doesn't fully support UTF-8. use -seven.\n"); - - # this is for the prinput utf8 validator. - # adapted from http://mail.nl.linux.org/linux-utf8/2003-03/msg00087.html - # eventually this will be removed when 5.6.x support is removed, - # and Perl will do the UTF-8 validation for us. - $badutf8='[\x00-\x7f][\x80-\xbf]+|^[\x80-\xbf]+|'. - '[\xc0-\xdf][\x00-\x7f\xc0-\xff]|'. - '[\xc0-\xdf][\x80-\xbf]{2}|'. - '[\xe0-\xef][\x80-\xbf]{0,1}[\x00-\x7f\xc0-\xff]|'. - '[\xe0-\xef][\x80-\xbf]{3}|'. - '[\xf0-\xf7][\x80-\xbf]{0,2}[\x00-\x7f\xc0-\xff]|'. - '[\xf0-\xf7][\x80-\xbf]{4}|'. - '[\xf8-\xfb][\x80-\xbf]{0,3}[\x00-\x7f\xc0-\xff]|'. - '[\xf8-\xfb][\x80-\xbf]{5}|'. - '[\xfc-\xfd][\x80-\xbf]{0,4}[\x00-\x7f\xc0-\xff]|'. - '\xed[\xa0-\xbf][\x80-\xbf]|'. - '\xef\xbf[\xbe-\xbf]|'. - '[\xf0-\xf7][\x8f,\x9f,\xaf,\xbf]\xbf[\xbe-\xbf]|'. - '\xfe|\xff|'. - '[\xc0-\xc1][\x80-\xbf]|'. - '\xe0[\x80-\x9f][\x80-\xbf]|'. - '\xf0[\x80-\x8f][\x80-\xbf]{2}|'. - '\xf8[\x80-\x87][\x80-\xbf]{3}|'. - '\xfc[\x80-\x83][\x80-\xbf]{4}'; # gah! - - eval <<'EOF'; - $utf8_encode = sub { utf8::encode(shift); }; - $utf8_decode = sub { utf8::decode(shift); }; -EOF - } - $wraptime = sub { my $x = shift; return ($x, $x); }; - if ($timestamp) { - my $fail = "-- can't use custom timestamps.\nspecify -timestamp by itself to use Twitter's without module.\n"; - if (length($timestamp) > 1) { # pattern specified - eval 'use Date::Parse;return 1' || - die("$@\nno Date::Parse $fail"); - eval 'use Date::Format;return 1' || - die("$@\nno Date::Format $fail"); - $timestamp = "%Y-%m-%d %k:%M:%S" - if ($timestamp eq "default" || - $timestamp eq "def"); - $wraptime = sub { - my $time = str2time(shift); - my $stime = time2str($timestamp, $time); - return ($time, $stime); - }; - } - } -} -END { - &killkid unless ($in_backticks || $in_buffer); # this is disgusting -} - -#### COMMON STARTUP #### - -# if we requested POSIX signals, or we NEED posix signals (5.14+), we -# must check if we have POSIX signals actually -if ($signals_use_posix) { - eval 'use POSIX'; - # God help the system that doesn't have SIGTERM - $j = eval 'return POSIX::SIGTERM' ; - die(<<"EOF") if (!(0+$j)); -*** death permeates me *** -your configuration requires using POSIX signalling (either Perl 5.14+ or -you specifically asked with -signals_use_posix). however, either you don't -have POSIX.pm, or it doesn't work. - -TTYtter requires 'unsafe' Perl signals (which are of course for its -purposes perfectly safe). unfortunately, due to Perl bug 92246 5.14+ must -use POSIX.pm, or have the switch set before starting TTYtter. run one of - -export PERL_SIGNALS=unsafe # sh, bash, ksh, etc. -setenv PERL_SIGNALS unsafe # csh, tcsh, etc. - -and restart TTYtter, or use Perl 5.12 or earlier (without specifying --signals_use_posix). -EOF -} - -# do we have POSIX::Termios? (usually we do) -eval 'use POSIX; $termios = new POSIX::Termios;'; -print $stdout "-- termios test: $termios\n" if ($verbose); - -# check the TRLT version. versions < 1.3 won't work with 2.0. -if ($termrl && $termrl->ReadLine eq 'Term::ReadLine::TTYtter') { - eval '$trlv = $termrl->Version;'; - die (<<"EOF") if (length($trlv) && 0+$trlv < 1.3); -*** death permeates me *** -you need to upgrade your Term::ReadLine::TTYtter to at least version 1.3 -to use TTYtter 2.x, or bad things will happen such as signal mismatches, -unexpected quits, and dogs and cats living peacefully in the same house. - -EOF - print $stdout "** t.co support needs Term::ReadLine:TTYtter 1.4+ (-notco to ignore)\n" - if (length($trlv) && !$notco && 0+$trlv < 1.4); -} - -# try to get signal numbers for SIG* from POSIX. use internals if failed. -eval 'use POSIX; $SIGUSR1 = POSIX::SIGUSR1; $SIGUSR2 = POSIX::SIGUSR2; $SIGHUP = POSIX::SIGHUP; $SIGTERM = POSIX::SIGTERM'; -# from <sys/signal.h> -$SIGHUP ||= 1; -$SIGTERM ||= 15; -$SIGUSR1 ||= 30; -$SIGUSR2 ||= 31; - -# wrap warning -die( -"** dude, what the hell kind of terminal can't handle a 5 character line?\n") - if ($wrap > 1 && $wrap < 5); -print $stdout "** warning: prompts not wrapped for wrap < 70\n" - if ($wrap > 1 && $wrap < 70); - -# reject stupid combinations -die("you can't use automatic ratelimits with -noratelimit.\nuse -pause=#sec\n") - if ($noratelimit && $pause eq 'auto'); -die("you can't use -synch with -script or -daemon.\n") - if ($synch && ($script || $daemon)); -die("-script and -daemon cannot be used together.\n") - if ($script && $daemon); - -# set up menu codes and caches -$is_background = 0; -$alphabet = "abcdefghijkLmnopqrstuvwxyz"; -%store_hash = (); -$mini_split = 250; # i.e., 10 tweets for the mini-menu (/th) -# leaving 50 tweets for the foreground temporary menus -$tweet_counter = 0; -%dm_store_hash = (); -$dm_counter = 0; -%id_cache = (); -%filter_next = (); - -# set up threading management -$in_reply_to = 0; -$expected_tweet_ref = undef; - -# interpret -script at this level -if ($script) { - $noansi = $noprompt = 1; - $silent = ($verbose) ? 0 : 1; - $pause = $vcheck = $slowpost = $verify = 0; -} - -### now instantiate the TTYtter dynamic API ### -### based off the defaults later in script. #### - -# first we need to load any extensions specified by -exts. -if (length($exts) && $exts ne '0') { - $multi_module_mode = -1; # mark as loader stage - - print "** attempting to load extensions\n" unless ($silent); - # unescape \, - $j=0; $xstring = "ESCAPED_STRING"; - while($exts =~ /$xstring$j/) { $j++; } - $xstring .= $j; - $exts =~ s/\\,/$xstring/g; - foreach $file (split(/,/, $exts)) { -#TODO -# wildcards? - $file =~ s/$xstring/,/g; - print "** loading $file\n" unless ($silent); - - die("** sorry, you cannot load the same extension twice.\n") - if ($master_store->{$file}->{'loaded'}); - - # prepare its working space in $store and load the module - $master_store->{$file} = { 'loaded' => 1 }; - $store = \%{ $master_store->{$file} }; - $EM_DONT_CARE = 0; - $EM_SCRIPT_ON = 1; - $EM_SCRIPT_OFF = -1; - $extension_mode = $EM_DONT_CARE; - die("** $file not found: $!\n") if (! -r "$file"); - require $file; # and die if bad - die("** $file failed to load: $@\n") if ($@); - die("** consistency failure: reference failure on $file\n") - if (!$store->{'loaded'}); - - # check type of extension (interactive or non-interactive). if - # we are in the wrong mode, bail out. - if ($extension_mode) { - die( -"** this extension requires -script. this may conflict with other extensions\n". -" you are loading, which may have their own requirements.\n") - if ($extension_mode == $EM_SCRIPT_ON && !$script); - die( -"** this extension cannot work with -script. this may conflict with other\n". -" extensions you are loading, which may have their own requirements.\n") - if ($extension_mode == $EM_SCRIPT_OFF && $script); - } - - # pick off all the subroutine references it makes for storage - # in an array to iterate and chain over later. - - # these methods are multi-module safe - foreach $arry (qw( - handle exception tweettype conclude dmhandle dmconclude - heartbeat precommand prepost postpost addaction - eventhandle listhandle userhandle shutdown)) { - if (defined($$arry)) { - $aarry = "m_$arry"; - push(@$aarry, [ $file, $$arry ]); - undef $$arry; - } - } - # these methods are NOT multi-module safe - # if a extension already hooked one of - # these and another extension tries to hook it, fatal error. - foreach $arry (qw( - getpassword prompt main autocompletion)) { - if (defined($$arry)) { - $sarry = "l_$arry"; - if (defined($$sarry)) { - die( -"** double hook of unsafe method \"$arry\" -- you cannot use this extension\n". -" with the other extensions you are loading. see the documentation.\n"); - } - $$sarry = $$arry; - undef $$arry; - } - } - } - # success! enable multi-module support in the TTYtter API and then - # dispatch calls through the multi-module system instead. - $multi_module_mode = 1; # mark as completed loader - - $handle = \&multihandle; - $exception = \&multiexception; - $tweettype = \&multitweettype; - $conclude = \&multiconclude; - $dmhandle = \&multidmhandle; - $dmconclude = \&multidmconclude; - $heartbeat = \&multiheartbeat; - $precommand = \&multiprecommand; - $prepost = \&multiprepost; - $postpost = \&multipostpost; - $addaction = \&multiaddaction; - $shutdown = \&multishutdown; - $userhandle = \&multiuserhandle; - $listhandle = \&multilisthandle; - $eventhandle = \&multieventhandle; - -} else { - # the old API single-end-point system - - $multi_module_mode = 0; # not executing multi module endpoints - - $handle = \&defaulthandle; - $exception = \&defaultexception; - $tweettype = \&defaulttweettype; - $conclude = \&defaultconclude; - $dmhandle = \&defaultdmhandle; - $dmconclude = \&defaultdmconclude; - $heartbeat = \&defaultheartbeat; - $precommand = \&defaultprecommand; - $prepost = \&defaultprepost; - $postpost = \&defaultpostpost; - $addaction = \&defaultaddaction; - $shutdown = \&defaultshutdown; - $userhandle = \&defaultuserhandle; - $listhandle = \&defaultlisthandle; - $eventhandle = \&defaulteventhandle; -} - -# unsafe methods use the single-end-point -$prompt = $l_prompt || \&defaultprompt; -$main = $l_main || \&defaultmain; -$getpassword = $l_getpassword || \&defaultgetpassword; - -# $autocompletion is special: -if ($termrl) { - $termrl->Attribs()->{'completion_function'} = - $l_autocompletion || \&defaultautocompletion; -} - -# fetch_id is based off last_id, if an extension set it -$fetch_id = $last_id || 0; - -# validate the notify method the user chose, if any. -# we can't do this in BEGIN, because it may not be instantiated yet, -# and we have to do it after loading modules because it might be in one. -@notifytypes = (); -if (length($notifytype) && $notifytype ne '0' && - $notifytype ne '1' && !$status) { - # NOT $script! scripts have a use case for notifiers! - - %dupenet = (); - foreach $nt (split(/\s*,\s*/, $notifytype)) { - $fnt="notifier_${nt}"; - (warn("** duplicate notification $nt was ignored\n"), next) - if ($dupenet{$fnt}); - eval 'return &$fnt(undef)' || - die("** invalid notification framework $nt: $@\n"); - $dupenet{$fnt}=1; - } - @notifytypes = keys %dupenet; - $notifytype = join(',', @notifytypes); - # warning if someone didn't tell us what notifies they wanted. - warn "-- warning: you specified -notifytype, but no -notifies\n" - if (!$silent && !length($notifies)); -} - -# set up track tags -if (length($tquery) && $tquery ne '0') { - my $xtquery = &tracktags_tqueryurlify($tquery); - die("** custom tquery is over 140 length: $xtquery\n") - if (length($xtquery) > 139); - @trackstrings = ($xtquery); -} else { - &tracktags_makearray; -} - -# compile filterflags -&filterflags_compile; - -# compile filters -exit(1) if (!&filter_compile); -$filterusers_sub = &filteruserlist_compile(undef, $filterusers); -$filterrts_sub = &filteruserlist_compile(undef, $filterrts); -$filteratonly_sub = &filteruserlist_compile(undef, $filteratonly); -exit(1) if (!&filterats_compile); - -# compile lists -exit(1) if (!&list_compile); - -# finally, compile notifies. we do this regardless of notifytype, so that -# an extension can look at it if it wants to. -¬ify_compile; - -# check that we are using a sensible authtype, based on our guessed user agent -$authtype ||= "oauth"; -die("** supported authtypes are basic or oauth only.\n") -if ($authtype ne 'basic' && $authtype ne 'oauth'); - -if ($termrl) { - $streamout = $stdout; # this is just simpler instead of dupping - warn(<<"EOF") if ($] < 5.006); -*********************************************************** -** -readline may not function correctly on Perls < 5.6.0 ** -*********************************************************** -EOF - print $stdout "-- readline using ".$termrl->ReadLine."\n"; -} else { - # dup $stdout for benefit of various other scripts - open(DUPSTDOUT, ">&STDOUT") || - warn("** warning: could not dup $stdout: $!\n"); - binmode(DUPSTDOUT, ":utf8") unless ($seven); - $streamout = \*DUPSTDOUT; -} -if ($silent) { - close($stdout); - open($stdout, ">>/dev/null"); # KLUUUUUUUDGE -} - -# after this point, die() may cause problems - -# initialize our route back out so background can talk to foreground -pipe(W, P) || die("pipe() error [or your Perl doesn't support it]: $!\n"); -select(P); $|++; -binmode(P, ":utf8") unless ($seven); -binmode(W, ":utf8") unless ($seven); - -# default command line options - -$anonymous ||= 0; -die("** -anonymous is no longer supported with Twitter (you must use -apibase also)\n") - if ($anonymous && !length($apibase)); -undef $user if ($anonymous); -print $stdout "-- using SSL for default URLs.\n" if ($ssl); -$http_proto = ($ssl) ? 'https' : 'http'; - -$lat ||= undef; -$long ||= undef; -$location ||= 0; -$linelength ||= 140; -$oauthbase ||= $apibase || "${http_proto}://api.twitter.com"; -# this needs to be AFTER oauthbase so that apibase can set oauthbase. -$apibase ||= "${http_proto}://api.twitter.com/1.1"; -$nonewrts ||= 0; - -# special case: if we explicitly refuse backload, don't load initially. -$backload = 30 if (!defined($backload)); # zero is valid! -$dont_refresh_first_time = 1 if (!$backload); - -$searchhits ||= 20; -$url ||= "${apibase}/statuses/home_timeline.json"; - -$oauthurl ||= "${oauthbase}/oauth/request_token"; -$oauthauthurl ||= "${oauthbase}/oauth/authorize"; -$oauthaccurl ||= "${oauthbase}/oauth/access_token"; - -$credurl ||= "${apibase}/account/verify_credentials.json"; -$update ||= "${apibase}/statuses/update.json"; -$rurl ||= "${apibase}/statuses/mentions_timeline.json"; -$uurl ||= "${apibase}/statuses/user_timeline.json"; -$idurl ||= "${apibase}/statuses/show.json"; -$delurl ||= "${apibase}/statuses/destroy/%I.json"; - -$rturl ||= "${apibase}/statuses/retweet"; -$rtsbyurl ||= "${apibase}/statuses/retweets/%I.json"; -$rtsofmeurl ||= "${apibase}/statuses/retweets_of_me.json"; - -$wurl ||= "${apibase}/users/show.json"; - -$frurl ||= "${apibase}/friendships/show.json"; -$followurl ||= "${apibase}/friendships/create.json"; -$leaveurl ||= "${apibase}/friendships/destroy.json"; -$blockurl ||= "${apibase}/blocks/create.json"; -$blockdelurl ||= "${apibase}/blocks/destroy.json"; -$friendsurl ||= "${apibase}/friends/ids.json"; -$followersurl ||= "${apibase}/followers/ids.json"; -$frupdurl ||= "${apibase}/friendships/update.json"; -$lookupidurl ||= "${apibase}/users/lookup.json"; - -$rlurl ||= "${apibase}/application/rate_limit_status.json"; - -$dmurl ||= "${apibase}/direct_messages.json"; -$dmsenturl ||= "${apibase}/direct_messages/sent.json"; -$dmupdate ||= "${apibase}/direct_messages/new.json"; -$dmdelurl ||= "${apibase}/direct_messages/destroy.json"; -$dmidurl ||= "${apibase}/direct_messages/show.json"; - -$favsurl ||= "${apibase}/favorites/list.json"; -$favurl ||= "${apibase}/favorites/create.json"; -$favdelurl ||= "${apibase}/favorites/destroy.json"; - -$getlisurl ||= "${apibase}/lists/list.json"; -$creliurl ||= "${apibase}/lists/create.json"; -$delliurl ||= "${apibase}/lists/destroy.json"; -$modifyliurl ||= "${apibase}/lists/update.json"; -$deluliurl ||= "${apibase}/lists/members/destroy_all.json"; -$adduliurl ||= "${apibase}/lists/members/create_all.json"; -$getuliurl ||= "${apibase}/lists/memberships.json"; -$getufliurl ||= "${apibase}/lists/subscriptions.json"; -$delfliurl ||= "${apibase}/lists/subscribers/destroy.json"; -$crefliurl ||= "${apibase}/lists/subscribers/create.json"; -$getfliurl ||= "${apibase}/lists/subscribers.json"; -$getliurl ||= "${apibase}/lists/members.json"; -$statusliurl ||= "${apibase}/lists/statuses.json"; - -$streamurl ||= "https://userstream.twitter.com/2/user.json"; -$dostream ||= 0; -$eventbuf ||= 0; - -$queryurl ||= "${apibase}/search/tweets.json"; -# no more $trendurl in 2.1. -$wtrendurl ||= "${apibase}/trends/place.json"; -$atrendurl ||= "${apibase}/trends/closest.json"; - -# pick ONE! -#$shorturl ||= "http://api.tr.im/v1/trim_simple?url="; -$shorturl ||= "http://is.gd/api.php?longurl="; - -# figure out the domain to stop shortener loops -&generate_shortdomain; - -$pause = (($anonymous) ? 120 : "auto") if (!defined $pause); - # NOT ||= ... zero is a VALID value! -$superverbose ||= 0; -$avatar ||= ""; -$urlopen ||= 'echo %U'; -$hold ||= 0; -$daemon ||= 0; -$maxhist ||= 19; -undef $shadow_history; -$timestamp ||= 0; -$noprompt ||= 0; -$slowpost ||= 0; -$twarg ||= undef; - -$verbose ||= $superverbose; -$dmpause = 4 if (!defined $dmpause); # NOT ||= ... zero is a VALID value! -$dmpause = 0 if ($anonymous); -$dmpause = 0 if ($pause eq '0'); -$ansi = ($noansi) ? 0 : - (($ansi || $ENV{'TERM'} eq 'ansi' || $ENV{'TERM'} eq 'xterm-color') - ? 1 : 0); - -# synch overrides these options. -if ($synch) { - $pause = 0; - $dmpause = ($dmpause) ? 1 : 0; -} - -$dmcount = $dmpause; -$lastshort = undef; - -# ANSI sequences -$colourprompt ||= "CYAN"; -$colourme ||= "YELLOW"; -$colourdm ||= "GREEN"; -$colourreply ||= "RED"; -$colourwarn ||= "MAGENTA"; -$coloursearch ||= "CYAN"; -$colourlist ||= "OFF"; -$colourdefault ||= "OFF"; -$ESC = pack("C", 27); -$BEL = pack("C", 7); -&generate_ansi; - -# to force unambiguous bareword interpretation -$true = 'true'; -sub true { return 'true'; } -$false = 'false'; -sub false { return 'false'; } -$null = undef; -sub null { return undef; } - -select($stdout); $|++; - -# figure out what our user agent should be -if ($lynx) { - if (length($lynx) > 1 && -x "/$lynx") { - $wend = $lynx; - print $stdout "Lynx forced to $wend\n"; - } else { - $wend = &wherecheck("trying to find Lynx", "lynx", -"specify -curl to use curl instead, or just let TTYtter autodetect stuff.\n"); - } -} else { - if (length($curl) > 1 && -x "/$curl") { - $wend = $curl; - print $stdout "cURL forced to $wend\n"; - } else { - $wend = (($curl) ? &wherecheck("trying to find cURL", "curl", -"specify -lynx to use Lynx instead, or just let TTYtter autodetect stuff.\n") - : &wherecheck("trying to find cURL", "curl")); - if (!$curl && !length($wend)) { - $wend = &wherecheck("failed. trying to find Lynx", - "lynx", - "you must have either Lynx or cURL installed to use TTYtter.\n") - if (!length($wend)); - $lynx = 1; - } else { - $curl = 1; - } - } -} -$baseagent = $wend; - -# whoops, no Lynx here if we are not using Basic Auth - die( -"sorry, OAuth is not currently supported with Lynx.\n". -"you must use SSL cURL, or specify -authtype=basic.\n") - if ($lynx && $authtype ne 'basic' && !$anonymous); - -# streaming API has multiple prereqs. not fatal; we just fall back on the -# REST API if not there. -unless($status) { -if (!$dostream || $authtype eq 'basic' || !$ssl || $script || $anonymous || $synch) { - $reason = (!$dostream) ? "(no -dostream)" - : ($script) ? "(-script)" - : (!$ssl) ? "(no SSL)" - : ($anonymous) ? "(-anonymous)" - : ($synch) ? "(-synch)" - : ($authtype eq 'basic') ? "(no OAuth)" - : "(it's funkatron's fault)"; - print $stdout - "-- Streaming API disabled $reason (TTYtter will use REST API only)\n"; - $dostream = 0; - } else { - print $stdout "-- Streaming API enabled\n"; - - # streams change mentions behaviour; we get them automatically. - # warn the user if the current settings are suboptimal. - if ($mentions) { - if ($nostreamreplies) { - print $stdout -"** warning: -mentions and -nostreamreplies are very inefficient together\n"; - } else { - print $stdout -"** warning: -mentions not generally needed in Streaming mode\n"; - } - } - } -} else { $dostream = 0; } # -status suppresses streaming -if (!$dostream && $streamallreplies) { - print $stdout -"** warning: -streamallreplies only works in Streaming mode\n"; -} - -# create and cache the logic for our selected user agent -if ($lynx) { - $simple_agent = "$baseagent -nostatus -source"; - - @wend = ('-nostatus'); - @wind = (@wend, '-source'); # GET agent - @wend = (@wend, '-post_data'); # POST agent - # we don't need to have the request signed by Lynx right now; - # it doesn't know how to pass custom headers. so this is simpler. - $stringify_args = sub { - my $basecom = shift; - my $resource = shift; - my $data = shift; - my $dont_do_auth = shift; - my $k = join("\n", @_); - - # if resource is an arrayref, then it's a GET with URL - # and args (mostly generated by &grabjson) - $resource = join('?', @{ $resource }) - if (ref($resource) eq 'ARRAY'); - die("wow, we have a bug: Lynx only works with Basic Auth\n") - if ($authtype ne 'basic' && !$dont_do_auth); - $k = "-auth=".$mytoken.':'.$mytokensecret."\n".$k - unless ($dont_do_auth); - $k .= "\n"; - $basecom = "$basecom \"$resource\" -"; - return ($basecom, $k, $data); - }; -} else { - $simple_agent = "$baseagent -s -m 20"; - - @wend = ('-s', '-m', '20', '-A', "TTYtter/$TTYtter_VERSION", - '-H', 'Expect:'); - @wind = @wend; - $stringify_args = sub { - my $basecom = shift; - my $resource = shift; - my $data = shift; - my $dont_do_auth = shift; - my $p; - my $l = ''; - - foreach $p (@_) { - if ($p =~ /^-/) { - $l .= "\n" if (length($l)); - $l .= "$p "; - next; - } - $l .= $p; - } - $l .= "\n"; - - # sign our request (Basic Auth or oAuth) - unless ($dont_do_auth) { - if ($authtype eq 'basic') { - $l .= "-u ".$mytoken.":".$mytokensecret."\n"; - } else { - my $nonce; - my $timestamp; - my $sig; - my $verifier = ''; - my $header; - my $ttoken = (length($mytoken) ? - (' oauth_token=\\"'.$mytoken.'\\",') : - ''); - - ($timestamp, $nonce, $sig, $verifier) = - &signrequest($resource, $data); - $header = <<"EOF"; --H "Authorization: OAuth oauth_nonce=\\"$nonce\\", oauth_signature_method=\\"HMAC-SHA1\\", oauth_timestamp=\\"$timestamp\\", oauth_consumer_key=\\"$oauthkey\\", oauth_signature=\\"$sig\\",${ttoken}${verifier} oauth_version=\\"1.0\\"" -EOF - print $stdout $header if ($superverbose); - $l .= $header; - } - } - - # if resource is an arrayref, then it's a GET with URL - # and args (mostly generated by &grabjson) - $resource = join('?', @{ $resource }) - if (ref($resource) eq 'ARRAY'); - $l .= "url = \"$resource\"\n"; - $l .= "data = \"$data\"\n" if length($data); - return ("$basecom -K -", $l, undef); - }; -} - -# update check -if ($vcheck && !length($status)) { - $vs = &updatecheck(0); -} else { - $vs = -"-- no version check performed (use /vcheck, or -vcheck to check on startup)\n" - unless ($script || $status); -} -print $stdout $vs; # and then again when client starts up - -## make sure we have all the authentication pieces we need for the -## chosen method (authtoken handles this for Basic Auth; -## this is where we validate OAuth) - -# if we use OAuth, then don't use any Basic Auth credentials we gave -# unless we specifically say -authtype=basic -if ($authtype eq 'oauth' && length($user)) { - print "** warning: -user is ignored when -authtype=oauth (default)\n"; - $user = undef; -} -$whoami = (split(/\:/, $user, 2))[0] unless ($anonymous || !length($user)); - -# yes, this is plaintext. obfuscation would be ludicrously easy to crack, -# and there is no way to hide them effectively or fully in a Perl script. -# so be a good neighbour and leave this the fark alone, okay? stealing -# credentials is mean and inconvenient to users. this is blessed by -# arrangement with Twitter. don't be a d*ck. thanks for your cooperation. -$oauthkey = (!length($oauthkey) || $oauthkey eq 'X') ? - "XtbRXaQpPdfssFwdUmeYw" : $oauthkey; -$oauthsecret = (!length($oauthsecret) || $oauthsecret eq 'X') ? - "csmjfTQPE8ZZ5wWuzgPJPOBR9dyvOBEtHT5cJeVVmAA" : $oauthsecret; - -unless ($anonymous) { -# if we are using Basic Auth, ignore any user token we may have in -# our keyfile -if ($authtype eq 'basic') { - $tokenkey = undef; - $tokensecret = undef; -} -# but if we are using OAuth, we can request one, unless we are in script -elsif ($authtype eq 'oauth' && (!length($keyf) || $oauthwizard)) { - if (length($oauthkey) && length($oauthsecret) && - !length($tokenkey) && !length($tokensecret)) { - # we have a key, we don't have the user token - # but we can't get that with -script - if ($script) { - print $streamout <<"EOF"; -AUTHENTICATION FAILURE -YOU NEED TO GET AN OAuth KEY, or use -authtype=basic -(run TTYtter without -script or -runcommand for help) -EOF - exit; - } - # run the wizard, which writes a keyfile for us - $keyf ||= $attempted_keyf; - print $stdout <<"EOF"; - -+----------------------------------------------------------------------------+ -|| WELCOME TO TTYtter: Authorize TTYtter by signing into Twitter with OAuth || -+----------------------------------------------------------------------------+ -Looks like you're starting TTYtter for the first time, and/or creating a -keyfile. Welcome to the most user-hostile, highly obfuscated, spaghetti code -infested and obscenely obscure Twitter client that's out there. You'll love it. - -TTYtter generates a keyfile that contains credentials for you, including your -access tokens. This needs to be done JUST ONCE. You can take this keyfile with -you to other systems. If you revoke TTYtter's access, you must remove the -keyfile and start again with a new token. You need to do this once per account -you use with TTYtter; only one account token can be stored per keyfile. If you -have multiple accounts, use -keyf=... to specify different keyfiles. KEEP THESE -FILES SECRET. - -** This wizard will overwrite $keyf -Press RETURN/ENTER to continue or CTRL-C NOW! to abort. -EOF - $j = <STDIN>; - print $stdout "\nRequest from $oauthurl ..."; - ($tokenkey, $tokensecret) = &tryhardfortoken($oauthurl, - "oauth_callback=oob"); - $mytoken = $tokenkey; - $mytokensecret = $tokensecret; # needs to be in both places - # kludge in case user does not specify SSL and this is - # Twitter: we know Twitter supports SSL - ($oauthauthurl =~ /twitter/) && - ($oauthauthurl =~ s/^http:/https:/); - print $stdout <<"EOF"; - -1. Visit, in your browser, ALL ON ONE LINE, - -${oauthauthurl}?oauth_token=$mytoken - -2. If you are not already signed in, fill in your username and password. - -3. Verify that TTYtter is the requesting application, and that its permissions -are as you expect (read your timeline, see who you follow and follow new -people, update your profile, post tweets on your behalf and access your -direct messages). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW! - -4. Click Authorize app. - -5. A PIN will appear. Enter it below. - -EOF - $j = ''; - while(!(0+$j)) { - print $stdout "Enter PIN> "; - chomp($j = <STDIN>); - } - print $stdout "\nRequest from $oauthaccurl ..."; - ($tokenkey, $tokensecret) = &tryhardfortoken($oauthaccurl, - "oauth_verifier=$j"); - - $oauthkey = "X"; - $oauthsecret = "X"; - open(W, ">$keyf") || - die("Failed to write keyfile $keyf: $!\n"); - print W <<"EOF"; -ck=${oauthkey}&cs=${oauthsecret}&at=${tokenkey}&ats=${tokensecret} -EOF - close(W); - chmod(0600, $keyf) || print $stdout - "Warning: could not change permissions on $keyf : $!\n"; - print $stdout <<"EOF"; -Written keyfile $keyf - -Now, restart TTYtter to use this keyfile. -(To choose between multiple keyfiles other than the default .ttytterkey, - tell TTYtter where the key is using -keyf=... .) - -EOF - exit; - } - # if we get three of the four, this must have been command line - if (length($oauthkey) && length($oauthsecret) && - (!length($tokenkey) || !length($tokensecret))) { - my $error = undef; - my $k; - foreach $k (qw(oauthkey oauthsecret tokenkey tokensecret)) { - $error .= "** you need to specify -$k\n" - if (!length($$k)); - } - if (length($error)) { - print $streamout <<"EOF"; - -you are missing portions of the OAuth sequence. either create a keyfile -and point to it with -keyf=... or add these missing pieces: -$error -then restart TTYtter, or use -authtype=basic. -EOF - exit; - } - } -} elsif ($retoke && length($keyf)) { - # start the "re-toke" wizard to convert DM-less cloned app keys. - # dup STDIN for systems that can only "close" it once - open(STDIN2, "<&STDIN") || die("couldn't dup STDIN: $!\n"); - print $stdout <<"EOF"; - -+-------------------------------------------------------------------------+ -|| The Re-Toke Wizard: Generate a new TTYtter keyfile for your app/token || -+-------------------------------------------------------------------------+ -Twitter is requiring tokens to now have specific permissions to READ -direct messages. This will be enforced by 1 July 2011. If you find you are -unable to READ direct messages, you will need this wizard. DO NOT use this -wizard if you are NOT using a cloned app key (1.2 and on) -- use -oauthwizard. - -This wizard will create a new keyfile for you from your app/user keys/tokens. -You do NOT need this wizard if you are using TTYtter for a purpose that does -not require direct message access. For example, if TTYtter is acting as -your command line posting agent, or you are only using it to read your -timeline, you do NOT need a new token. You also do not need a new token to -SEND a direct message, only to READ ones this account has received. - -You SHOULD NOT need this wizard if your app key was cloned after 1 June 2011. -However, you can still use it if you experience this specific issue with DMs, -or need to rebuild your keyfile for any other reason. - -** This wizard will overwrite the key at $keyf -** To change this, restart TTYtter with -retoke -keyf=/path/to/keyfile -Press RETURN/ENTER to continue, or CTRL-C NOW! to abort. -EOF - - $j = <STDIN>; - print $stdout <<"EOF"; - -First: let's get your API key, consumer key and consumer secret. -Start your browser. -1. Log into https://twitter.com/ with your desired account. -2. Go to this URL. You must be logged into Twitter FIRST! - -https://dev.twitter.com/apps - -3. Click the TTYtter cloned app key you need to regenerate or upgrade. -4. Click Edit Application Settings. -5. Make sure Read, Write & Private Message is selected, and click the - "Save application" button. -6. Select All (CTRL/Command-A) on the next screen, copy (CTRL/Command-C) it, - and paste (CTRL/Command-V) it into this window. (You can also cut and - paste a smaller section if I can't understand your browser's layout.) -7. Press ENTER/RETURN and CTRL-D when you have pasted the window contents. -EOF - - $q = $/; - PASTE1LOOP: for(;;) { - print $stdout <<"EOF"; - --- Press ENTER and CTRL-D AFTER you have pasted the window contents! --------- -Go ahead: -EOF - undef $/; - $j = <STDIN2>; - print $stdout <<"EOF"; - --- EOF ----------------------------------------------------------------------- -Processing ... - -EOF - $j =~ s/[\r\n]/ /sg; - - # process this. as a checksum, API key should == consumer key. - $ck = ''; - $cs = ''; - ($j =~ /Consumer key\s+([-a-zA-Z0-9_]{10,})\s+/) && ($ck = $1); - ($j =~ /Consumer secret\s+([-a-zA-Z0-9_]{10,})\s+/) && - ($cs = $1); - - if (!length($ck) || !length($cs)) { - # escape hatch - print $stdout <<"EOF"; -Something's wrong: I could not find your consumer key or consumer -secret in that text. If this was a misfired paste, please restart the wizard. -Otherwise, bug me at \@ttytter or ckaiser\@floodgap.com. Please don't send -keys or secrets to either address. - -EOF - exit; - } - last PASTE1LOOP; - } - # this part is similar to the retoke. - $oauthkey = $ck; - $oauthsecret = $cs; - print $stdout "\nI'm testing this key to see if it works.\n"; - print $stdout "Request from $oauthurl ..."; - ($tokenkey, $tokensecret) = &tryhardfortoken($oauthurl, - "oauth_callback=oob"); - $mytoken = $tokenkey; - $mytokensecret = $tokensecret; - # kludge in case user does not specify SSL and this is - # Twitter: we know Twitter supports SSL - ($oauthauthurl =~ /twitter/) && ($oauthauthurl =~ s/^http:/https:/); - $/ = $q; - print $stdout <<"EOF"; - -Okay, your consumer key is ==> $ck - and your consumer secret ==> $cs - -IF THIS IS WRONG, PRESS CTRL-C NOW AND RESTART THE WIZARD! - -Now we will verify your Imperial battle station is fully operational by -signing in with OAuth. - -1. Visit, in your browser, ALL ON ONE LINE (you should still be logged in), - -${oauthauthurl}?oauth_token=$mytoken - -2. Verify that your app is the requesting application, and that its permissions -are as you expect (read your timeline, see who you follow and follow new -people, update your profile, post tweets on your behalf and access your -direct messages). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW! - -3. Click Authorize app. - -4. A PIN will appear. Enter it below. - -EOF - print $stdout "Enter PIN> "; - chomp($j = <STDIN>); - print $stdout "\nRequest from $oauthaccurl ..."; - ($at, $ats) = &tryhardfortoken($oauthaccurl, "oauth_verifier=$j"); - - print $stdout <<"EOF"; - -Consumer key =========> $ck -Consumer secret ======> $cs -Access token =========> $at -Access token secret ==> $ats - -EOF - open(W, ">$keyf") || (print $stdout ("Unable to write to $keyf: $!\n"), - exit); - print W "ck=$ck&cs=$cs&at=$at&ats=$ats\n"; - close(W); - chmod(0600, $keyf) || print $stdout -"Warning: could not change permissions on $keyf : $!\n"; - print $stdout "Keys written to regenerated keyfile $keyf\n"; - print $stdout "Now restart TTYtter.\n"; - exit; -} - -# now, get a token (either from Basic Auth, the keyfile or OAuth) -($mytoken, $mytokensecret) = &authtoken; -} # unless anonymous - -# if we are testing the stream, this is where we split -if ($streamtest) { - print $stdout ">>> STREAMING CONNECT TEST <<< (kill process to end)\n"; - &start_streaming; } # this never returns in this mode - -# initial login tests and command line controls -if ($statusurl) { - $shorstatusturl = &urlshorten($statusurl); - $status = ((length($status)) ? "$status " : "") . $shorstatusturl; -} -$phase = 0; -$didhold = $hold; -$hold = -1 if ($hold == 1 && !$script); -$credentials = ''; -$status = pack("U0C*", unpack("C*", $status)) - unless ($seven || !length($status) || $LANG =~ /8859/); # kludgy also -if ($status eq '-') { - chomp(@status = <STDIN>); - $status = join("\n", @status); -} -for(;;) { - $rv = 0; - die( - "sorry, you can't tweet anonymously. use an authenticated username.\n") - if ($anonymous && length($status)); - die( -"sorry, status too long: reduce by @{[ &length_tco($status)-$linelength ]} chars, ". -"or use -autosplit={word,char,cut}.\n") - if (&length_tco($status) > $linelength && !$autosplit); - ($status, $next) = &csplit($status, ($autosplit eq 'char' || - $autosplit eq 'cut') ? 1 : 0) - if (!length($next)); - if ($autosplit eq 'cut' && length($next)) { - print "-- warning: input autotrimmed to $linelength bytes\n"; - $next = ""; - } - if (!$anonymous && !length($whoami) && !length($status)) { - # we must be using OAuth tokens. we'll need - # to get our screen name from Twitter. we DON'T need this - # if we're just posting with -status. - print "(checking credentials) "; $data = - $credentials = &backticks($baseagent, '/dev/null', undef, - $credurl, undef, $anonymous, @wind); - $rv = $? || &is_fail_whale($data) || &is_json_error($data); - } - if (!$rv && length($status) && $phase) { - print "post attempt "; $rv = &updatest($status, 0); - } else { - # no longer a way to test anonymous logins - unless ($rv || $anonymous) { - print "test-login "; - $data = &backticks($baseagent, '/dev/null', undef, - $url, undef, $anonymous, @wind); - $rv = $?; - } - } - if ($rv || &is_fail_whale($data) || &is_json_error($data)) { - if (&is_fail_whale($data)) { - print "FAILED -- Fail Whale detected\n"; - } elsif ($x = &is_json_error($data)) { - print "FAILED!\n*** server reports: \"$x\"\n"; - print "check your password or configuration.\n"; - } else { - $x = $rv >> 8; - print - "FAILED. ($x) bad password, login or URL? server down?\n"; - } - print "access failure on: "; - print (($phase) ? $update : $url); - print "\n"; - print - "--- data received ($hold) ---\n$data\n--- data received ($hold) ---\n" - if ($superverbose); - if ($hold && --$hold) { - print - "trying again in 1 minute, or kill process now.\n\n"; - sleep 60; - next; - } - if ($didhold) { - print "giving up after $didhold tries.\n"; - } else { - print - "to automatically wait for a connect, use -hold.\n"; - } - exit(1); - } - if ($status && !$phase) { - print "SUCCEEDED!\n"; - $phase++; - next; - } - if (length($next)) { - print "SUCCEEDED!\n(autosplit) "; - $status = $next; - $next = ""; - next; - } - last; -} -print "SUCCEEDED!\n"; -exit(0) if (length($status)); -&sigify(sub { ; }, qw(USR1 PWR XCPU)); -&sigify(sub { $background_is_ready++ }, qw(USR2 SYS UNUSED XFSZ)); -if (length($credentials)) { - print "-- processing credentials: "; - $my_json_ref = &parsejson($credentials); - $whoami = lc($my_json_ref->{'screen_name'}); - if (!length($whoami)) { - print "FAILED!\nis your account suspended, or wrong token?\n"; - exit; - } - print "logged in as $whoami\n"; - $credlog = "-- you are logged in as $whoami\n"; -} - -#### BOT/DAEMON MODE STARTUP #### - -$last_rate_limit = undef; -$rate_limit_left = undef; -$rate_limit_rate = undef; -$rate_limit_next = 0; -$effpause = 0; # for both daemon and background -if ($daemon) { - if (!$pause) { - print $stdout "*** kind of stupid to run daemon with pause=0\n"; - exit 1; - } - if ($child = fork()) { - print $stdout "*** detached daemon released. pid = $child\n"; - kill 15, $$; - exit 0; - } elsif (!defined($child)) { - print $stdout "*** fork() failed: $!\n"; - exit 1; - } else { - $bufferpid = 0; - if ($dostream) { - &sigify(sub { - kill $SIGHUP, $nursepid if ($nursepid); - kill $SIGHUP, $bufferpid if ($bufferpid); - kill 9, $curlpid if ($curlpid); - sleep 1; - # send myself a shutdown - kill 9, $nursepid if ($nursepid); - kill 9, $bufferpid if ($bufferpid); - kill 9, $curlpid if ($curlpid); - kill 9, $$; - }, qw(TERM HUP PIPE)); - &sigify("IGNORE", qw(INT)); - $bufferpid = &start_streaming; - $rin = ''; - vec($rin, fileno(STBUF), 1) = 1; - } - $parent = 0; - $dmcount = 1 if ($dmpause); # force fetch - $is_background = 1; - DAEMONLOOP: for(;;) { - my $snooze; - my $nfound; - my $wake; - - &$heartbeat; - &update_effpause; - &refresh(0); - $dont_refresh_first_time = 0; - if ($dmpause) { - if (!--$dmcount) { - &dmrefresh(0); - $dmcount = $dmpause; - } - } - # service events on the streaming socket, if - # we have one. - $snooze = ($effpause || 0+$pause || 60); - $wake = time() + $snooze; - if (!$bufferpid) { - sleep $snooze; - } else { - my $read_failure = 0; - SLEEP_AGAIN: for(;;) { - $nfound = select($rout = $rin, - undef, undef, $snooze); - if ($nfound && - vec($rout, fileno(STBUF), 1)==1) { - my $buf = ''; - my $rbuf = ''; - my $len; - - sysread(STBUF, $buf, 1); - if (!length($buf)) { - $read_failure++; - # a stuck ready FH says - # our buffer is dead; - # see MONITOR: below. - if ($read_failure>100){ -print $stdout "*** unrecoverable failure of buffer process, aborting\n"; - exit; - } - next SLEEP_AGAIN; - } - $read_failure = 0; - if ($buf !~ /^[0-9a-fA-F]+$/) { - print $stdout - "-- warning: bogus character(s) ".unpack("H*", $buf)."\n" - if ($superverbose); - next SLEEP_AGAIN; - } - while (length($buf) < 8) { - # don't read 8 -- read 1. that means we can - # skip trailing garbage without a window. - sysread(STBUF,$rbuf,1); - if ($rbuf =~ /[0-9a-fA-F]/) { - $buf .= $rbuf; - } else { - print $stdout - "-- warning: bogus character(s) ".unpack("H*", $rbuf)."\n" - if ($superverbose); - $buf = '' - if(length($rbuf)); - } - } - print $stdout "-- length packet: $buf\n" - if ($superverbose); - $len = hex($buf); - $buf = ''; - while (length($buf) < $len) { - sysread(STBUF, $rbuf, - ($len-length($buf))); - $buf .= $rbuf; - } - &streamevents( - &parsejson($buf) ); - $snooze = $wake - time(); - next SLEEP_AGAIN if - ($snooze > 0); - } - last SLEEP_AGAIN; - } - } - } - } - die("uncaught fork() exception\n"); -} - -#### INTERACTIVE MODE and CONSOLE STARTUP #### - -unless ($simplestart) { - print <<"EOF"; - -###################################################### +oo=========oo+ - ${EM}TTYtter ${TTYtter_VERSION}.${padded_patch_version} (c)2012 cameron kaiser${OFF} @ @ -EOF - $e = <<'EOF'; - ${EM}all rights reserved.${OFF} +oo= =====oo+ - ${EM}http://www.floodgap.com/software/ttytter/${OFF} ${GREEN}a==:${OFF} ooo - ${GREEN}.++o++.${OFF} ${GREEN}..o**O${OFF} - freeware under the floodgap free software license. ${GREEN}+++${OFF} :O${GREEN}:::::${OFF} - http://www.floodgap.com/software/ffsl/ ${GREEN}+**O++${OFF} # ${GREEN}:ooa${OFF} - #+$$AB=. - ${EM}tweet me: http://twitter.com/ttytter${OFF} #;;${YELLOW}ooo${OFF};; - ${EM}tell me: ckaiser@floodgap.com${OFF} #+a;+++;O -###################################################### ,$B.${RED}*o***${OFF} O$, -# a=o${RED}$*O*O*$${OFF}o=a -# when ready, hit RETURN/ENTER for a prompt. @${RED}$$$$$${OFF}@ -# type /help for commands or /quit to quit. @${RED}o${OFF}@o@${RED}o${OFF}@ -# starting background monitoring process. @=@ @=@ -# -EOF - $e =~ s/\$\{([A-Z]+)\}/${$1}/eg; print $stdout $e; -} else { - print <<"EOF"; -TTYtter ${TTYtter_VERSION}.${padded_patch_version} (c)2012 cameron kaiser -all rights reserved. freeware under the floodgap free software license. -http://www.floodgap.com/software/ffsl/ - -tweet me: http://twitter.com/ttytter * tell me: ckaiser\@floodgap.com -type /help for commands or /quit to quit. -starting background monitoring process. - -EOF -} -if ($superverbose) { - print $stdout "-- OMGSUPERVERBOSITYSPAM enabled.\n\n"; -} else { - print $stdout "-- verbosity enabled.\n\n" if ($verbose); -} -sleep 3 unless ($silent); - -# these three functions are outside of the usual API assertions for clarity. -# they represent the main loop, which by default is the interactive console. -# the main loop can be redefined. - -sub defaultprompt { - my $rv = ($noprompt) ? "" : "TTYtter> "; - my $rvl = ($noprompt) ? 0 : 9; - return ($rv, $rvl) if (shift); - $wrapseq = 0; - print $stdout "${CCprompt}$rv${OFF}" unless ($termrl); -} -sub defaultaddaction { return 0; } -sub defaultmain { - if (length($runcommand)) { - &prinput($runcommand); - &sync_n_quit; - } - @history = (); - print C "rsga---------------\n"; - $dont_use_counter = $nocounter; - eval '$termrl->hook_no_counter'; - $tco_sub = sub { return &main::fastturntotco(shift); }; - eval '$termrl->hook_no_tco'; - if ($termrl) { - while(defined ($_ = $termrl->readline((&$prompt(1))[0]))) { - kill $SIGUSR1, $child; # suppress output - $rv = &prinput($_); - kill $SIGUSR2, $child; # resume output - last if ($rv < 0); - &sync_console unless (!$rv || !$synch); - if ($dont_use_counter ne $nocounter) { - # only if we have to -- this is expensive - $dont_use_counter = $nocounter; - eval '$termrl->hook_no_counter' - } - } - } else { - &$prompt; - while(<>) { #not stdin so we can read from script files - kill $SIGUSR1, $child; # suppress output - $rv = &prinput(&uforcemulti($_)); - kill $SIGUSR2, $child; # resume output - last if ($rv < 0); - &sync_console unless (!$rv || !$synch); - &$prompt; - } - &sync_n_quit if ($script); - } -} - -# SIGPIPE in particular must be trapped in case someone kills the background -# or, in streaming mode, buffer processes. we can't recover from that. -# the streamer MUST have been initialized before we start these signal -# handlers, or the streamer will try to run them too. eeek! -# -# DO NOT trap SIGCHLD: we generate child processes that die normally. -&sigify(\&end_me, qw(PIPE INT)); -&sigify(\&repaint, qw(USR1 PWR XCPU)); -sub sigify { - # this routine abstracts setting signals to a subroutine reference. - # check and see if we have to use POSIX.pm (Perl 5.14+) or we can - # still use $SIG for proper signalling. We prefer the latter, but - # must support the former. - my $subref = shift; - my $k; - - if ($signals_use_posix) { - my @w; - my $sigaction = POSIX::SigAction->new($subref); - while ($k = shift) { - my $e = &posix_signal_of($k); - # some signals may not exist on all systems. - next if (!(0+$e)); - POSIX::sigaction($e, $sigaction) - || die("sigaction failure: $! $@\n"); - } - } else { - while ($k = shift) { $SIG{$k} = $subref; } - } -} -sub posix_signal_of { - die("never call posix_signal_of if signals_use_posix is false\n") - if (!$signals_use_posix); - - # this assumes that POSIX::SIG* returns a scalar int value. - # not all signals exist on all systems. this ensures zeroes are - # returned for locally bogus ones. - return 0+(eval("return POSIX::SIG".shift)); -} - -sub send_repaint { - unless ($wrapseq){ - return; - } - $wrapseq = 0; - return if ($daemon); - if ($child) { - # we are the parent, call our repaint - &repaint; - } else { - # we are not the parent, call the parent to repaint itself - kill $SIGUSR1, $parent; # send SIGUSR1 - } -} -sub repaint { - # try to speed this up, since we do it a lot. - $wrapseq = 0; - return &$repaintcache if ($repaintcache) ; - - # cache our repaint function (no-op or redisplay) - $repaintcache = sub { ; }; # no-op - return unless ($termrl && - ($termrl->Features()->{'canRepaint'} || $readlinerepaint)); - return if ($daemon); - $termrl->redisplay; $repaintcache = sub { $termrl->redisplay; }; -} -sub send_removereadline { - # this just stubs into its own removereadline - return &$removereadlinecache if ($removereadlinecache); - - $removereadlinecache = sub { ; }; - return unless ($termrl && $termrl->Features()->{'canRemoveReadline'}); - return if ($daemon); - $termrl->removereadline; - $removereadlinecache = sub { $termrl->removereadline; }; -} - -# start the background process -# this has to be last or the background process can't see the full API -if ($child = open(C, "|-")) { - close(P); - binmode(C, ":utf8") unless ($seven); -} else { - close(W); - goto MONITOR; -} -eval'$termrl->hook_background_control' if ($termrl); -select(C); $|++; select($stdout); - -# handshake for synchronicity mode, if we want it. -if ($synch) { - # we will get two replies for this. - print C "synm---------------\n"; - &thump; - # the second will be cleared by the console -} - -# wait for background to become ready -sleep 1 while (!$background_is_ready); - -# start the -&$main; -# loop until we quit and then we'll -&sync_n_quit if ($script); -# else -exit; - -#### command processor #### - -sub prinput { - my $i; - local($_) = shift; # bleh - - # validate this string if we are in UTF-8 mode - unless ($seven) { - $probe = $_; - &$utf8_encode($probe); - die("utf8 doesn't work right in this perl. run with -seven.\n") - if (&ulength($probe) < length($_)); - # should be at least as big - if ($probe =~ /($badutf8)/) { -print $stdout "*** invalid UTF-8: partial delete of a wide character?\n"; - print $stdout "*** ignoring this string\n"; - return 0; - } - } - - $in_reply_to = 0; - chomp; - $_ = &$precommand($_); - s/^\s+//; - s/\s+$//; - my $cfc = 0; - $cfc++ while (s/\033\[[0-9]?[ABCD]// || s/.[\177]// || s/.[\010]// - || s/[\000-\037\177]//); - if ($cfc) { - $history[0] = $_; - print $stdout "*** filtered control characters; now \"$_\"\n"; - print $stdout "*** use %% for truncated version, or append to %%.\n"; - return 0; - } - - if (/^$/) { - return 1; - } - - if (!$slowpost && !$verify && # we assume you know what you're doing! - ($_ eq 'h' || $_ eq 'help' || $_ eq 'quit' || $_ eq 'q' || - /^TTYtter>/ || $_ eq 'ls' || $_ eq '?' || - m#^help /# || $_ eq 'exit')) { - - &add_history($_); - unless ($_ eq 'exit' || /^TTYtter>/ || $_ eq 'ls') { - print $stdout "*** did you mean /$_ ?\n"; - print $stdout - "*** to send this as a command, type /%%\n"; - } else { - print $stdout - "*** did you really mean to tweet \"$_\"?\n"; - } - print $stdout "*** to tweet it anyway, type %%\n"; - return 0; - } - - if (/^\%(\%|-\d+):p$/) { - my $x = $1; - if ($x eq '%') { - print $stdout "=> \"$history[0]\"\n"; - } else { - $x += 0; - if (!$x || $x < -(scalar(@history))) { - print $stdout "*** illegal index\n"; - } else { - print $stdout "=> \"$history[-($x + 1)]\"\n"; - } - } - return 0; - } - - # handle history substitution (including /%%, %%--, %%*, etc.) - $i = 0; # flag - - if (/^\%(\%|-\d+)(--|-\d+|\*)?/) { - ($i, $proband, $r, $s) = &sub_helper($1, $2, $_); - return 0 if (!$i); - - $s = quotemeta($s); - s/^\%${r}${s}/$proband/; - } - if (/[^\\]\%(\%|-\d+)(--|-\d+|\*)?$/) { - ($i, $proband, $r, $s) = &sub_helper($1, $2, $_); - return 0 if (!$i); - - $s = quotemeta($s); - s/\%${r}${s}$/$proband/; - } - # handle variables second, in case they got in history somehow ... - $i = 1 if (s/^\%URL\%/$urlshort/ || s/\%URL\%$/$urlshort/); - $i = 1 if (s/^\%RT\%/$retweet/ || s/\%RT\%$/$retweet/); - - # and escaped history - s/^\\\%/%/; - - if ($i) { - print $stdout "(expanded to \"$_\")\n" ; - $in_reply_to = $expected_tweet_ref->{'id_str'} || 0 - if (defined $expected_tweet_ref && - ref($expected_tweet_ref) eq 'HASH'); - } else { - $expected_tweet_ref = undef; - } - - return 0 unless length; # actually possible to happen - # with control char filters and history. - - &add_history($_); - $shadow_history = $_; - - # handle history display - if ($_ eq '/history' || $_ eq '/h') { - for ($i = scalar(@history); $i >= 1; $i--) { - print $stdout "\t$i\t$history[($i-1)]\n"; - } - return 0; - } - - my $slash_first = ($_ =~ m#^/#); - - return -1 if ($_ eq '/quit' || $_ eq '/q' || $_ eq '/bye' || - $_ eq '/exit'); - - return 0 if (scalar(&$addaction($_))); - - # add commands here - - # dumper - if (m#^/du(mp)? ([zZ]?[a-zA-Z]?[0-9]+)$#) { - my $code = lc($2); - unless ($code =~ /^d[0-9][0-9]+$/) { # this is a DM. - my $tweet = &get_tweet($code); - my $k; - my $sn; - my $id; - my @superfields = ( - [ "user", "screen_name" ], # must always be first - [ "retweeted_status", "id_str" ], - [ "user", "geo_enabled" ], - [ "place", "id" ], - [ "place", "country_code" ], - [ "place", "full_name" ], - [ "place", "place_type" ], - [ "tag", "type" ], - [ "tag", "payload" ], - ); - my $superfield; - - if (!defined($tweet)) { - print $stdout "-- no such tweet (yet?): $code\n"; - return 0; - } - - foreach $superfield (@superfields) { - my $sfn = join('->', @{ $superfield }); - my $sfk = "{'" . join("'}->{'", @{ $superfield }) . - "'}"; - my $sfv; - eval "\$sfv = &descape(\$tweet->$sfk);"; - print $stdout - substr("$sfn ", 0, 25). - " $sfv\n"; - $sn = $sfv if (!length($sn) && length($sfv)); - } - # geo is special - print $stdout "geo->coordinates (" . - join(', ', @{ $tweet->{'geo'}->{'coordinates'} }) - . ")\n"; - foreach $k (sort keys %{ $tweet }) { - next if (ref($tweet->{$k})); - print $stdout - substr("$k ", 0, 25) . - " " . &descape($tweet->{$k}) . "\n"; - } - # include a URL to the tweet per @augmentedfourth - $urlshort = - "${http_proto}://twitter.com/$sn/statuses/$tweet->{'id_str'}"; - print $stdout - "-- %URL% is now $urlshort (/short to shorten)\n"; - return 0; - } # if dxxxx, fall through to the below. - } - - if (m#^/du(mp)? ([dD][a-zA-Z]?[0-9]+)$#) { - my $code = lc($2); - my $dm = &get_dm($code); - my $k; - my $sn; - my $id; - my @superfields = ( - [ "sender", "screen_name" ], # must always be first - ); - - if (!defined($dm)) { - print $stdout "-- no such DM (yet?): $code\n"; - return 0; - } - - foreach $superfield (@superfields) { - my $sfn = join('->', @{ $superfield }); - my $sfk = "{'" . join("'}->{'", @{ $superfield }) . - "'}"; - my $sfv; - eval "\$sfv = &descape(\$dm->$sfk);"; - print $stdout - substr("$sfn ", 0, 25). - " $sfv\n"; - $sn = $sfv if (!length($sn) && length($sfv)); - } - - foreach $k (sort keys %{ $dm }) { - next if (ref($dm->{$k})); - print $stdout - substr("$k ", 0, 25) . - " " . &descape($dm->{$k}) . "\n"; - } - return 0; - } - - # evaluator - if (m#^/ev(al)? (.+)$#) { - $k = eval $2; - print $stdout "==> "; - print $streamout "$k $@\n"; - return 0; - } - - # version check - if (m#^/v(ersion)?check$# || m#^/u(pdate)?check$#) { - print $stdout &updatecheck(1); - return 0; - } - - # url shortener routine - if (($_ eq '/sh' || $_ eq '/short') && length($urlshort)) { - $_ = "/short $urlshort"; - print $stdout "*** assuming you meant %URL%: $_\n"; - # and fall through to ... - } - if (m#^/sh(ort)? (https?|gopher)(://[^ ]+)#) { - my $url = $2 . $3; - my $answer = (&urlshorten($url) || 'FAILED -- %% to retry'); - print $stdout "*** shortened to: "; - print $streamout ($answer . "\n"); - return 0; - } - - # getter for internal value settings - if (/^\/r(ate)?l(imit)?$/) { - $_ = '/print rate_limit_rate'; - # and fall through to ... - } - - if ($_ eq '/p' || $_ eq '/print') { - foreach $key (sort keys %opts_can_set) { - print $stdout "*** $key => $$key\n" - if (!$opts_secret{$key}); - } - return 0; - } - if (/^\/p(rint)?\s+([^ ]+)/) { - my $key = $2; - if ($valid{$key} || - $key eq 'effpause' || - $key eq 'rate_limit_rate' || - $key eq 'rate_limit_left') { - my $value = &getvariable($key); - print $stdout "*** "; - print $stdout "(read-only value) " - if (!$opts_can_set{$key}); - print $stdout "$key => $value\n"; - - # I don't see a need for these in &getvariable, so they are - # not currently supported. whine if you disagree. - - } elsif ($key eq 'tabcomp') { - if ($termrl) { - &generate_otabcomp; - } else { - print $stdout "*** readline isn't on\n"; - } - } elsif ($key eq 'ntabcomp') { # sigh - if ($termrl) { - print $stdout "*** new TAB-comp entries: "; - $did_print = 0; - foreach(keys %readline_completion) { - next if ($original_readline{$_}); - $did_print = 1; - print $stdout "$_ "; - } - print $stdout "(none)" if (!$did_print); - print $stdout "\n"; - } else { - print $stdout "*** readline isn't on\n"; - } - - } else { - print "*** not a valid option or setting: $key\n"; - } - return 0; - } - if ($_ eq '/verbose' || $_ eq '/ve') { - $verbose ^= 1; - $_ = "/set verbose $verbose"; - print $stdout "-- verbosity.\n" if ($verbose); - # and fall through to set - } - - # search api integration (originally based on @kellyterryjones', - # @vielmetti's and @br3nda's patches) - if (/^\/se(arch)?\s+(\+\d+\s+)?(.+)\s*$/) { - my $countmaybe = $2; - my $kw = $3; - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - $countmaybe ||= $searchhits; - $kw = &url_oauth_sub($kw); - $kw = "q=$kw" if ($kw !~ /^q=/); - - my $r = &grabjson("$queryurl?$kw", 0, 0, $countmaybe, { - "type" => "search", - "payload" => $k - }, 1); - if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })) { - &dt_tdisplay($r, 'search'); - } else { - print $stdout "-- sorry, no results were found.\n"; - } - &$conclude; - return 0; - } - if ($_ eq '/notrack') { # special case - print $stdout "*** all tracking keywords cancelled\n"; - $track = ''; - &setvariable('track', $track, 1); - return 0; - } - if (s/^\/troff\s+// && s/\s*// && length) { - # remove it from array, regenerate $track, call tracktags_makearray - # and then sync - my $k; - my $l = ''; - my $q = 0; - my %w; - $_ = lc($_); - my (@ptags) = split(/\s+/, $_); - - # filter duplicates and merge quoted strings (again) - # but this time we're building up a hash for fast searches - foreach $k (@ptags) { - if ($q && $k =~ /"$/) { # this has to be first - $l .= " $k"; - $q = 0; - } elsif ($k =~ /^"/ || $q) { - $l .= (length($l)) ? " $k" : $k; - $q = 1; - next; - } else { - $l = $k; - } - next if ($w{$l}); # ignore silently here - $w{$l} = 1; - $l = ''; - } - print $stdout "-- warning: syntax error, missing quote?\n" - if ($q); - - # now filter out of @tracktags - @ptags = (); - foreach $k (@tracktags) { - push (@ptags, $k) unless ($w{$k}); - } - unless (scalar(@ptags) < scalar(@tracktags)) { - print $stdout "-- sorry, no track terms matched.\n"; - print $stdout (length($track) ? - "-- you are tracking: $track\n" : - "-- (maybe because you're not tracking anything?)\n"); - return 0; - } - print $stdout "*** ok, filtered @{[ keys(%w) ]}\n"; - $track = join(' ', @ptags); - &setvariable('track', $track, 1); - return 0; - } - - if (s#^/tre(nds)?\s*##) { - my $t = undef; - my $wwoeid = (length) ? $_ : $woeid; - $wwoeid ||= "1"; - my $r = &grabjson("${wtrendurl}?id=${wwoeid}", - 0, 0, 0, undef, 1); - my $fr = ($wwoeid && $wwoeid ne '1') ? - " FOR WOEID $wwoeid" : ' GLOBALLY'; - - if (defined($r) && ref ($r) eq 'ARRAY') { - $t = $r->[0]->{'trends'}; - } - if (defined($t) && ref($t) eq 'ARRAY') { - my $i; - my $j; - - print $stdout "${EM}<<< TRENDING TOPICS${fr} >>>${OFF}\n"; - foreach $j (@{ $t }) { - my $k = &descape($j->{'name'}); - my $l = ($k =~ /\sOR\s/) ? $k : - ($k =~ /^"/) ? $k : - ('"' . $k . '"'); - print $streamout "/search $l\n"; - $k =~ s/\sOR\s/ /g; - $k = '"' . $k . '"' if ($k =~ /\s/ - && $k !~ /^"/); - print $streamout "/tron $k\n"; - } - print $stdout "${EM}<<< TRENDING TOPICS >>>${OFF}\n"; - } else { - print $stdout -"-- sorry, trends not available for WOEID $wwoeid.\n"; - } - return 0; - } - - # woeid finder based on lat/long - if ($_ eq '/woeids') { - my $max = 10; - if (!$lat && !$long) { - print $stdout - "-- set your location with lat/long first.\n"; - return 0; - } - my $r = &grabjson("$atrendurl?lat=$lat&long=$long", 0, 0, 0, - undef, 1); - if (defined($r) && ref($r) eq 'ARRAY') { - my $i; - foreach $i (@{ $r }) { - my $woeid = &descape($i->{'woeid'}); - my $nm = &descape($i->{'name'}) . ' (' . - &descape($i->{'countryCode'}) .')'; - print $streamout "$nm\n/set woeid $woeid\n"; - last unless ($max--); - } - } else { - print $stdout -"-- sorry, couldn't get a supported WOEID for your location.\n"; - } - return 0; - } - - 1 if (s/^\/#([^\s]+)/\/tron #\1/); - # /# command falls through to tron - if (s/^\/tron\s+// && s/\s*$// && length) { - $_ = lc($_); - $track .= " " if (length($track)); - $_ = "/set track ${track}$_"; - # fall through to set - } - if (/^\/track ([^ ]+)/) { - s#^/#/set #; - # and fall through to set - } - - # /listoff - if (s/^\/list?off\s+// && s/\s*$// && length) { - if (/,/ || /\s+/) { - print $stdout "-- one list at a time please\n"; - return 0; - } - if (!scalar(@listlist)) { - print $stdout - "-- ok! that was easy! (you don't have any lists in your timeline)\n"; - return 0; - } - my $w; - my $newlists = ''; - my $didfilter = 0; - foreach $w (@listlist) { - my $x = join('/', @{ $w }); - if ($x eq $_ || "$whoami$_" eq $x || - "$whoami/$_" eq $x) { - print $stdout "*** ok, filtered $x\n"; - $didfilter = 1; - } else { - $newlists .= (length($newlists)) ? ",$x" - : $x; - } - } - if ($didfilter) { - &setvariable('lists', $newlists, 1); - } else { - print $stdout "*** hmm, no such list? current value:\n"; - print $stdout "*** lists => ", - &getvariable('lists'), "\n"; - } - return 0; - } - - # /liston - if (s/^\/list?on\s+// && s/\s*$// && length) { - if (/,/ || /\s+/) { - print $stdout "-- one list at a time please\n"; - return 0; - } - my $uname; - my $lname; - if (m#/#) { - ($uname, $lname) = split(m#/#, $_, 2); - } else { - $lname = $_; - $uname = ''; - } - if (!length($uname) && $anonymous) { - print $stdout -"-- you must specify a username for a list when anonymous.\n"; - return 0; - } - $uname ||= $whoami; - - # check the list validity - my $my_json_ref = &grabjson( - "${statusliurl}?owner_screen_name=${uname}&slug=${lname}", - 0, 0, 0, undef, 1); - if (!$my_json_ref || ref($my_json_ref) ne 'ARRAY') { - print $stdout - "*** list $uname/$lname seems bogus; not added\n"; - return 0; - } - - $_ = "/add lists $uname/$lname"; - # fall through to add - } - if (s/^\/a(uto)?lists?\s+// && s/\s*$// && length) { - s/\s+/,/g if (!/,/); - print $stdout - "--- warning: lists aren't checked en masse; make sure they exist\n"; - $_ = "/set lists $_"; - # and fall through to set - } - - # setter for internal value settings - # shortcut for boolean settings - if (/^\/s(et)? ([^ ]+)\s*$/) { - my $key = $2; - $_ = "/set $key 1" - if($opts_boolean{$key} && $opts_can_set{$key}); - # fall through to three argument version - } - if (/^\/uns(et)? ([^ ]+)\s*$/) { - my $key = $2; - if ($opts_can_set{$key} && $opts_boolean{$key}) { - &setvariable($key, 0, 1); - return 0; - } - &setvariable($key, undef, 1); - return 0; - } - # stubs out to set variable - if (/^\/s(et)? ([^ ]+) (.+)\s*$/) { - my $key = $2; - my $value = $3; - &setvariable($key, $value, 1); - return 0; - } - # append to a variable (if not boolean) - if (/^\/ad(d)? ([^ ]+) (.+)\s*$/) { - my $key = $2; - my $value = $3; - if ($opts_boolean{$key}) { - print $stdout - "*** why are you appending to a boolean?\n"; - return 0; - } - if (length(&getvariable($key))) { - $value = " $value" if ($opts_space_delimit{$key}); - $value = ",$value" if ($opts_comma_delimit{$key}); - } - &setvariable($key, &getvariable($key).$value, 1); - return 0; - } - # delete from a variable (if not boolean) - if (/^\/del ([^ ]+) (.+)\s*$/) { - my $key = $1; - my $value = $2; - my $old; - if ($opts_boolean{$key}) { - print $stdout - "*** why are you deleting from a boolean?\n"; - return 0; - } - if (!length($old = &getvariable($key))) { - print $stdout "*** $key is already empty\n"; - return 0; - } - my $del = - ($opts_space_delimit{$key}) ? '\s+' : - ($opts_comma_delimit{$key}) ? '\s*,\s*' : - undef; - if (!defined($del)) { - # simple substitution - 1 while ($old =~ s/$value//g); - } else { - 1 while ($old =~ s/$del$value($del)/\1/g); - 1 while ($old =~ s/^$value$del//); - 1 while ($old =~ s/$del$value//); - } - &setvariable($key, $old, 1); - return 0; - } - # I thought about implementing a /pdel but besides being ugly - # I don't think most people will push a truncated setting. tell me - # if I'm wrong. - - # stackable settings - if (/^\/pu(sh)? ([^ ]+)\s*$/) { - my $key = $2; - if ($opts_can_set{$key}) { - if ($opts_boolean{$key}) { - $_ = "/push $key 1"; - # fall through to three argument version - } else { - if (!$opts_can_set{$key}) { - print $stdout - "*** setting is not stackable: $key\n"; - return 0; - } - my $old = &getvariable($key); - push(@{ $push_stack{$key} }, $old); - print $stdout - "--- saved on stack for $key: $old\n"; - return 0; - } - } - } - - # common code for set and append - if (/^\/(pu|push|pad|padd) ([^ ]+) (.+)\s*$/) { - my $comm = $1; - my $key = $2; - my $value = $3; - $comm = ($comm =~ /^pu/) ? "push" : "padd"; - if ($opts_boolean{$key} && $comm eq 'padd') { - print $stdout - "*** why are you appending to a boolean?\n"; - return 0; - } - if (!$opts_can_set{$key}) { - print $stdout - "*** setting is not stackable: $key\n"; - return 0; - } - my $old = &getvariable($key); - $old += 0 if ($opts_boolean{$key}); - push(@{ $push_stack{$key} }, $old); - print $stdout "--- saved on stack for $key: $old\n"; - if ($comm eq 'padd' && length($old)) { - $value = " $value" if ($opts_space_delimit{$key}); - $value = ",$value" if ($opts_comma_delimit{$key}); - $old .= $value; - } else { - $old = $value; - } - &setvariable($key, $old, 1); - return 0; - } - # we assume that if the setting is in the push stack, it's valid - if (/^\/pop ([^ ]+)\s*$/) { - my $key = $1; - if (!scalar(@{ $push_stack{$key} })) { - print $stdout - "*** setting is not stacked: $key\n"; - return 0; - } - &setvariable($key, pop(@{ $push_stack{$key} }), 1); - return 0; - } - - # shell escape - if (s/^\/\!// && s/\s*$// && length) { - system("$_"); - $x = $? >> 8; - print $stdout "*** exited with $x\n" if ($x); - return 0; - } - - if ($_ eq '/help' || $_ eq '/?') { - print <<'EOF'; - - *** BASIC COMMANDS: :a$AAOOOOOOOOOOOOOOOOOAA$a, ================== - +@A:. .:B@+ ANYTHING WITHOUT - /refresh =@B HELP!!! HELP!!! B@= A LEADING / IS - grabs the newest :a$Ao oA$a, SENT AS A TWEET! - tweets right ;AAA$a; :a$AAAAAAAAAAA; ================== - away (or tells :AOaaao:, .:oA*:. JUST TYPE TO TALK! - you if there .;=$$$OBO***+ .+aaaa$: - is nothing new) :*; :***O@Aaaa*o, ============ - by thumping .+++++: o#o REMEMBER!! - the background :OOOOOOA*:::, =@o ,:::::. ============ - process. .+++++++++: =@*.....=a$OOOB#; MANY COMMANDS, AND - =@OoO@BAAA#@$o, ALL TWEETS ARE - /again =@o .+aaaaa: --ASYNCHRONOUS-- - displays most recent =@Aaaaaaaaaa*o*a;, and might not always - tweets, both old and =@$++=++++++:,;+aA: respond - new. ,+$@*.=O+ ...oO; oAo+. immediately! - ,+o$OO=.+aA#####Oa;.*OO$o+. - /dm and /dmagain for DMs. +Ba::;oaa*$Aa=aA$*aa=;::$B: - ,===O@BOOOOOOOOO#@$===, - /replies o@BOOOOOOOOO#@+ ================== - shows replies and mentions. o@BOB@B$B@BO#@+ USE + FOR A COUNT: - o@*.a@o a@o.$@+ /re +30 => last 30 replies - /quit resumes your boring life. o@B$B@o a@A$#@+ ========================== -EOF - &linein("PRESS RETURN/ENTER>"); - print <<"EOF"; - -+- MORE COMMANDS -+ -=-=- USER STUFF -=-=- -| | /whois username displays info about username -| See the TTYtter | /again username views their most recent tweets -| home page for | /wagain username combines them all -| complete list | /follow username follow a username -| | /leave username stop following a username -+-----------------+ /dm username message send a username a DM -+--- TWEET AND DM SELECTION -------------------------------------------------+ -| all DMs and tweets have menu codes (letters + number, d for DMs). example: | -| a5> <ttytter> Send me Dr Pepper http://www.floodgap.com/TTYtter | -| [DM da0][ttytter/Sun Jan 32 1969] I think you are cute | -| /reply a5 message replies to tweet a5 | -| example: /reply a5 I also like Dr Pepper | -| becomes \@ttytter I also like Dr Pepper (and is threaded) | -| /thread a5 if a5 is part of a thread (the username | -| has a \@) then show all posts up to that | -| /url a5 opens all URLs in tweet a5 | -| Mac OS X users, do first: /set urlopen open %U | -| Dummy terminal users, try /set urlopen lynx -dump %U | more | -| /delete a5 deletes tweet a5, if it's your tweet | -| /rt a5 retweets tweet a5: RT \@tytter: Send me...| -+-- Abbreviations: /re, /th, /url, /del --- menu codes wrap around at end ---+ -=====> /reply, /delete and /url work for direct message menu codes too! <===== -EOF - &linein("PRESS RETURN/ENTER>"); - print <<"EOF"; - - - -Use /set to turn on options or set them at runtime. There is a BIG LIST! - ->> EXAMPLE: WANT ANSI? /set ansi 1 - or use the -ansi command line option. - WANT TO VERIFY YOUR TWEETS BEFORE POSTING? /set verify 1 - or use the -verify command line option. -For more, like readline support, UTF-8, SSL, proxies, etc., see the docs. - -** READ THE COMPLETE DOCUMENTATION: http://www.floodgap.com/software/ttytter/ - - TTYtter $TTYtter_VERSION is (c)2012 cameron kaiser + contributors. - all rights reserved. this software is offered AS IS, with no guarantees. it - is not endorsed by Obvious or the executives and developers of Twitter. - - *** subscribe to updates at http://twitter.com/ttytter - or http://twitter.com/floodgap - send your suggestions to me at ckaiser\@floodgap.com - or http://twitter.com/doctorlinguist - - - -EOF - return 0; - } - if ($_ eq '/ruler' || $_ eq '/ru') { - my ($prompt, $prolen) = (&$prompt(1)); - $prolen = " " x $prolen; - print $stdout <<"EOF"; -${prolen} 1 2 3 4 5 6 7 8 9 0 1 2 3 XX -${prompt}1...5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5...XX -EOF - return 0; - } - if ($_ eq '/cls' || $_ eq '/clear') { - if ($ansi) { - print $stdout "${ESC}[H${ESC}[2J\n"; - } else { - print $stdout ("\n" x ($ENV{'ROWS'} || 50)); - } - return 0; - } - if ($_ eq '/refresh' || $_ eq '/thump' || $_ eq '/r') { - print $stdout "-- /refresh in streaming mode is pretty impatient\n" - if ($dostream); - &thump; - return 0; - } - if (m#^/a(gain)?(\s+\+\d+)?$#) { # the asynchronous form - my $countmaybe = $2; - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - if ($countmaybe > 999) { - print $stdout "-- greedy bastard, try +fewer.\n"; - return 0; - } - $countmaybe = sprintf("%03i", $countmaybe); - print $stdout "-- background request sent\n" unless ($synch); - - print C "reset${countmaybe}-----------\n"; - &sync_semaphore; - return 0; - } - - # this is for users -- list form is below - if ($_ =~ m#^/(w)?a(gain)?\s+(\+\d+\s+)?([^\s/]+)$#) { #synchronous form - my $mode = $1; - my $uname = lc($4); - - my $countmaybe = $3; - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - - $uname =~ s/^\@//; - $readline_completion{'@'.$uname}++ if ($termrl); - print $stdout - "-- synchronous /again command for $uname ($countmaybe)\n" - if ($verbose); - my $my_json_ref = - &grabjson("${uurl}?screen_name=${uname}&include_rts=true", - 0, 0, $countmaybe, undef, 1); - &dt_tdisplay($my_json_ref, 'again'); - unless ($mode eq 'w' || $mode eq 'wf') { - return 0; - } # else fallthrough - } - if ($_ =~ m#^/w(hois|a|again)?\s+(\+\d+\s+)?\@?([^\s]+)#) { - my $uname = lc($3); - $uname =~ s/^\@//; - $readline_completion{'@'.$uname}++ if ($termrl); - print $stdout "-- synchronous /whois command for $uname\n" - if ($verbose); - my $my_json_ref = - &grabjson("${wurl}?screen_name=${uname}", 0, 0, 0, undef, 1); - - if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' && - length($my_json_ref->{'screen_name'})) { - my $sturl = undef; - my $purl = - &descape($my_json_ref->{'profile_image_url'}); - if ($avatar && length($purl) && $purl !~ -m#^http://[^.]+\.(twimg\.com|twitter\.com).+/images/default_profile_\d+_normal.png#) { - my $exec = $avatar; - my $fext; - ($purl =~ /\.([a-z0-9A-Z]+)$/) && - ($fext = $1); - if ($purl !~ /['\\]/) { # careful! - $exec =~ s/\%U/'$purl'/g; - $exec =~ s/\%N/$uname/g; - $exec =~ s/\%E/$fext/g; - print $stdout "\n"; - print $stdout "($exec)\n" - if ($verbose); - system($exec); - } - } - print $streamout "\n"; - &userline($my_json_ref, $streamout); - print $streamout &wwrap( -"\"@{[ &strim(&descape($my_json_ref->{'description'})) ]}\"\n") - if (length(&strim($my_json_ref->{'description'}))); - if (length($my_json_ref->{'url'})) { - $sturl = - $urlshort = &descape($my_json_ref->{'url'}); - $urlshort =~ s/^\s+//; - $urlshort =~ s/\s+$//; - print $streamout "${EM}URL:${OFF}\t\t$urlshort\n"; - } - print $streamout &wwrap( -"${EM}Location:${OFF}\t@{[ &descape($my_json_ref->{'location'}) ]}\n") - if (length($my_json_ref->{'location'})); - print $streamout <<"EOF"; -${EM}Picture:${OFF}\t@{[ &descape($my_json_ref->{'profile_image_url'}) ]} - -EOF - unless ($anonymous || $whoami eq $uname) { - my $g = &grabjson( - "$frurl?source_screen_name=$whoami&target_screen_name=$uname", 0, 0, 0, - undef, 1); - print $streamout &wwrap( - "${EM}Do you follow${OFF} this user? ... ${EM}$g->{'relationship'}->{'target'}->{'followed_by'}${OFF}\n") - if (ref($g) eq 'HASH'); - my $g = &grabjson( - "$frurl?source_screen_name=$uname&target_screen_name=$whoami", 0, 0, 0, - undef, 1); - print $streamout &wwrap( -"${EM}Does this user follow${OFF} you? ... ${EM}$g->{'relationship'}->{'target'}->{'followed_by'}${OFF}\n") - if (ref($g) eq 'HASH'); - print $streamout "\n"; - } - print $stdout &wwrap( - "-- %URL% is now $urlshort (/short shortens, /url opens)\n") - if (defined($sturl)); - } - return 0; - } - - if (m#^/(df|doesfollow)\s+\@?([^\s]+)$#) { - if ($anonymous) { - print $stdout "-- who follows anonymous anyway?\n"; - return 0; - } - $_ = "/doesfollow $2 $whoami"; - print $stdout "*** assuming you meant: $_\n"; - # fall through to ... - } - if (m#^/(df|doesfollow)\s+\@?([^\s]+)\s+\@?([^\s]+)$#) { - my $user_a = $2; - my $user_b = $3; - if ($user_a =~ m#/# || $user_b =~ m#/#) { - print $stdout "--- sorry, this won't work on lists.\n"; - return 0; - } - my $g = &grabjson( -"${frurl}?source_screen_name=${user_a}&target_screen_name=${user_b}", 0, 0, 0, - undef, 1); - if ($msg = &is_json_error($g)) { - print $stdout <<"EOF"; -${MAGENTA}*** warning: server error message received -*** "$ec"${OFF} -EOF - } elsif ($g->{'relationship'}->{'target'}) { - print $stdout "--- does $user_a follow ${user_b}? => "; - print $streamout "$g->{'relationship'}->{'target'}->{'followed_by'}\n" - } else { - print $stdout -"-- sorry, bogus server response, try again later.\n"; - } - return 0; - } - - # this is dual-headed and supports both lists and regular followers. - if(s#^/(frs|friends|fos|followers)(\s+\+\d+)?\s*##) { - my $countmaybe = $2; - my $mode = $1; - my $arg = lc($_); - my $lname = ''; - my $user = ''; - my $what = ''; - $arg =~ s/^@//; - $who = $arg; - ($who, $lname) = split(m#/#, $arg, 2) if (m#/#); - if (length($lname) && !length($user) && $anonymous) { - print $stdout - "-- you must specify a username for a list when anonymous.\n"; - return 0; - } - $who ||= $whoami; - if (!length($lname)) { - $what = ($mode eq 'frs' || $mode eq 'friends') - ? "friends" : "followers"; - $mode = ($mode eq 'frs' || $mode eq 'friends') - ? $friendsurl : $followersurl; - } else { - $what = ($mode eq 'frs' || $mode eq 'friends') - ? "friends/members" : "followers/subscribers"; - $mode = ($mode eq 'frs' || $mode eq 'friends') - ? $getliurl : $getfliurl; - $user = "&owner_screen_name=${who}&slug=${lname}"; - $who = "list $who/$lname"; - } - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - $countmaybe ||= 20; - - # we use the undocumented count= support to, by default, - # reduce the JSON parsing overhead. if we always had to take - # all 100, we really eat it on parsing. the downside is that, - # per @episod, the stuff we get is "less" fresh. - my $countper = ($countmaybe < 100) ? $countmaybe : 100; - - if (!length($lname)) { - # we need to get IDs, then call lookup. right now it's - # limited to 5000 because that is the limit for API 1.1 - # without having to do pagination here too. sorry. - if ($countmaybe >= 5000) { - print $stdout -"-- who do you think you are? Scoble? currently limited to 4999 or less\n"; - return 0; - } - - # grab all the IDs - my $ids_ref = &grabjson( - "$mode?count=${countmaybe}&screen_name=${who}&stringify_ids=true", - 0, 0, 0, undef, 1); - return 0 if (!$ids_ref || ref($ids_ref) ne 'HASH' || - !$ids_ref->{'ids'}); - $ids_ref = $ids_ref->{'ids'}; - return 0 if (ref($ids_ref) ne 'ARRAY'); - my @ids = @{ $ids_ref }; - @ids = sort { 0+$a <=> 0+$b } @ids; - # make it somewhat deterministic - - my $dount = &min($countmaybe, scalar(@ids)); - my $swallow = &min(100, $dount); - my @usarray = undef; shift(@usarray); # force underflow - my $l_ref = undef; - - # for each block of $countper, emit - my $printed = 0; - - FFABIO: while ($dount--) { - if (!scalar(@usarray)) { - my @next_ids; - - last FFABIO if (!scalar(@ids)); - - # if we asked for less than 100, get - # that. otherwise, - # get the top 100 off that list (or - # the list itself, if 100 or less) - if (scalar(@ids) <= $swallow) { - @next_ids = @ids; - @ids = (); - } else { - @next_ids = - @ids[0..($swallow-1)]; - @ids = @ids[$swallow..$#ids]; - } - - # turn it into a list to pass to - # lookupidurl and get the list - $l_ref = &postjson($lookupidurl, - "user_id=".&url_oauth_sub(join(',', @next_ids))); - last FFABIO if(ref($l_ref) ne 'ARRAY'); - @usarray = sort - { 0+($a->{'id'}) <=> 0+($b->{'id'}) } - @{ $l_ref }; - last if (!scalar(@usarray)); - } - &$userhandle(shift(@usarray)); - $printed++; - } - print $stdout "-- sorry, no $what found for $who.\n" - if (!$printed); - return 0; - } - - # lists - # loop through using the cursor until desired number. - my $cursor = -1; # initial value - my $printed = 0; - my $nofetch = 0; - my $json_ref = undef; - my @usarray = undef; shift(@usarray); # force underflow - - # this is a simpler version of the above. - FABIO: while($countmaybe--) { - if(!scalar(@usarray)) { - last FABIO if ($nofetch); - $json_ref = &grabjson( - "${mode}?count=${countper}&cursor=${cursor}${user}", - 0, 0, 0, undef, 1); - @usarray = @{ $json_ref->{'users'} }; - last FABIO if (!scalar(@usarray)); - $cursor = $json_ref->{'next_cursor_str'} || - $json_ref->{'next_cursor'} || -1; - $nofetch = ($cursor < 1) ? 1 : 0; - } - &$userhandle(shift(@usarray)); - $printed++; - } - print $stdout "-- sorry, no $what found for $who.\n" - if (!$printed); - return 0; - } - - # threading - if (m#^/th(read)?\s+(\+\d+\s+)?([zZ]?[a-zA-Z]?[0-9]+)$#) { - my $countmaybe = $2; - if (length($countmaybe)) { - print $stdout - "-- /thread does not (yet) support +count\n"; - return 0; - } - my $code = lc($3); - my $tweet = &get_tweet($code); - if (!defined($tweet)) { - print $stdout "-- no such tweet (yet?): $code\n"; - return 0; - } - my $limit = 9; - my $id = $tweet->{'retweeted_status'}->{'id_str'} || - $tweet->{'in_reply_to_status_id_str'}; - my $thread_ref = [ $tweet ]; - while ($id && $limit) { - print $stdout "-- thread: fetching $id\n" - if ($verbose); - my $next = &grabjson("${idurl}?id=${id}", 0, 0, 0, - undef, 1); - $id = 0; - $limit--; - if (defined($next) && ref($next) eq 'HASH') { - push(@{ $thread_ref }, - &fix_geo_api_data($next)); - $id = $next->{'retweeted_status'}->{'id_str'} - || $next->{'in_reply_to_status_id_str'} - || 0; - } - } - &tdisplay($thread_ref, 'thread', 0, 1); # use the mini-menu - return 0; - } - - # pull out entities. this works for DMs and tweets. - # btw: T.CO IS WACK. - if (m#^/ent?(ities)? ([dDzZ]?[a-zA-Z]?[0-9]+)$#) { - my $v; - my $w; - my $thing; - my $genurl; - my $code = lc($2); - my $hash; - if ($code !~ /[a-z]/) { - # this is an optimization: we don't need to get - # the old tweet since we're going to fetch it anyway. - $hash = { "id_str" => $code }; - $thing = "tweet"; - $genurl = $idurl; - } elsif ($code =~ /^d.[0-9]+$/) { - $hash = &get_dm($code); - $thing = "DM"; - $genurl = $dmidurl; - } else { - $hash = &get_tweet($code); - $thing = "tweet"; - $genurl = $idurl; - } - - if (!defined($hash)) { - print $stdout "-- no such $thing (yet?): $code\n"; - return 0; - } - - my $id = $hash->{'id_str'}; - $hash = &grabjson("${genurl}?id=${id}", 0, 0, 0, undef, 1); - if (!defined($hash) || ref($hash) ne 'HASH') { - print $stdout "-- failed to get entities from server, sorry\n"; - return 0; - } - - # if a retweeted status, get the status. - $hash = $hash->{'retweeted_status'} - if (defined($hash->{'retweeted_status'}) && - ref($hash->{'retweeted_status'}) eq 'HASH'); - - my $didprint = 0; - # Twitter puts entities in multiple fields. - foreach $w (qw(media urls)) { - my $p = $hash->{'entities'}->{$w}; - next if (!defined($p) || ref($p) ne 'ARRAY'); - foreach $v (@{ $p }) { - next if (!defined($v) || ref($v) ne 'HASH'); - next if (!length($v->{'url'}) || - (!length($v->{'expanded_url'}) && - !length($v->{'media_url'}))); - my $u1 = &descape($v->{'url'}); - my $u2 = &descape($v->{'expanded_url'}); - my $u3 = &descape($v->{'media_url'}); - my $u4 = &descape($v->{'media_url_https'}); - $u2 = $u4 || $u3 || $u2; - print $stdout "$u1 => $u2\n"; - $urlshort = $u4 || $u3 || $u1; - $didprint++; - } - } - if ($didprint) { - print $stdout &wwrap( - "-- %URL% is now $urlshort (/url opens)\n"); - } else { - print $stdout "-- no entities or URLs found\n"; - } - return 0; - } - - if (($_ eq '/url' || $_ eq '/open') && length($urlshort)) { - $_ = "/url $urlshort"; - print $stdout "*** assuming you meant %URL%: $_\n"; - # and fall through to ... - } - if (m#^/(url|open)\s+(http|gopher|https|ftp)://.+# && - s#^/(url|open)\s+##) { - &openurl($_); - return 0; - } - if (m#^/(url|open) ([dDzZ]?[a-zA-Z]?[0-9]+)$#) { - my $code = lc($2); - my $tweet; - my $genurl = undef; - $urlshort = undef; - - if ($code =~ /^d/ && length($code) > 2) { - $tweet = &get_dm($code); # USO! - if (!defined($tweet)) { - print $stdout - "-- no such DM (yet?): $code\n"; - return 0; - } - $genurl = $dmidurl; - } else { - $tweet = &get_tweet($code); - if (!defined($tweet)) { - print $stdout - "-- no such tweet (yet?): $code\n"; - return 0; - } - $genurl = $idurl; - } - - # to be TOS-compliant, we must try entities first to use - # t.co wrapped links. this is a tiny version of /entities. - unless ($notco) { - my $id = $tweet->{'retweeted_status'}->{'id_str'} - || $tweet->{'id_str'}; - my $hash; - - # only fetch if we have to. if we already fetched - # because we were given a direct id_str instead of a - # menu code, then we already have the entities. - if ($code !~ /^[0-9]+$/) { - $hash = &grabjson("${genurl}?id=${id}", - 0, 0, 0, undef, 1); - } else { - # MAKE MONEY FAST WITH OUR QUICK CACHE PLAN - $hash = $tweet; - } - if (defined($hash) && ref($hash) eq 'HASH') { - my $w; - my $v; - my $didprint = 0; - - # Twitter puts entities in multiple fields. - foreach $w (qw(media urls)) { - my $p = $hash->{'entities'}->{$w}; - next if (!defined($p) || - ref($p) ne 'ARRAY'); - foreach $v (@{ $p }) { - next if (!defined($v) || - ref($v) ne 'HASH'); - next if (!length($v->{'url'}) || - (!length($v->{'expanded_url'}) && - !length($v->{'media_url'}))); - my $u1 = &descape($v->{'url'}); - &openurl($u1); - $didprint++; - } - } - print $stdout - "-- sorry, couldn't find any URL.\n" - if (!$didprint); - return 0; - } - print $stdout - "-- unable to use t.co URLs, using fallback\n"; - } - # that failed, so fall back on the old method. - my $text = &descape($tweet->{'text'}); - # findallurls - while ($text - =~ s#(h?ttp|h?ttps|ftp|gopher)://([a-zA-Z0-9_~/:%\-\+\.\=\&\?\#,]+)##){ -# sigh. I HATE YOU TINYARRO.WS -#TODO -# eventually we will have to put a punycode implementation into openurl -# to handle things like Mac OS X's open which don't understand UTF-8 URLs. -# when we do, uncomment this again -# =~ s#(http|https|ftp|gopher)://([^'\\]+?)('|\\|\s|$)##) { - my $url = $1 . "://$2"; - $url = "h$url" if ($url =~ /^ttps?:/); - $url =~ s/[\.\?]$//; - &openurl($url); - } - print $stdout "-- sorry, couldn't find any URL.\n" - if (!defined($urlshort)); - return 0; - } - -#TODO - if (s/^\/(favourites|favorites|faves|favs|fl)(\s+\+\d+)?\s*//) { - my $my_json_ref; - my $countmaybe = $2; - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - - if (length) { - $my_json_ref = &grabjson("${favsurl}?screen_name=$_", - 0, 0, $countmaybe, undef, 1); - } else { - if ($anonymous) { - print $stdout - "-- sorry, you can't haz favourites if you're anonymous.\n"; - } else { - print $stdout - "-- synchronous /favourites user command\n" - if ($verbose); - $my_json_ref = &grabjson($favsurl, 0, 0, - $countmaybe, undef, 1); - } - } - if (defined($my_json_ref) - && ref($my_json_ref) eq 'ARRAY') { - if (scalar(@{ $my_json_ref })) { - my $w = "-==- favourites " x 10; - $w = $EM . substr($w, 0, $wrap || 79) . $OFF; - print $stdout "$w\n"; - &tdisplay($my_json_ref, "favourites"); - print $stdout "$w\n"; - } else { - print $stdout - "-- no favourites found, boring impartiality concluded.\n"; - } - } - &$conclude; - return 0; - } - if ( -m#^/(un)?f(rt|retweet|a|av|ave|avorite|avourite)? ([zZ]?[a-zA-Z]?[0-9]+)$#) { - my $mode = $1; - my $secondmode = $2; - my $code = lc($3); - $secondmode = ($secondmode eq 'retweet') ? 'rt' : $secondmode; - if ($mode eq 'un' && $secondmode eq 'rt') { - print $stdout - "-- hmm. seems contradictory. no dice.\n"; - return 0; - } - my $tweet = &get_tweet($code); - if (!defined($tweet)) { - print $stdout "-- no such tweet (yet?): $code\n"; - return 0; - } - &cordfav($tweet->{'id_str'}, 1, - (($mode eq 'un') ? $favdelurl : $favurl), - &descape($tweet->{'text'}), - (($mode eq 'un') ? 'removed' : 'created')); - if ($secondmode eq 'rt') { - $_ = "/rt $code"; - # and fall through - } else { - return 0; - } - } - - # Retweet API and manual RTs - if (s#^/([oe]?)r(etweet|t) ([zZ]?[a-zA-Z]?[0-9]+)\s*##) { - my $mode = $1; - my $code = lc($3); - my $tweet = &get_tweet($code); - if (!defined($tweet)) { - print $stdout "-- no such tweet (yet?): $code\n"; - return 0; - } - # use a native retweet unless we can't (or user used /ort /ert) - unless ($nonewrts || length || length($mode)) { - # we don't always get rs->text, so we simulate it. - my $text = &descape($tweet->{'text'}); - $text =~ s/^RT \@[^\s]+:\s+// - if ($tweet->{'retweeted_status'}->{'id_str'}); - print $stdout "-- status retweeted\n" - unless(&updatest($text, 1, 0, undef, - $tweet->{'retweeted_status'}->{'id_str'} - || $tweet->{'id_str'})); - return 0; - } - # we can't or user requested /ert /ort - $retweet = "RT @" . - &descape($tweet->{'user'}->{'screen_name'}) . - ": " . &descape($tweet->{'text'}); - if ($mode eq 'e') { - &add_history($retweet); - print $stdout &wwrap( - "-- ok, %RT% and %% are now \"$retweet\"\n"); - return 0; - } - $_ = (length) ? "$retweet $_" : $retweet; - print $stdout &wwrap("(expanded to \"$_\")"); - print $stdout "\n"; - goto TWEETPRINT; # fugly! FUGLY! - } - - if (m#^/(re)?rts?of?me?(\s+\+\d+)?$# && !$nonewrts) { -#TODO -# when more fields are added, integrate them over the JSON_ref - my $mode = $1; - my $countmaybe = $2; - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - - my $my_json_ref = &grabjson($rtsofmeurl, 0, 0, $countmaybe); - &dt_tdisplay($my_json_ref, "rtsofme"); - if ($mode eq 're') { - $_ = '/re'; # and fall through ... - } else { - return 0; - } - } - if (m#^/rts?of\s+([zZ]?[a-zA-Z]?[0-9]+)$# && !$nonewrts) { - my $code = lc($1); - my $tweet = &get_tweet($code); - my $id; - - if (!defined($tweet)) { - print $stdout "-- no such tweet (yet?): $code\n"; - return 0; - } - $id = $tweet->{'retweeted_status'}->{'id_str'} || - $tweet->{'id_str'}; - if (!$id) { - print $stdout "-- hmmm, that tweet is major bogus.\n"; - return 0; - } - my $url = $rtsbyurl; - $url =~ s/%I/$id/; - my $users_ref = &grabjson("$url", 0, 0, 100, undef, 1); - return if (!defined($users_ref) || ref($users_ref) ne 'ARRAY'); - my $k = scalar(@{ $users_ref }); - if (!$k) { - print $stdout - "-- no known retweeters, or they're private.\n"; - return 0; - } - my $j; - foreach $j (@{ $users_ref }) { - &$userhandle($j->{'user'}); - } - return 0; - } - - # enable and disable NewRTs from users - # we allow this even if newRTs are off from -nonewrts - if (s#^/rts(on|off)\s+## && length) { - &rtsonoffuser($_, 1, ($1 eq 'on')); - return 0; - } - - if (m#^/del(ete)?\s+([zZ]?[a-zA-Z]?[0-9]+)$#) { - my $code = lc($2); - unless ($code =~ /^d[0-9][0-9]+$/) { # this is a DM. - my $tweet = &get_tweet($code); - if (!defined($tweet)) { - print $stdout "-- no such tweet (yet?): $code\n"; - return 0; - } - if (lc(&descape($tweet->{'user'}->{'screen_name'})) - ne lc($whoami)) { - print $stdout - "-- not allowed to delete somebody's else's tweets\n"; - return 0; - } - print $stdout &wwrap( -"-- verify you want to delete: \"@{[ &descape($tweet->{'text'}) ]}\""); - print $stdout "\n"; - $answer = lc(&linein( - "-- sure you want to delete? (only y or Y is affirmative):")); - if ($answer ne 'y') { - print $stdout "-- ok, tweet is NOT deleted.\n"; - return 0; - } - $lastpostid = -1 if ($tweet->{'id_str'} == $lastpostid); - &deletest($tweet->{'id_str'}, 1); - return 0; - } # dxxx falls through to ... - } - # DM delete version - if (m#^/del(ete)? ([dD][a-zA-Z]?[0-9]+)$#) { - my $code = lc($2); - my $dm = &get_dm($code); - if (!defined($dm)) { - print $stdout "-- no such DM (yet?): $code\n"; - return 0; - } - print $stdout &wwrap( - "-- verify you want to delete: " . - "(from @{[ &descape($dm->{'sender'}->{'screen_name'}) ]}) ". - "\"@{[ &descape($dm->{'text'}) ]}\""); - print $stdout "\n"; - $answer = lc(&linein( - "-- sure you want to delete? (only y or Y is affirmative):")); - if ($answer ne 'y') { - print $stdout "-- ok, DM is NOT deleted.\n"; - return 0; - } - &deletedm($dm->{'id_str'}, 1); - return 0; - } - # /deletelast - if (m#^/de?l?e?t?e?last$#) { - if (!$lastpostid) { - print $stdout "-- you haven't posted yet this time!\n"; - return 0; - } - if ($lastpostid == -1) { - print $stdout "-- you already deleted it!\n"; - return 0; - } - print $stdout &wwrap( -"-- verify you want to delete: \"$lasttwit\""); - print $stdout "\n"; - $answer = lc(&linein( - "-- sure you want to delete? (only y or Y is affirmative):")); - if ($answer ne 'y') { - print $stdout "-- ok, tweet is NOT deleted.\n"; - return 0; - } - &deletest($lastpostid, 1); - $lastpostid = -1; - return 0; - } - - if (s#^/(v)?re(ply)? ([zZ]?[a-zA-Z]?[0-9]+) ## && length) { - my $mode = $1; - my $code = lc($3); - unless ($code =~ /^d[0-9][0-9]+/) { # this is a DM - my $tweet = &get_tweet($code); - if (!defined($tweet)) { - print $stdout "-- no such tweet (yet?): $code\n"; - return 0; - } - my $target = &descape($tweet->{'user'}->{'screen_name'}); - $_ = '@' . $target . " $_"; - unless ($mode eq 'v') { - $in_reply_to = $tweet->{'id_str'}; - $expected_tweet_ref = $tweet; - } else { - $_ = ".$_"; - } - $readline_completion{'@'.lc($target)}++ if ($termrl); - print $stdout &wwrap("(expanded to \"$_\")"); - print $stdout "\n"; - goto TWEETPRINT; # fugly! FUGLY! - } else { - # this is a DM, reconstruct it - $_ = "/${mode}re $code $_"; - # and fall through to ... - } - } - # DM reply version - if (s#^/(dm)?re(ply)? ([dD][a-zA-Z]?[0-9]+) ## && length) { - my $code = lc($3); - my $dm = &get_dm($code); - if (!defined($dm)) { - print $stdout "-- no such DM (yet?): $code\n"; - return 0; - } - # in the future, add DM in_reply_to here - my $target = &descape($dm->{'sender'}->{'screen_name'}); - $readline_completion{'@'.lc($target)}++ if ($termrl); - $_ = "/dm $target $_"; - print $stdout &wwrap("(expanded to \"$_\")"); - print $stdout "\n"; - # and fall through to /dm - } - # replyall (based on @FunnelFiasco's extension) - if (s#^/(v)?r(eply)?(to)?a(ll)? ([zZ]?[a-zA-Z]?[0-9]+) ## && length) { - my $mode = $1; - my $code = $5; - - # common code from /vreply - my $tweet = &get_tweet($code); - if (!defined($tweet)) { - print $stdout "-- no such tweet (yet?): $code\n"; - return 0; - } - my $target = &descape($tweet->{'user'}->{'screen_name'}); - my $text = $_; - $_ = '@' . $target; - unless ($mode eq 'v') { - $in_reply_to = $tweet->{'id_str'}; - $expected_tweet_ref = $tweet; - } else { - $_ = ".$_"; - } - - # don't repeat the target or myself; track other mentions - my %did_mentions = map { $_ => 1 } (lc($target)); - my $reply_tweet = &descape($tweet->{'text'}); - - while($reply_tweet =~ s/\@(\w+)//) { - my $name = $1; - my $mame = lc($name); # preserve camel case - next if ($mame eq $whoami || $did_mentions{$mame}++); - $_ .= " \@$name"; - } - $_ .= " $text"; - - # add everyone in did_mentions to readline_completion - grep { $readline_completion{'@'.$_}++ } (keys %did_mentions) - if ($termrl); - - # and fall through to post - print $stdout &wwrap("(expanded to \"$_\")"); - print $stdout "\n"; - goto TWEETPRINT; # fugly! FUGLY! - } - - if (m#^/re(plies)?(\s+\+\d+)?$#) { - my $countmaybe = $2; - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - - if ($anonymous) { - print $stdout - "-- sorry, how can anyone reply to you if you're anonymous?\n"; - } else { - # we are intentionally not keeping track of "last_re" - # in this version because it is not automatically - # updated and may not act as we expect. - print $stdout "-- synchronous /replies command\n" - if ($verbose); - my $my_json_ref = &grabjson($rurl, 0, 0, $countmaybe, - undef, 1); - &dt_tdisplay($my_json_ref, "replies"); - } - return 0; - } - - # DMs - if ($_ eq '/dm' || $_ eq '/dmrefresh' || $_ eq '/dmr') { - &dmthump; - return 0; - } - # /dmsent, /dmagain - if (m#^/dm(s|sent|a|again)(\s+\+\d+)?$#) { - my $mode = $1; - my $countmaybe = $2; - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - if ($countmaybe > 999) { - print $stdout "-- greedy bastard, try +fewer.\n"; - return 0; - } - $countmaybe = sprintf("%03i", $countmaybe); - print $stdout "-- background request sent\n" unless ($synch); - - $mode = ($mode =~ /^s/) ? 's' : 'd'; - print C "${mode}mreset${countmaybe}---------\n"; - &sync_semaphore; - return 0; - } - if (s#^/dm \@?([^\s]+)\s+## && length) { - return &common_split_post($_, undef, $1); - } - - # follow and leave users - if (m#^/(follow|leave|unfollow) \@?([^\s/]+)$#) { - my $m = $1; - my $u = lc($2); - &foruuser($u, 1, - (($m eq 'follow') ? $followurl : $leaveurl), - (($m eq 'follow') ? 'started' : 'stopped')); - return 0; - } - - # follow and leave lists. this is, frankly, pointless; it does - # nothing other than to mark you. otherwise, /liston and /listoff - # actually add lists to your timeline. - if (m#^/(l?follow|l?leave|l?unfollow) \@?([^\s/]*)/([^\s/]+)$#) { - my $m = $1; - my $uname = lc($2); - my $lname = lc($3); - - if (!length($uname) || $uname eq $whoami) { - print $stdout &wwrap( -"** you can't mark/unmark yourself as a follower of your own lists!\n"); - print $stdout &wwrap( -"** to add/remove your own lists from your timeline, use /liston /listoff\n"); - return 0; - } - if ($m !~ /^l/) { - print $stdout &wwrap( -"-- to mark/unmark you as a follower of a list, use /lfollow /lleave\n"); - print $stdout &wwrap( -"-- to add/remove your own lists from your timeline, use /liston /listoff\n"); - return 0; - } - - my $r = &postjson( - ($m ne 'lfollow') ? $delfliurl : $crefliurl, - "owner_screen_name=$uname&slug=$lname"); - if ($r) { - my $t = ($m eq 'lfollow') ? "" : "un"; - print $stdout &wwrap( -"*** ok, you are now ${t}marked as a follower of $uname/${lname}.\n"); - my $c = ($t eq 'un') ? "off" : "on"; - $t = ($t eq 'un') ? "remove from" : "add to"; - print $stdout &wwrap( -"--- to also $t your timeline, use /list${c}\n"); - } - return 0; - } - - # block and unblock users - if (m#^/(block|unblock) \@?([^\s/]+)$#) { - my $m = $1; - my $u = lc($2); - if ($m eq 'block') { - $answer = lc(&linein( - "-- sure you want to block $u? (only y or Y is affirmative):")); - if ($answer ne 'y') { - print $stdout "-- ok, $u is NOT blocked.\n"; - return 0; - } - } - &boruuser($u, 1, - (($m eq 'block') ? $blockurl : $blockdelurl), - (($m eq 'block') ? 'started' : 'stopped')); - return 0; - } - - # list support - # /withlist (/withlis, /with, /wl) - if (s#^/(withlist|withlis|withl|with|wl)\s+([^/\s]+)\s+## && - ($lname=lc($2)) && s/\s*$// && length) { - my $comm = ''; - my $args = ''; - my $dont_return = 0; - if ($anonymous) { - print $stdout "-- no list love for anonymous\n"; - return 0; - } - if (/\s+/) { - ($comm, $args) = split(/\s+/, $_, 2); - } else { - $comm = $_; - } - - my $return; - # this is a Twitter bug -- it will not give you the - # new slug in the returned hash. - my $state = "modified list $lname (WAIT! then /lists to see new slug)"; - if ($comm eq 'create') { - my $desc; - ($args, $desc) = split(/\s+/, $args, 2) - if ($args =~ /\s+/); - if ($args ne 'public' && $args ne 'private') { - print $stdout - "-- must specify public or private\n"; - return 0; - } - $state = "created new list $lname (mode $args)"; - $desc = "description=".&url_oauth_sub($desc)."&" - if (length($desc)); - $return = &postjson($creliurl, - "${desc}mode=$args&name=$lname"); - } elsif ($comm eq 'private' || $comm eq 'public') { - $return = &postjson($modifyliurl, - "mode=$comm&owner_screen_name=${whoami}&slug=${lname}"); - } elsif ($comm eq 'desc' || $comm eq 'description') { - if (!length($args)) { - print $stdout "-- $comm needs an argument\n"; - return 0; - } - $return = &postjson($modifyliurl, - "description=".&url_oauth_sub($args). - "&owner_screen_name=${whoami}&slug=${lname}"); - } elsif ($comm eq 'name') { - if (!length($args)) { - print $stdout "-- $comm needs an argument\n"; - return 0; - } - $return = &postjson($modifyliurl, - "name=".&url_oauth_sub($args). - "&owner_screen_name=${whoami}&slug=${lname}"); - $state = "RENAMED list $lname (WAIT! then /lists to see new slug)"; - } elsif ($comm eq 'add' || $comm eq 'adduser' || - ($comm eq 'delete' && length($args))) { - my $u = ($comm eq 'delete') ? $deluliurl : $adduliurl; - $state = ($comm eq 'delete') - ? "user(s) deleted from list $lname" - : "user(s) added to list $lname"; - if ($args !~ /,/ || $args =~ /\s+/) { - 1 while ($args =~ s/\s+/,/); - } - if ($args =~ /\s*,\s+/ || $args =~ /\s+,\s*/) { - 1 while ($args =~ s/\s+//); - } - if (!length($args)) { - print $stdout "-- illegal/missing argument\n"; - return 0; - } - print $stdout "--- warning: user list not checked\n"; - $return = &postjson($u, - "owner_screen_name=${whoami}". - "&screen_name=".&url_oauth_sub($args). - "&slug=${lname}"); - } elsif ($comm eq 'delete' && !length($args)) { - $state = "deleted list $lname"; - print $stdout - "-- verify you want to delete list $lname\n"; - my $answer = lc(&linein( - "-- sure you want to delete? (only y or Y is affirmative):")); - if ($answer ne 'y') { - print $stdout "-- ok, list is NOT deleted.\n"; - return 0; - } - $return = &postjson($delliurl, - "owner_screen_name=${whoami}&slug=${lname}"); - if ($return) { - # check and see if this is in our autolists. - # if it is, delete it there too. - my $value = &getvariable('lists'); - &setvariable('lists', $value, 1) - if ($value=~s#(^|,)${whoami}/${lname}($|,)##); - } - } elsif ($comm eq 'list') { # synonym for /list - $_ = "/list /$lname"; - $dont_return = 1; # and fall through - } else { - print $stdout "*** illegal list operation $comm\n"; - } - if ($return) { - print $stdout "*** ok, $state\n"; - } - return 0 unless ($dont_return); - } - - # /a to show statuses in a list - if (m#^/a(gain)?\s+(\+\d+\s+)?\@?([^\s/]*)/([^\s/]+)#) { - my $uname = lc($3); - if ($anonymous && !length($uname)) { - print $stdout "-- you must specify a username when anonymous.\n"; - return 0; - } - my $lname = lc($4); - my $countmaybe = $2; - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - $uname ||= $whoami; - - my $my_json_ref = &grabjson( - "${statusliurl}?owner_screen_name=${uname}&slug=${lname}", - 0, 0, $countmaybe, undef, 1); - &dt_tdisplay($my_json_ref, "again"); - return 0; - } - - # /lists command: if @, show their lists. if @?../... show that list. - # trivially duplicates /frs and /fos for lists - # also handles /listfos and /listfrs - if (length($whoami) && - (m#^/list?s?$# || m#^/list?f[ro](llower|iend)?s$#)) { - $_ .= " $whoami"; - } - if (m#^/lis(t|ts|t?fos|tfollowers|t?frs|tfriends)?\s+(\+\d+\s+)?(\@?[^\s]+)$#) { - my $mode = $1; - my $countmaybe = $2; - my $uname = lc($3); - my $lname = ''; - - $mode = ($mode =~ /^t?fo/) ? 'fo' : - ($mode =~ /^t?fr/) ? 'fr' : - ''; - $uname =~ s/^\@//; - ($uname, $lname) = split(m#/#, $uname, 2) if ($uname =~ m#/#); - if ($anonymous && !length($uname) && length($mode)) { - print $stdout "-- you must specify a username when anonymous.\n"; - return 0; - } - $uname ||= $whoami; - if (length($lname) && length($mode)) { - print $stdout "-- specify username only\n"; - return 0; - } - - $countmaybe =~ s/[^\d]//g if (length($countmaybe)); - $countmaybe += 0; - $countmaybe ||= 20; - - # this is copied from /friends and /followers (q.v.) - my $countper = ($countmaybe < 100) ? $countmaybe : 100; - - my $cursor = -1; # initial value - my $nofetch = 0; - my $printed = 0; - my $json_ref = undef; - my @usarray = undef; shift(@usarray); # force underflow - my $furl = (length($lname)) ? ($getliurl."?owner_") - : ($mode eq '') ? ($getlisurl."?") - : ($mode eq 'fo') ? ($getuliurl."?") - : ($getufliurl."?"); - $furl .= "screen_name=${uname}"; - $furl .= "&slug=${lname}" if (length($lname)); - - LABIO: while($countmaybe--) { - if(!scalar(@usarray)) { - last LABIO if ($nofetch); - $json_ref = &grabjson( - "${furl}&count=${countper}&cursor=${cursor}", 0, 0, 0, - undef, 1); - @usarray = @{ ((length($lname)) ? - $json_ref->{'users'} : - $json_ref - ) }; - last LABIO if (!scalar(@usarray)); - if (length($lname)) { - $cursor = $json_ref->{'next_cursor_str'} || - $json_ref->{'next_cursor'} || -1; - $nofetch = ($cursor < 1) ? 1 : 0; - } else { $nofetch = 1; } - } - my $list_ref = shift(@usarray); - if (length($lname)) { - &$userhandle($list_ref); - } else { - # lists/list returns their lists AND the - # ones they subscribe to, different from 1.0. - # right now we just deal with that. - #next if ($uname ne - # $list_ref->{'user'}->{'screen_name'}); - - # listhandle? - my $list_name = -"\@$list_ref->{'user'}->{'screen_name'}/@{[ &descape($list_ref->{'slug'}) ]}"; - my $list_full_name = - (length($list_ref->{'name'})) ? -&descape($list_ref->{'name'})."${OFF} ($list_name)" : $list_name; - my $list_mode = - (lc(&descape($list_ref->{'mode'})) ne 'public') ? -" ${EM}(@{[ ucfirst(&descape($list_ref->{'mode'})) ]})${OFF}" : ""; - print $streamout <<"EOF"; -${CCprompt}$list_full_name${OFF} (f:$list_ref->{'member_count'}/$list_ref->{'subscriber_count'})$list_mode -EOF - my $desc = &strim(&descape($list_ref->{'description'})); - my $klen = ($wrap || 79) - 9; - $klen = 10 if ($klen < 0); - $desc = substr($desc, 0, $klen)."..." - if (length($desc) > $klen); - print $streamout (' "' . $desc . '"' . "\n") - if (length($desc)); - } - $printed++; - } - if (!$printed) { - print $stdout ((length($lname)) - ? "-- list $uname/$lname does not follow anyone.\n" - : ($mode eq 'fr') - ? "-- user $uname doesn't follow any lists.\n" - : ($mode eq 'fo') - ? "-- user $uname isn't followed by any lists.\n" - : "-- no lists found for user $uname.\n"); - } - return 0; - } - - &sync_n_quit if ($_ eq '/end' || $_ eq '/e'); - - ##### - # - # below this point, we are posting - # - ##### - - if (m#^/me\s#) { - $slash_first = 0; # kludge! - } - - if ($slash_first) { - if (!m#^//#) { - print $stdout "*** invalid command\n"; - print $stdout "*** to pass as a tweet, type /%%\n"; - return 0; - } - s#^/##; # leave the second slash on - } - -TWEETPRINT: # fugly! FUGLY! - return &common_split_post($_, $in_reply_to, undef); -} - -# this is the common code used by standard updates and by the /dm command. -sub common_split_post { - my $k = shift; - my $in_reply_to = shift; - my $dm_user = shift; - - my $dm_lead = (length($dm_user)) ? "/dm $dm_user " : ''; - my $ol = "$dm_lead$k"; - - my (@tweetstack) = &csplit($k, ($autosplit eq 'char' || - $autosplit eq 'cut') ? 1 : 0); - my $m = shift(@tweetstack); - if (scalar(@tweetstack)) { - $l = "$dm_lead$m"; - $history[0] = $l; - if (!$autosplit) { - print $stdout &wwrap( -"*** sorry, too long to send; ". -"truncated to \"$l\" (@{[ length($m) ]} chars)\n"); - print $stdout "*** use %% for truncated version, or append to %%.\n"; - return 0; - } - print $stdout &wwrap( - "*** over $linelength; autosplitting to \"$l\"\n"); - } - # there was an error; stop autosplit, restore original command - if (&updatest($m, 1, $in_reply_to, $dm_user)) { - $history[0] = $ol; - return 0; - } - if (scalar(@tweetstack)) { - $k = shift(@tweetstack); - $l = "$dm_lead$k"; - &add_history($l); - print $stdout &wwrap("*** next part is ready: \"$l\"\n"); - print $stdout "*** (this will also be automatically split)\n" - if (length($k) > $linelength); - print $stdout - "*** to send this next portion, use %%.\n"; - } - return 1; -} - -# helper functions for the command line processor. -sub add_history { - my $h = shift; - - @history = (($h, @history)[0..&min(scalar(@history), $maxhist)]); - if ($termrl) { - if ($termrl->Features()->{'canSetTopHistory'}) { - $termrl->settophistory($h); - } else { - $termrl->addhistory($h); - } - } -} -sub sub_helper { - my $r = shift; - my $s = shift; - my $g = shift; - my $x; - my $q = 0; - my $proband; - - if ($r eq '%') { - $x = -1; - } else { - $x = $r + 0; - } - if (!$x || $x < -(scalar(@history))) { - print $stdout "*** illegal history index\n"; - return (0, $_, undef, undef, undef); - } - $proband = $history[-($x + 1)]; - if ($s eq '--') { - $q = 1; - } elsif ($s eq '*') { - if ($x != -1 || !length($shadow_history)) { - print $stdout - "*** can only %%* on most recent command\n"; - return (0, $_, undef, undef, undef); - } - # we assume it's at the end; it's only relevant there - $proband = substr($shadow_history, length($g)-(2+length($r))); - } else { - $q = -(0+$s); - } - if ($q) { - my $j; - my $c; - for($j=0; $j<$q; $j++) { - $c++ if ($proband =~ s/\s+[^\s]+$//); - } - if ($j != $c) { - print $stdout "*** illegal word index\n"; - return (0, $_, undef, undef, undef); - } - } - return (1, $proband, $r, $s); -} - -# this is used for synchronicity mode to make sure we receive the -# GA semaphore from the background before printing another prompt. -sub sync_console { - &thump; - &dmthump unless (!$dmpause); -} -sub sync_semaphore { - if ($synch) { - my $k = ''; - - while(!length($k)) { - sysread(W, $k, 1); - } # wait for semaphore - } -} - -# wrapper function to get a line from the terminal. -sub linein { - my $prompt = shift; - my $return; - - return 'y' if ($script); - - $prompt .= " "; - if ($termrl) { - $dont_use_counter = 1; - eval '$termrl->hook_no_counter'; - $return = $termrl->readline($prompt); - $dont_use_counter = $nocounter; - eval '$termrl->hook_no_counter'; - } else { - print $stdout $prompt; - chomp($return = lc(<$stdin>)); - } - return $return; -} - -#### this is the background part of the process #### - -MONITOR: -%store_hash = (); -$is_background = 1; -$first_synch = $synchronous_mode = 0; -$rin = ''; -vec($rin,fileno(STDIN),1) = 1; -# paranoia -binmode($stdout, ":crlf") if ($termrl); -unless ($seven) { - binmode(STDIN, ":utf8"); - binmode($stdout, ":utf8"); -} - -# allow foreground process to squelch us -# we have to cover all the various versions of 30/31 signals on various -# systems just in case we are on a system without POSIX.pm. this set should -# cover Linux 2.x/3.x, AIX, Mac OS X, *BSD and Solaris. we have to assert -# these signals before starting streaming, or we may "kill" ourselves by -# accident because it is possible to process a tweet before these are -# operational. -&sigify(sub { - $suspend_output ^= 1 if ($suspend_output != -1); - $we_got_signal = 1; -}, qw(USR1 PWR XCPU)); -&sigify( sub { - $suspend_output = -1; $we_got_signal = 1; -}, qw(USR2 SYS UNUSED XFSZ)); -&sigify("IGNORE", qw(INT)); # don't let slowpost kill us - -# now we can safely initialize streaming -if ($dostream) { - @events = (); - $lasteventtime = time(); - &sigify(sub { - print $stdout "-- killing processes $nursepid $bufferpid\n" - if ($verbose); - kill $SIGHUP, $nursepid if ($nursepid); - kill $SIGHUP, $bufferpid if ($bufferpid); - kill 9, $curlpid if ($curlpid); - sleep 1; - # send myself a shutdown - kill 9, $nursepid if ($nursepid); - kill 9, $bufferpid if ($bufferpid); - kill $SIGTERM, $$; - }, qw(HUP)); # use SIGHUP etc. from parent process to signal end - $bufferpid = &start_streaming; - vec($rin, fileno(STBUF), 1) = 1; -} else { - &sigify("IGNORE", qw(HUP)); # we only respond to SIGKILL/SIGTERM -} - -$interactive = $previous_last_id = $we_got_signal = 0; -$suspend_output = -1; -$stream_failure = 0; -$dm_first_time = ($dmpause) ? 1 : 0; -$stuck_stdin = 0; - -# tell the foreground we are ready -kill $SIGUSR2, $parent; - -# loop until we are killed or told to stop. -# we receive instructions on stdin, and send data back on our pipe(). -for(;;) { - &$heartbeat; - &update_effpause; - $wrapseq = 0; # remember, we don't know when commands are sent. - &refresh($interactive, $previous_last_id) unless - (!$effpause && !$interactive); - $dont_refresh_first_time = 0; - $previous_last_id = $last_id; - if ($dmpause && ($effpause || $synch)) { - if ($dm_first_time) { - &dmrefresh(0); - $dmcount = $dmpause; - } elsif (!$interactive) { - if (!--$dmcount) { - &dmrefresh($interactive); # using dm_first_time - $dmcount = $dmpause; - } - } - } -DONT_REFRESH: - # nrvs is tricky with synchronicity - if (!$synch || ($synch && $synchronous_mode && !$dm_first_time)) { - $k = length($notify_rate) + length($vs) + length($credlog); - if ($k) { - &send_removereadline if ($termrl); - print $stdout $notify_rate; - print $stdout $vs; - print $stdout $credlog; - $wrapseq = 1; - } - $notify_rate = ""; - $vs = ""; - $credlog = ""; - } - print P "0" if ($synchronous_mode && $interactive); - &send_repaint if ($termrl); - - # this core loop is tricky. most signals will not restart the call. - # -- respond to alarms if we are ignoring our timeout. - # -- do not respond to bogus packets if a signal handler triggered it. - # -- clear our flag when we detect a signal handler has been called. - - # if our master select is interrupted, we must restart with the - # appropriate time taken from effpause. however, most implementations - # don't report timeleft, so we must. - $restarttime = time() + $effpause; -RESTART_SELECT: - &send_repaint if ($termrl); - $interactive = 0; - $we_got_signal = 0; # acknowledge all signals - if ($effpause == undef) { # -script and anonymous have no effpause. - print $stdout "-- select() loops forever\n" if ($verbose); - $nfound = select($rout = $rin, undef, undef, undef); - } else { - $actualtime = $restarttime - time(); - print $stdout "-- select pending ($actualtime sec left)\n" - if ($superverbose); - if ($actualtime <= 0) { - $nfound = 0; - } else { - $nfound = select( - $rout = $rin, undef, undef, $actualtime); - } - } - if ($nfound > 0) { - my $len; - - # service the streaming socket first, if we have one. - if ($dostream) { - if (vec($rout, fileno(STBUF), 1) == 1) { - my $json_ref; - my $buf = ''; - my $rbuf; - my $reads = 0; - - print $stdout "-- data on streaming socket\n" - if ($superverbose); - - # read until we get eight hex digits. this forces the - # data stream to synchronize. - # first, however, make sure we actually have valid - # data, or we sit here and slow down the user. - sysread(STBUF, $buf, 1); - if (!length($buf)) { - # if we get a "ready" but there's actually - # no data, that means either 1) a signal - # occurred on the buffer, which we need to - # ignore, or 2) something killed the - # buffer, which is unrecoverable. if we keep - # getting repeated ready-no data situations, - # it's probably the latter. - $stream_failure++; - &screech(<<"EOF") if ($stream_failure > 100); - -*** fatal error *** -something killed the streaming buffer process. I can't recover from this. -please restart TTYtter. -EOF - goto DONESTREAM; - } - $stream_failure = 0; - if ($buf !~ /^[0-9a-fA-F]+$/) { - print $stdout - "-- warning: bogus character(s) ".unpack("H*", $buf)."\n" - if ($superverbose); - goto DONESTREAM; - } - while (length($buf) < 8) { - # don't read 8 -- read 1. that means we can - # skip trailing garbage without a window. - sysread(STBUF, $rbuf, 1); - $reads++; - if ($rbuf =~ /[0-9a-fA-F]/) { - $buf .= $rbuf; - $reads = 0; - } else { - print $stdout - "-- warning: bogus character(s) ".unpack("H*", $rbuf)."\n" - if ($superverbose); - $buf = '' - if (length($rbuf)); # bogus data - } - print $stdout - "-- master, I am stuck: $reads reads on stream and no valid data\n" - if ($reads > 0 && ($reads % 1000) == 0); - } - print $stdout "-- length packet: $buf\n" - if ($superverbose); - $len = hex($buf); - $buf = ''; - while (length($buf) < $len) { - sysread(STBUF, $rbuf, ($len-length($buf))); - $buf .= $rbuf; - } - - print $stdout - "-- streaming data ($len) --\n$buf\n-- streaming data --\n\n" - if ($superverbose); - $json_ref = &parsejson($buf); - push(@events, $json_ref); - - if (scalar(@events) > $eventbuf || (scalar(@events) && - (time()-$lasteventtime) > $effpause)){ - sleep 5 while ($suspend_output > 0); - &streamevents(@events); - &send_repaint if ($termrl); - @events = (); - $lasteventtime = time(); - } - } - DONESTREAM: print $stdout "-- done with streaming events\n" - if ($superverbose); - } - - # then, check if there is data on our control socket. - # command packets should always be (initially) 20 characters. - # if we come up short, it's either a bug, signal or timeout. - if ($we_got_signal) { - goto RESTART_SELECT; - } - goto RESTART_SELECT if(vec($rout, fileno(STDIN), 1) != 1); - print $stdout "-- waiting for data ", scalar localtime, "\n" - if ($superverbose); - if(sysread(STDIN, $rout, 20) != 20) { - # if we get repeated "ready" but no data on STDIN, - # like the streaming buffer, we probably lost our - # IPC and we should die here. - if (++$stuck_stdin > 100) { - print $stdout "parent is dead; we die too\n"; - kill 9,$$; - } - goto RESTART_SELECT; - } - $stuck_stdin = 0; - # background communications central command code - # we received a command from the console, so let's look at it. - print $stdout "-- command received ", scalar - localtime, " $rout" if ($verbose); - if ($rout =~ /^rsga/) { - $suspend_output = 0; # reset our status - goto RESTART_SELECT; - } elsif ($rout =~ /^pipet (..)/) { - my $key = &get_tweet($1); - my $ms = $key->{'menu_select'} || 'XX'; - my $ds = $key->{'created_at'} || 'argh, no created_at'; - $ds =~ s/\s/_/g; - my $src = $key->{'source'} || 'unknown'; - $src =~ s/\|//g; # shouldn't be any anyway. - $key = substr(( "$ms ".($key->{'id_str'})." ". - ($key->{'in_reply_to_status_id_str'})." ". - ($key->{'retweeted_status'}->{'id_str'})." ". - ($key->{'user'}->{'geo_enabled'} || "false") . " ". - ($key->{'geo'}->{'coordinates'}->[0]). " ". - ($key->{'geo'}->{'coordinates'}->[1]). " ". - $key->{'place'}->{'id'} . " ". - $key->{'place'}->{'country_code'} ." ". - $key->{'place'}->{'place_type'} . " ". - unpack("${pack_magic}H*", $key->{'place'}->{'full_name'})." ". - $key->{'tag'}->{'type'}. " ". # NO SPACES! - unpack("${pack_magic}H*", $key->{'tag'}->{'payload'}). " ". - ($key->{'retweet_count'} || "0") . " " . - $key->{'user'}->{'screen_name'}." $ds $src|". - unpack("${pack_magic}H*", $key->{'text'}). - $space_pad), 0, 1024); - print P $key; - goto RESTART_SELECT; - } elsif ($rout =~ /^piped (..)/) { - my $key = $dm_store_hash{$1}; - my $ms = $key->{'menu_select'} || 'XX'; - my $ds = $key->{'created_at'} || 'argh, no created_at'; - $ds =~ s/\s/_/g; - $key = substr(( "$ms ".($key->{'id_str'})." ". - $key->{'sender'}->{'screen_name'}." $ds ". - unpack("${pack_magic}H*", $key->{'text'}). - $space_pad), 0, 1024); - print P $key; - goto RESTART_SELECT; - } elsif ($rout =~ /^ki ([^\s]+) /) { - my $key = $1; - my $module; - sysread(STDIN, $module, 1024); - $module =~ s/\s+$//; - $module = pack("H*", $module); - print $stdout "-- fetch for module $module key $key\n" - if ($verbose); - print P substr(unpack("${pack_magic}H*", - $master_store->{$module}->{$key}).$space_pad, - 0, 1024); - goto RESTART_SELECT; - } elsif ($rout =~ /^kn ([^\s]+) /) { - my $key = $1; - my $module; - sysread(STDIN, $module, 1024); - $module =~ s/\s+$//; - $module = pack("H*", $module); - print $stdout "-- nulled module $module key $key\n" - if ($verbose); - $master_store->{$module}->{$key} = undef; - goto RESTART_SELECT; - } elsif ($rout =~ /^ko ([^\s]+) /) { - my $key = $1; - my $value; - my $module; - sysread(STDIN, $module, 1024); - $module =~ s/\s+$//; - $module = pack("H*", $module); - sysread(STDIN, $value, 1024); - $value =~ s/\s+$//; - print $stdout - "-- set module $module key $key = $value\n" - if ($verbose); - $master_store->{$module}->{$key} = pack("H*", $value); - goto RESTART_SELECT; - } elsif ($rout =~ /^sync/) { - print $stdout "-- synced; exiting at ", - scalar localtime, "\n" - if ($verbose); - exit $laststatus; - } elsif ($rout =~ /^synm/) { - $first_synch = $synchronous_mode = 1; - print $stdout "-- background is now synchronous\n" - if ($verbose); - } elsif ($rout =~ /([\=\?\+])([^ ]+)/) { - $comm = $1; - $key =$2; - if ($comm eq '?') { - print P substr("${$key}$space_pad", 0, 1024); - } else { - sysread(STDIN, $value, 1024); - $value =~ s/\s+$//; - $interactive = ($comm eq '+') ? 0 : 1; - if ($key eq 'tquery') { - print $stdout - "*** custom query installed\n" - if ($interactive || $verbose); - print $stdout - "$value" if ($verbose); - @trackstrings = (); - # already URL encoded - push(@trackstrings, $value); - } else { - $$key = $value; - print $stdout - "*** changed: $key => $$key\n" - if ($interactive || $verbose); - - &generate_ansi if ($key eq 'ansi' || - $key =~ /^colour/); - $rate_limit_next = 0 - if ($key eq 'pause' && - $value eq 'auto'); - &tracktags_makearray - if ($key eq 'track'); - &filter_compile - if ($key eq 'filter'); - ¬ify_compile - if ($key eq 'notifies'); - &list_compile - if ($key eq 'lists'); - &filterflags_compile - if ($key eq 'filterflags'); - $filterrts_sub = - &filteruserlist_compile( - $filterrts_sub, $value) - if ($key eq 'filterrts'); - $filterusers_sub = - &filteruserlist_compile( - $filterusers_sub,$value) - if ($key eq 'filterusers'); - $filteratonly_sub = - &filteruserlist_compile( - $filteratonly_sub, - $value) - if ($key eq 'filteratonly'); - &filterats_compile - if ($key eq 'filterats'); - } - } - goto RESTART_SELECT; - } else { - $interactive = 1; - ($fetchwanted = 0+$1, $fetch_id = 0, $last_id = 0) - if ($rout =~ /^reset(\d+)/); - ($dmfetchwanted = 0+$1, $last_dm = 0) - if ($rout =~ /^dmreset(\d+)/); - if ($rout =~ /^smreset/) { # /dmsent - $dmfetchwanted = 0+$1 - if ($rout =~ /(\d+)/); - &dmrefresh(1, 1); - &send_repaint if ($termrl); - # we do not want to force a refresh. - goto DONT_REFRESH; - } - if ($rout =~ /^dm/) { - &dmrefresh($interactive); - &send_repaint if ($termrl); - $dmcount = $dmpause; - goto DONT_REFRESH; - } - } - } else { - if ($we_got_signal || $nfound == -1) { - # we need to restart the call. we might be waiting - # longer, but this is unavoidable. - goto RESTART_SELECT; - } - print $stdout -"-- routine refresh (effpause = $effpause, $dmcount to next dm) ", - scalar localtime, "\n" if ($verbose); - } -} - -#### internal implementation functions for the twitter API. DON'T ALTER #### - -# manage automatic rate limiting by checking our max. -#TODO -# autoslowdown as we run out of requests, then speed up when hour -# has passed. -sub update_effpause { - return ($effpause = undef) if ($script); # for select() - if ($pause ne 'auto' && $noratelimit) { - $effpause = (0+$pause) || undef; - return; - } - $effpause = (0+$pause) || undef - if ($anonymous || (!$pause && $pause ne 'auto')); - if (!$rate_limit_next && !$anonymous && ($pause > 0 || - $pause eq 'auto')) { - - # Twitter 1.0 used a simple remaining_hits and - # hourly_limit. 1.1 uses multiple rate endpoints. we - # are only interested in certain specific ones, though - # we currently fetch them all and we might use more later. - - $rate_limit_next = 5; - $rate_limit_ref = &grabjson($rlurl, 0, 0, 0, undef, 1); - - if (defined $rate_limit_ref && - ref($rate_limit_ref) eq 'HASH') { - - # of mentions_timeline, home_timeline and search/tweets, - # choose the MOST restrictive and normalize that. - - $rate_limit_left = &min( -0+$rate_limit_ref->{'resources'}->{'statuses'}->{'/statuses/home_timeline'}->{'remaining'}, - &min( -0+$rate_limit_ref->{'resources'}->{'statuses'}->{'/statuses/mentions_timeline'}->{'remaining'}, -0+$rate_limit_ref->{'resources'}->{'search'}->{'/search/tweets'}->{'remaining'})); - $rate_limit_rate = &min( -0+$rate_limit_ref->{'resources'}->{'statuses'}->{'/statuses/home_timeline'}->{'limit'}, - &min( -0+$rate_limit_ref->{'resources'}->{'statuses'}->{'/statuses/mentions_timeline'}->{'limit'}, -0+$rate_limit_ref->{'resources'}->{'search'}->{'/search/tweets'}->{'limit'})); - if ($rate_limit_left < 3 && $rate_limit_rate) { - $estring = -"*** warning: API rate limit imminent"; - if ($pause eq 'auto') { - $estring .= - "; temporarily halting autofetch"; - $effpause = 0; - } - &$exception(5, "$estring\n"); - } else { - if ($pause eq 'auto') { - -# the new rate limits do not require us to reduce our fetching for mentions, -# direct messages or search, because they pull from different buckets, and -# their rate limits are roughly the same. - $effpause = 5*$rate_limit_rate; - # this will usually be 75s -# for lists, however, we have to drain the list bucket faster, so for every -# list AFTER THE FIRST ONE we subscribe to, add rate_limit_rate to slow. -# for search, it has 180 requests, so we don't care so much. if this -# changes later, we will probably need something similar to this for -# cases where the search array is > 1. - $effpause += ((scalar(@listlist)-1)* - $rate_limit_rate) - if (scalar(@listlist) > 1); - - if (!$effpause) { - print $stdout -"-- rate limit rate failure: using 180 second fallback\n"; - $effpause = 180; - } - - # we don't go under sixty. - $effpause = 60 if ($effpause < 60); - } else { - $effpause = 0+$pause; - } - } - print $stdout -"-- rate limit check: $rate_limit_left/$rate_limit_rate (rate is $effpause sec)\n" - if ($verbose); - $adverb = (!$last_rate_limit) ? ' currently' : - ($last_rate_limit < $rate_limit_rate) ? ' INCREASED to': - ($last_rate_limit > $rate_limit_rate) ? ' REDUCED to': - ''; - $notify_rate = -"-- notification: API rate limit is${adverb} ${rate_limit_rate} req/15min\n" - if ($last_rate_limit != $rate_limit_rate); - $last_rate_limit = $rate_limit_rate; - } else { - $rate_limit_next = 0; - $effpause = ($pause eq 'auto') ? 180 : 0+$pause; - print $stdout -"-- failed to fetch rate limit (rate is $effpause sec)\n" - if ($verbose); - } - } else { - $rate_limit_next-- unless ($anonymous); - } -} - -# streaming API support routines - -### INITIALIZE STREAMING -### spin off a nurse process to proxy data from curl, and a buffer process -### to protect the background process from signals curl may generate. - -sub start_streaming { - $bufferpid = 0; - unless ($streamtest) { - if($bufferpid = open(STBUF, "-|")) { - # streaming processes initialized - return $bufferpid; - } - } - - # now within buffer process - # verbosity does not work here, so force both off. - $verbose = 0; - $superverbose = 0; - - $0 = "TTYtter (streaming buffer thread)"; - $in_buffer = 1; - # set up signal handlers - $streampid = 0; - &sigify(sub { - # in an earlier version we wrote a disconnect packet to the - # pipe in this handler. THIS IS NOT SAFE on certain OS/Perl - # combinations. I moved this down to the HELLOAGAINNURSE loop, - # or otherwise you get random seg faults. - $i = $streampid; - $streampid = 0; - waitpid $i, 0 if ($i); - }, qw(CHLD PIPE)); - &sigify(sub { - $i = $streampid; - $streampid = 0; # suppress handler above - kill ($SIGHUP, $i) if ($i); - waitpid $i, 0 if ($i); - kill 9, $curlpid if ($curlpid && !$i); - kill 9, $$; - }, qw(HUP TERM)); - &sigify("IGNORE", qw(INT)); - - $packets_read = 0; # part of exponential backoff - $wait_time = 0; - - # open the nurse process - HELLOAGAINNURSE: $w = "{\"packet\" : \"connect\", \"payload\" : {} }"; - select(STDOUT); $|++; - printf STDOUT ("%08x%s", length($w), $w); - close(NURSE); - if (!$packets_read) { $wait_time += (($wait_time) ? $wait_time : 1) } - else { $wait_time = 0; } - $packets_read = 0; - $wait_time = ($wait_time > 60) ? 60 : $wait_time; - if ($streampid = open(NURSE, "-|")) { - # within the buffer process - select(NURSE); $|++; select(STDOUT); - my $rin = ''; - vec($rin,fileno(NURSE),1) = 1; - my $datasize = 0; - my $buf = ''; - my $cuf = ''; - my $duf = ''; - - # read the curlpid from the stream - read(NURSE, $curlpax, 8); - $curlpid = hex($curlpax); - - # if we are testing the socket, just emit data. - if ($streamtest) { - my $c; - - for(;;) { - sysread(NURSE, $c, 1); - print STDOUT $c; - } - } - HELLONURSE: while(1) { - # restart nurse process if it/curl died - goto HELLOAGAINNURSE if(!$streampid); - - # read a line of text (hopefully numbers) - chomp($buf = <NURSE>); - # should be nothing but digits and whitespace. - # if anything else, we're getting garbage, and we - # should reconnect. - if ($buf =~ /[^0-9\r\l\n\s]+/s) { - close(NURSE); - kill 9, $streampid if ($streampid); - # and SIGCHLD will reap - kill 9, $curlpid if ($curlpid); - goto HELLOAGAINNURSE; - } - $datasize = 0+$buf; - next HELLONURSE if (!$datasize); - $datasize--; - read(NURSE, $duf, $datasize); - # don't send broken entries - next HELLONURSE if (length($duf) < $datasize); - # yank out all \r\n - 1 while $duf =~ s/[\r\n]//g; - $duf = "{ \"packet\" : \"data\", \"pid\" : \"$streampid\", \"curlpid\" : \"$curlpid\", \"payload\" : $duf }"; - printf STDOUT ("%08x%s", length($duf), $duf); - $packets_read++; - } - } else { - # within the nurse process - $0 = "TTYtter (waiting $wait_time sec to connect to stream)"; - sleep $wait_time; - $curlpid = 0; - $replarg = ($streamallreplies) ? '&replies=all' : ''; - &sigify(sub { - kill 9, $curlpid if ($curlpid); - waitpid $curlpid, 0 unless (!$curlpid); - $curlpid = 0; - kill 9, $$; - }, qw(CHLD PIPE)); - &sigify(sub { - kill 9, $curlpid if ($curlpid); - }, qw(INT HUP TERM)); # which will cascade into SIGCHLD - ($comm, $args, $data) = &$stringify_args($baseagent, - [ $streamurl, "delimited=length${replarg}" ], - undef, undef, - '-s', - '-A', "TTYtter_Streaming/$TTYtter_VERSION", - '-N', - '-H', 'Expect:'); - ($curlpid = open(K, "|$comm")) || die("failed curl: $!\n"); - printf STDOUT ("%08x", $curlpid); - - # "DIE QUICKLY" - $0 = "TTYtter (streaming socket nurse thread to ${curlpid})"; - - select(K); $|++; select(STDOUT); $|++; - print K "$args\n"; - close(K); - waitpid $curlpid, 0; - $curlpid = 0; - kill 9, $$; - } -} - -# handle a set of events acquired from the streaming socket. -# ordinarily only the background is calling this. -sub streamevents { - my (@events) = (@_); - my $w; - my @x; - my %k; # need temporary dedupe - - foreach $w (@events) { - my $tmp; - - # don't send non-data events (yet). - next if ($w->{'packet'} ne 'data'); - - # try to get PID information if available for faster shutdown - $nnursepid = 0+($w->{'pid'}); - if ($nnursepid != $nursepid) { - $nursepid = $nnursepid; - print $stdout -"-- got new pid of streaming nurse socket process: $nursepid\n" - if ($verbose); - } - $ncurlpid = 0+($w->{'curlpid'}); - if ($ncurlpid != $curlpid) { - $curlpid = $ncurlpid; - print $stdout -"-- got new pid of streaming curl process: $ncurlpid\n" - if ($verbose); - } - - # we don't use this (yet). - next if ($w->{'payload'}->{'friends'}); - - sleep 5 while ($suspend_output > 0); - - # dispatch tweets - if ($w->{'payload'}->{'text'} && !$notimeline) { - # normalize the tweet first. - my $payload = &normalizejson($w->{'payload'}); - my $sid = $payload->{'id_str'}; - - $payload->{'tag'}->{'type'} = 'timeline'; - $payload->{'tag'}->{'payload'} = 'stream'; - - # filter replies from streaming socket if the - # user requested it. use $tweettype to determine - # this so the user can interpose custom logic. - if ($nostreamreplies) { - my $sn = &descape( - $payload->{'user'}->{'screen_name'}); - my $text = &descape($payload->{'text'}); - next if (&$tweettype($payload, $sn, $text) eq - 'reply'); - } - - # finally, filter everything else and dedupe. - unless (length($id_cache{$sid}) || - $filter_next{$sid} || - $k{$sid}) { - &tdisplay([ $payload ]); - $k{$sid}++; - } - - # roll *_id so that we don't do unnecessary work - # testing the API. don't roll fetch_id, search uses - # it. don't roll if last_id was zero, because that - # means we are streaming *before* the API backfetch. - $last_id = $sid unless (!$last_id); - } - - # dispatch DMs - elsif (($tmp = $w->{'payload'}->{'direct_message'}) && - $dmpause) { - &dmrefresh(0, 0, [ $tmp ]); - # don't roll last_dm yet. - } - - # must be an event. see if standardevent can make sense of it. - elsif (!$notimeline) { - $w = $w->{'payload'}; - my $sou_sn = - &descape($w->{'source'}->{'screen_name'}); - if (!length($sou_sn) || !$filterusers_sub || - !&$filterusers_sub($sou_sn)) { - &send_removereadline if ($termrl); - &$eventhandle($w); - $wrapseq = 1; - &send_repaint if ($termrl); - } - } - } -} - -# REST API support -# -# thump for timeline -# THIS MUST ONLY BE RUN BY THE BACKGROUND. -sub refresh { - my $interactive = shift; - my $relative_last_id = shift; - my $k; - my $my_json_ref = undef; - my $i; - my @streams = (); - my $dont_roll_back_too_far = 0; - - # this mixes all the tweet streams (timeline, hashtags, replies - # and lists) into a single unified data river. - # backload can be zero, but this will still work since &grabjson - # sees a count of zero as "default." - - # first, get my own timeline - # note that anonymous has no timeline (but they can sample the - # stream) - unless ($notimeline || $anonymous) { - # in streaming mode, use $last_id - # in API mode, use $fetch_id - my $base_json_ref = &grabjson($url, - ($dostream) ? $last_id : $fetch_id, - 0, - (($last_id) ? 250 : $fetchwanted || $backload), { - "type" => "timeline", - "payload" => "api" - }, 1); - # if I can't get my own timeline, ABORT! highest priority! - return if (!defined($base_json_ref) || - ref($base_json_ref) ne 'ARRAY'); - - # we have to filter against the ID cache right now, because - # we might not have any other streams! - if ($fetch_id && $last_id) { - $my_json_ref = []; - my $l; - my %k; # need temporary dedupe - foreach $l (@{ $base_json_ref }) { - unless (length($id_cache{$l->{'id_str'}}) || - $filter_next{$l->{'id_str'}} || - $k{$l->{'id_str'}}) { - push(@{ $my_json_ref }, $l); - $k{$l->{'id_str'}}++; - } - } - } else { - $my_json_ref = $base_json_ref; - } - } - - # add stream for replies, if requested - if ($mentions) { - # same thing - my $r = &grabjson($rurl, - ($dostream && !$nostreamreplies) ? $last_id : $fetch_id, - 0, - (($last_id) ? 250 - : $fetchwanted || $backload), { - "type" => "reply", - "payload" => "" - }, 1); - push(@streams, $r) - if (defined($r) && - ref($r) eq 'ARRAY' && - scalar(@{ $r })); - } - - # next handle hashtags and tracktags - # failure here does not abort, because search may be down independently - # of the main timeline. - if (!$notrack && scalar(@trackstrings)) { - my $r; - my $k; - my $l; - - if (!$last_id) { - $l = &min($backload, $searchhits); - } else { - $l = (($fetchwanted) ? $fetchwanted : - &max(100, $searchhits)); - } - # temporarily squelch server complaints (see below) - $muffle_server_messages = 1 unless ($verbose); - foreach $k (@trackstrings) { - # use fetch_id here in both modes. - $r = &grabjson("$queryurl?${k}&result_type=recent", - $fetch_id, 0, $l, { - "type" => "search", - "payload" => $k - }, 1); - # depending on the state of the search API, we might be using - # a bogus search ID that is too far back. so if this fails, - # try again with last_id, but not if we're streaming (it - # will always fetch zero). - if (!defined($r) || ref($r) ne 'ARRAY' || !$dostream) { - print $stdout "-- search retry $k attempted with last_id\n" - if ($verbose); - $r = &grabjson("$queryurl?${k}&result_type=recent", - $last_id, 0, $l, { - "type" => "search", - "payload" => $k - }, 1); - $dont_roll_back_too_far = 1; - } - # or maybe not even then? - if (!defined($r) || ref($r) ne 'ARRAY') { - print $stdout "-- search retry $k attempted with zero!\n" - if ($verbose); - $r = &grabjson("$queryurl?${k}&result_type=recent", - 0, 0, $l, { - "type" => "search", - "payload" => $k - }, 1); - $dont_roll_back_too_far = 1; - } - push(@streams, $r) - if (defined($r) && - ref($r) eq 'ARRAY' && - scalar(@{ $r })); - } - $muffle_server_messages = 0; - } - - # add stream for lists we have on with /set lists, and tag it with - # the list. - if (scalar(@listlist)) { - foreach $k (@listlist) { - # always use fetch_id - my $r = &grabjson( - "${statusliurl}?owner_screen_name=".$k->[0].'&slug='.$k->[1], - $fetch_id, 0, - (($last_id) ? 250 : $fetchwanted), { - "type" => "list", - "payload" => ($k->[0] ne $whoami) ? - "$k->[0]/$k->[1]" : - "$k->[1]" - }, 1); - push(@streams, $r) - if (defined($r) && ref($r) eq 'ARRAY' && - scalar(@{ $r })); - } - } - - $fetchwanted = 0; # done with that. - # now, streamix all the streams into my_json_ref, discarding duplicates - # a simple hash lookup is no good; it has to be iterative. because of - # that, we might as well just splice it in here and save a sort later. - # the streammix logic is unnecessarily complex, probably. - # remember, the most recent tweets are FIRST. - if (scalar(@streams)) { - my $j; - my $k; - my $l = scalar(@{ $my_json_ref }); - my $m; - my $n; - - foreach $n (@streams) { - SMIX0: foreach $j (@{ $n }) { - my $id = $j->{'id_str'}; # for ease of use - # possible to happen if search tryhard is on - next SMIX0 if ($id < $fetch_id); - - # filter this lot against the id cache - # and any tweets we just filtered. - next SMIX0 if (length($id_cache{$id}) && - $fetch_id); - next SMIX0 if ($filter_next{$id} && - $fetch_id); - - if (!$l) { # degenerate case - push (@{ $my_json_ref }, $j); - $l++; - next SMIX0; - } - - # find the same ID, or one just before, - # and splice in - $m = -1; - SMIX1: for($i=0; $i<$l; $i++) { - next SMIX0 # it's a duplicate - if($my_json_ref->[$i]->{'id_str'} == $id); - if($my_json_ref->[$i]->{'id_str'} < $id) { - $m = $i; - last SMIX1; # got it - } - } - if ($m == -1) { # didn't find - push (@{ $my_json_ref }, $j); - } elsif ($m == 0) { # degenerate case - unshift (@{ $my_json_ref }, $j); - } else { # did find, so splice - splice(@{ $my_json_ref }, $m, 0, - $j); - } - $l++; - } - } - } - %filter_next = (); - - # fetch_id gyration. initially start with last_id, then roll. we - # want to keep a window, though, so we try to pick a sensible value - # that doesn't fetch too much but includes some overlap. we can't - # do computations on the ID itself, because it's "opaque." - $fetch_id = 0 if ($last_id == 0); - &send_removereadline if ($termrl); - if ($dont_refresh_first_time) { - $last_id = &max($my_json_ref->[0]->{'id_str'}, $last_id); - } else { - ($last_id, $crap) = - &tdisplay($my_json_ref, undef, $relative_last_id); - } - my $new_fi = (scalar(@{ $my_json_ref })) ? - $my_json_ref->[(scalar(@{ $my_json_ref })-1)]->{'id_str'} : - ''; - # try to widen the window to a "reasonable amount" - $fetch_id = ($fetch_id == 0) ? $last_id : - (length($new_fi) && $new_fi ne $last_id - && $new_fi > $fetch_id) ? $new_fi : - ($relative_last_id > 0 && $relative_last_id ne $last_id && - $relative_last_id > $fetch_id) ? - $relative_last_id : $fetch_id; - - print $stdout -"-- last_id $last_id, fetch_id $fetch_id, rollback $relative_last_id\n". -"-- (@{[ scalar(keys %id_cache) ]} cached)\n" - if ($verbose); - &send_removereadline if ($termrl); - &$conclude; - $wrapseq = 1; - &send_repaint if ($termrl); -} - -# convenience function for filters (see below) -sub killtw { my $j = shift; $filtered++; $filter_next{$j->{'id_str'}}++ - if ($is_background); } - -# handle (i.e., display) an array of tweets in standard format -sub tdisplay { # used by both synchronous /again and asynchronous refreshes - my $my_json_ref = shift; - my $class = shift; - my $relative_last_id = shift; - my $mini_id = shift; - my $printed = 0; - my $disp_max = &min($print_max, scalar(@{ $my_json_ref })); - my $save_counter = -1; - my $i; - my $j; - - if ($disp_max) { # null list may be valid if we get code 304 - unless ($is_background) { # reset store hash each console - if ($mini_id) { -#TODO -# generalize this at some point instead of hardcoded menu codes -# maybe an ma0-mz9? - $save_counter = $tweet_counter; - $tweet_counter = $mini_split; - for(0..9) { - undef $store_hash{"zz$_"}; - } - }# else { - # $tweet_counter = $back_split; - # %store_hash = (); - #} - } - for($i = $disp_max; $i > 0; $i--) { - my $g = ($i-1); - $j = $my_json_ref->[$g]; - my $id = $j->{'id_str'}; - my $sn = $j->{'user'}->{'screen_name'}; - next if (!length($sn)); - $sn = lc(&descape($sn)); - - # - # implement filter stages: - # do so in such a way that we can toss tweets out - # quickly, because multiple layers eat CPU! - # - - # zeroth: if this is us, do not filter. - if (($anonymous || $sn ne $whoami) && !($nofilter)) { - - # first, filterusers. this is very fast. - # do for the tweet - (&killtw($j), next) if - ($filterusers_sub && - &$filterusers_sub($sn)); - # and if the tweet has a retweeted status, do for - # that. - (&killtw($j), next) if - ($j->{'retweeted_status'} && - $filterusers_sub && - &$filterusers_sub(lc(&descape($j-> - {'retweeted_status'}-> - {'user'}->{'screen_name'})))); - - # second, filterrts. this is almost as fast. - (&killtw($j), next) if - ($filterrts_sub && - length($j->{'retweeted_status'}->{'id_str'})&& - &$filterrts_sub($sn)); - - # third, filteratonly. this has a fast case and a - # slow case. - my $tex = &descape($j->{'text'}); - (&killtw($j), next) if - ($filteratonly_sub && - &$filteratonly_sub($sn) && # fast test - $tex !~ /\@$whoami\b/i); # slow test - - # fourth, filterats. this is somewhat expensive. - (&killtw($j), next) if ($filterats_c && - &$filterats_c($tex)); - - # finally, classic -filter. this is the most expensive. - (&killtw($j), next) if ($filter_c && &$filter_c($tex)); - } - - # damn it, user may actually want this tweet. - # assign menu codes and place into caches - $key = (($is_background) ? '' : 'z' ). - substr($alphabet, $tweet_counter/10, 1) . - $tweet_counter % 10; - $tweet_counter = - ($tweet_counter == 259) ? $mini_split : - ($tweet_counter == ($mini_split - 1)) - ? 0 : ($tweet_counter+1); - $j->{'menu_select'} = $key; - $key = lc($key); - - # recover ID cache memory: find the old ID with this - # menu code and remove it, then add the new one - # except if this is the foreground. we don't use this - # in the foreground. - if ($is_background) { - delete $id_cache{$store_hash{$key}->{'id_str'}}; - $id_cache{$id} = $key; - } - - # finally store in menu code cache - $store_hash{$key} = $j; - - sleep 5 while ($suspend_output > 0); - &send_removereadline if ($termrl); - $wrapseq++; - - $printed += scalar(&$handle($j, - ($class || (($id <= $relative_last_id) ? 'again' : - undef)))); - } - } - $tweet_counter = $save_counter if ($save_counter > -1); - sleep 5 while ($suspend_output > 0); - &$exception(6,"*** warning: more tweets than menu codes; truncated\n") - if (scalar(@{ $my_json_ref }) > $print_max); - if (($interactive || $verbose) && !$printed) { - &send_removereadline if ($termrl); - print $stdout "-- sorry, nothing to display.\n"; - $wrapseq = 1; - } - return (&max($my_json_ref->[0]->{'id_str'}, $last_id), $j); -} - -sub dt_tdisplay { - my $my_json_ref = shift; - my $class = shift; - if (defined($my_json_ref) - && ref($my_json_ref) eq 'ARRAY' - && scalar(@{ $my_json_ref })) { - my ($crap, $art) = &tdisplay($my_json_ref, $class); - unless ($timestamp) { - my ($time, $ts1) = &$wraptime( -$my_json_ref->[(&min($print_max,scalar(@{ $my_json_ref }))-1)]->{'created_at'}); - my ($time, $ts2) = &$wraptime($art->{'created_at'}); - print $stdout &wwrap( - "-- update covers $ts1 thru $ts2\n"); - } - &$conclude; - } -} - -# thump for DMs -sub dmrefresh { - my $interactive = shift; - my $sent_dm = shift; - # for streaming API to inject DMs it receives - my $my_json_ref = shift; - - if ($anonymous) { - print $stdout - "-- sorry, you can't read DMs if you're anonymous.\n" - if ($interactive); - return; - } - - # no point in doing this if we can't even get to our own timeline - # (unless user specifically requested it, or our timeline is off) - return if (!$interactive && !$last_id && !$notimeline); # NOT last_dm - - $my_json_ref = &grabjson((($sent_dm) ? $dmsenturl : $dmurl), - (($sent_dm) ? 0 : $last_dm), 0, $dmfetchwanted, undef, 1) - if (!defined($my_json_ref) || - ref($my_json_ref) ne 'ARRAY'); - return if (!defined($my_json_ref) - || ref($my_json_ref) ne 'ARRAY'); - - my $orig_last_dm = $last_dm; - $last_dm = 0 if ($sent_dm); - - $dmfetchwanted = 0; - my $printed = 0; - my $max = 0; - my $disp_max = &min($print_max, scalar(@{ $my_json_ref })); - my $i; - my $g; - my $key; - - if ($disp_max) { # an empty list can be valid - if ($dm_first_time) { - sleep 5 while ($suspend_output > 0); - &send_removereadline if ($termrl); - print $stdout - "-- checking for most recent direct messages:\n"; - $disp_max = 2; - $interactive = 1; - } - for($i = $disp_max; $i > 0; $i--) { - $g = ($i-1); - my $j = $my_json_ref->[$g]; - next if (!$sent_dm && $j->{'id_str'} <= $last_dm); - next if (!length($j->{'sender'}->{'screen_name'}) || - !length($j->{'recipient'}->{'screen_name'})); - - $key = substr($alphabet, $dm_counter/10, 1) . - $dm_counter % 10; - $dm_counter = - ($dm_counter == 259) ? 0 : - ($dm_counter+1); - $j->{'menu_select'} = $key; - $dm_store_hash{lc($key)} = $j; - - sleep 5 while ($suspend_output > 0); - &send_removereadline if ($termrl); - $wrapseq++; - - $printed += scalar(&$dmhandle($j)); - } - $max = $my_json_ref->[0]->{'id_str'}; - } - sleep 5 while ($suspend_output > 0); - if (($interactive || $verbose) && !$printed && !$dm_first_time) { - &send_removereadline if ($termrl); - print $stdout (($sent_dm) - ? "-- you haven't sent anything yet.\n" - : "-- sorry, no new direct messages.\n"); - $wrapseq = 1; - } - $last_dm = ($sent_dm) ? $orig_last_dm - : &max($last_dm, $max); - $dm_first_time = 0 if ($last_dm || !scalar(@{ $my_json_ref })); - print $stdout "-- dm bookmark is $last_dm.\n" if ($verbose); - &$dmconclude; - &send_repaint if ($termrl); -} - -# post an update -# this is a general API function that handles status updates and sending DMs. -sub updatest { - my $string = shift; - my $interactive = shift; - my $in_reply_to = shift; - my $user_name_dm = shift; - my $rt_id = shift; # even if this is set, string should also be set. - my $urle = ''; - my $i; - my $subpid; - my $istring; - - my $verb = (length($user_name_dm)) ? "DM $user_name_dm" : - ($rt_id) ? 'RE-tweet' : - 'tweet'; - - if ($anonymous) { - print $stdout - "-- sorry, you can't $verb if you're anonymous.\n" - if ($interactive); - return 99; - } - - # "the pastebrake" - if (!$slowpost && !$verify && !$script) { - if ((time() - $postbreak_time) < 5) { - $postbreak_count++; - if ($postbreak_count == 3) { - print $stdout - "-- you're posting pretty fast. did you mean to do that?\n". - "-- waiting three seconds before taking the next set of tweets\n". - "-- hit CTRL-C NOW! to kill TTYtter if you accidentally pasted in this window\n"; - sleep 3; - $postbreak_count = 0; - } - } else { - $postbreak_count = 0; - } - $postbreak_time = time(); - } - - my $payload = (length($user_name_dm)) ? 'text' : 'status'; - $string = &$prepost($string) unless ($user_name_dm || $rt_id); - - # YES, you *can* verify and slowpost. I thought about this and I - # think I want to allow it. - if ($verify && !$status) { - my $answer; - - print $stdout - &wwrap("-- verify you want to $verb: \"$string\"\n"); - $answer = lc(&linein( - "-- send to server? (only y or Y is affirmative):")); - if ($answer ne 'y') { - print $stdout "-- ok, NOT sent to server.\n"; - return 97; - } - } - - unless ($rt_id) { - $urle = ''; - foreach $i (unpack("${pack_magic}C*", $string)) { - my $k = chr($i); - if ($k =~ /[-._~a-zA-Z0-9]/) { - $urle .= $k; - } else { - $k = sprintf("%02X", $i); - $urle .= "%$k"; - } - } - } - - $user_name_dm = (length($user_name_dm)) ? - "&user=$user_name_dm" : ''; - - my $i = ''; - $i .= "source=TTYtter&" if ($authtype eq 'basic'); - $i .= "in_reply_to_status_id=${in_reply_to}&" if ($in_reply_to > 0); - if (!$rt_id && defined $lat && defined $long && $location) { - print $stdout "-- using lat/long: ($lat, $long)\n"; - $i .= "lat=${lat}&long=${long}&"; - } elsif ((defined $lat || defined $long) && $location && !$rt_id) { - print $stdout - "-- warning: incomplete location ($lat, $long) ignored\n"; - } - $i .= "${payload}=${urle}${user_name_dm}" unless ($rt_id); - $i .= "id=$rt_id" if ($rt_id); - $slowpost += 0; if ($slowpost && !$script && !$status && !$silent) { - if($pid = open(SLOWPOST, '-|')) { - # pause background so that it doesn't kill itself - # when this signal occurs. - kill $SIGUSR1, $child; - print $stdout &wwrap( - "-- waiting $slowpost seconds to $verb, ^C cancels: \"$string\"\n"); - close(SLOWPOST); # this should wait for us - if ($? > 256) { - print $stdout - "\n-- not sent, cancelled by user\n"; - return 97; - } - print $stdout "-- sending to server\n"; - kill $SIGUSR2, $child; - &send_removereadline if ($termrl && $dostream); - } else { - $in_backticks = 1; # defeat END sub - &sigify(sub { exit 254; }, qw(BREAK INT TERM PIPE)); - sleep $slowpost; - exit 0; - } - } - my $return = &backticks($baseagent, '/dev/null', undef, - (length($user_name_dm)) ? $dmupdate : - ($rt_id) ? "$rturl/${rt_id}.json" : - $update, $i, 0, @wend); - print $stdout "-- return --\n$return\n-- return --\n" - if ($superverbose); - if ($? > 0) { - $x = $? >> 8; - print $stdout <<"EOF" if ($interactive); -${MAGENTA}*** warning: connect timeout or no confirmation received ($x) -*** to attempt a resend, type %%${OFF} -EOF - return $?; - } - my $ec; - if ($ec = &is_json_error($return)) { - print $stdout <<"EOF" if ($interactive); -${MAGENTA}*** warning: server error message received -*** "$ec"${OFF} -EOF - return 98; - } - if ($ec = &is_fail_whale($return) || - $return =~ /^\[?\]?<!DOCTYPE\s+html/i || - $return =~ /^(Status:\s*)?50[0-9]\s/ || - $return =~ /^<html>/i || - $return =~ /^<\??xml\s+/) { - print $stdout <<"EOF" if ($interactive); -${MAGENTA}*** warning: Twitter Fail Whale${OFF} -EOF - return 98; - } - $lastpostid = &parsejson($return)->{'id_str'}; - unless ($user_name_dm || $rt_id) { - $lasttwit = $string; - &$postpost($string); - } - return 0; -} - -# this dispatch routine replaces the common logic of deletest, deletedm, -# follow, leave and the favourites system. -# this is a modified, abridged version of &updatest. -sub central_cd_dispatch { - my ($payload, $interactive, $update) = (@_); - my $return = &backticks($baseagent, '/dev/null', undef, - $update, $payload, 0, @wend); - print $stdout "-- return --\n$return\n-- return --\n" - if ($superverbose); - if ($? > 0) { - $x = $? >> 8; - print $stdout <<"EOF" if ($interactive); -${MAGENTA}*** warning: connect timeout or no confirmation received ($x) -*** to attempt again, type %%${OFF} -EOF - return ($?, ''); - } - my $ec; - if ($ec = &is_json_error($return)) { - print $stdout <<"EOF" if ($interactive); -${MAGENTA}*** warning: server error message received -*** "$ec"${OFF} -EOF - return (98, $return); - } - return (0, $return); -} - -# the following functions may be user-exposed in a future version of -# TTYtter, but are officially still "private interfaces." -# delete a status -sub deletest { - my $id = shift; - my $interactive = shift; - my $url = $delurl; - - $url =~ s/%I/$id/; - my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $url); - print $stdout "-- tweet id #${id} has been removed\n" - if ($interactive && !$en); - print $stdout "*** (was the tweet already deleted?)\n" - if ($interactive && $en); - return 0; -} - -# delete a DM -sub deletedm { - my $id = shift; - my $interactive = shift; - - my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $dmdelurl); - print $stdout "-- DM id #${id} has been removed\n" - if ($interactive && !$en); - print $stdout "*** (was the DM already deleted?)\n" - if ($interactive && $en); - return 0; -} - -# create or destroy a favourite -sub cordfav { - my $id = shift; - my $interactive = shift; - my $basefav = shift; - my $text = shift; - my $verb = shift; - - my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $basefav); - print $stdout "-- favourite $verb for tweet id #${id}: \"$text\"\n" - if ($interactive && !$en); - print $stdout "*** (was the favourite already ${verb}?)\n" - if ($interactive && $en); - return 0; -} - -# follow or unfollow a user -sub foruuser { - my $uname = shift; - my $interactive = shift; - my $basef = shift; - my $verb = shift; - - my ($en, $em) = ¢ral_cd_dispatch("screen_name=$uname", - $interactive, $basef); - print $stdout "-- ok, you have $verb following user $uname.\n" - if ($interactive && !$en); - return 0; -} - -# block or unblock a user -sub boruuser { - my $uname = shift; - my $interactive = shift; - my $basef = shift; - my $verb = shift; - - my ($en, $em) = ¢ral_cd_dispatch("screen_name=$uname", - $interactive, $basef); - print $stdout "-- ok, you have $verb blocking user $uname.\n" - if ($interactive && !$en); - return 0; -} - -# enable or disable retweets for a user -sub rtsonoffuser { - my $uname = shift; - my $interactive = shift; - my $selection = shift; - my $verb = ($selection) ? 'enabled' : 'disabled'; - my $tval = ($selection) ? 'true' : 'false'; - - my ($en, $em) = ¢ral_cd_dispatch( - "retweets=${tval}&screen_name=${uname}", - $interactive, $frupdurl); - print $stdout "-- ok, you have ${verb} retweets for user $uname.\n" - if ($interactive && !$en); - return 0; -} - -#### TTYtter internal API utility functions #### -# ... which your API *can* call - -# gets and returns the contents of a URL (optionally pass a POST body) -sub graburl { - my $resource = shift; - my $data = shift; - - return &backticks($baseagent, - '/dev/null', undef, $resource, $data, - 1, @wind); -} - -# format a tweet based on user options -sub standardtweet { - my $ref = shift; - my $nocolour = shift; - - my $sn = &descape($ref->{'user'}->{'screen_name'}); - my $tweet = &descape($ref->{'text'}); - my $colour; - my $g; - my $h; - - # wordwrap really ruins our day here, thanks a lot, @augmentedfourth - # have to insinuate the ansi sequences after the string is wordwrapped - - $g = $colour = ${'CC' . scalar(&$tweettype($ref, $sn, $tweet)) } - unless ($nocolour); - $colour = $OFF . $colour - unless ($nocolour); - - # prepend screen name "badges" - $sn = "\@$sn" if ($ref->{'in_reply_to_status_id_str'} > 0); - $sn = "+$sn" if ($ref->{'user'}->{'geo_enabled'} eq 'true' && - (($ref->{'geo'}->{'coordinates'}->[0] ne 'undef' && - length($ref->{'geo'}->{'coordinates'}->[0]) && - $ref->{'geo'}->{'coordinates'}->[1] ne 'undef' && - length($ref->{'geo'}->{'coordinates'}->[0])) || - length($ref->{'place'}->{'id'}))); - $sn = "%$sn" if (length($ref->{'retweeted_status'}->{'id_str'})); - $sn = "*$sn" if ($ref->{'source'} =~ /TTYtter/ && $ttytteristas); - # prepend list information, if this tweet originated from a list - $sn = "($ref->{'tag'}->{'payload'})$sn" - if (length($ref->{'tag'}->{'payload'}) && - $ref->{'tag'}->{'type'} eq 'list'); - $tweet = "<$sn> $tweet"; - # twitter doesn't always do this right. - $h = $ref->{'retweet_count'}; $h += 0; #$h = "${h}+" if ($h >= 100); - # twitter doesn't always handle single retweets right. good f'n grief. - $tweet = "(x${h}) $tweet" if ($h > 1 && !$nonewrts); - # br3nda's modified timestamp patch - if ($timestamp) { - my ($time, $ts) = &$wraptime($ref->{'created_at'}); - $tweet = "[$ts] $tweet"; - } - - # pull it all together - $tweet = &wwrap($tweet, ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0) - if ($wrap); # remember to account for prompt length on #1 - $tweet =~ s/^([^<]*)<([^>]+)>/${g}\1<${EM}\2${colour}>/ - unless ($nocolour); - $tweet =~ s/\n*$//; - $tweet .= ($nocolour) ? "\n" : "$OFF\n"; - - # highlight anything that we have in track - if(scalar(@tracktags)) { # I'm paranoid - foreach $h (@tracktags) { - $h =~ s/^"//; $h =~ s/"$//; # just in case -$tweet =~ s/(^|[^a-zA-Z0-9])($h)([^a-zA-Z0-9]|$)/\1${EM}\2${colour}\3/ig - unless ($nocolour); - } - } - - # smb's underline/bold patch goes on last (modified for lists) - unless ($nocolour) { - # only do this after the < > portion. - my $k = index($tweet, ">"); - my $botsub = substr($tweet, $k); - my $topsub = substr($tweet, 0, $k); - $botsub =~ -s/(^|[^a-zA-Z0-9_])\@([a-zA-Z0-9_\/]+)/\1\@${UNDER}\2${colour}/g; - $tweet = $topsub . $botsub; - } - - return $tweet; -} - -# format a DM based on standard user options -sub standarddm { - my $ref = shift; - my $nocolour = shift; - - my ($time, $ts) = &$wraptime($ref->{'created_at'}); - my $text = &descape($ref->{'text'}); - my $sns = &descape($ref->{'sender'}->{'screen_name'}); - if ($sns eq $whoami) { - $sns = "->" . &descape($ref->{'recipient'}->{'screen_name'}); - } - my $g = &wwrap("[DM d$ref->{'menu_select'}]". - "[$sns/$ts] $text", ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0); - - $g =~ s/^\[DM ([^\/]+)\//${CCdm}[DM ${EM}\1${OFF}${CCdm}\// - unless ($nocolour); - $g =~ s/\n*$//; - $g .= ($nocolour) ? "\n" : "$OFF\n"; - $g =~ s/(^|[^a-zA-Z0-9_])\@(\w+)/\1\@${UNDER}\2${OFF}${CCdm}/g - unless ($nocolour); - return $g; -} - -# format an event record based on standard user options (mostly for -# streaming API, perhaps REST API one day) -sub standardevent { - my $ref = shift; - my $nocolour = shift; - - my $g = '>>> '; - my $verb = &descape($ref->{'event'}); - - # https://dev.twitter.com/docs/streaming-apis/messages - - if (length($verb)) { # see below for server-level events - my $tar_sn = '@'.&descape($ref->{'target'}->{'screen_name'}); - my $sou_sn = '@'.&descape($ref->{'source'}->{'screen_name'}); - - my $tar_list_name = ''; - my $tar_list_desc = ''; - - # For all verbs starting with "list", get name and desc - if ($verb =~ m/^list/ ) { - $tar_list_name = &descape($ref->{'target_object'}->{'full_name'}); - $tar_list_desc = &descape($ref->{'target_object'}->{'description'}); - } - - if ($verb eq 'favorite' || $verb eq 'unfavorite') { - my $rto = &destroy_all_tco($ref->{'target_object'}); - my $txt = &descape($rto->{'text'}); - $g .= - "$sou_sn just ${verb}d ${tar_sn}'s tweet: \"$txt\""; - } elsif ($verb eq 'follow') { - $g .= "$sou_sn is now following $tar_sn"; - } elsif ($verb eq 'user_update') { - $g .= "$sou_sn updated their profile (/whois $sou_sn to see)"; - } elsif ($verb eq 'list_member_added') { - $g .= "$sou_sn added $tar_sn to the list \"$tar_list_desc\" ($tar_list_name)"; - } elsif ($verb eq 'list_member_removed') { - $g .= "$sou_sn removed $tar_sn from the list \"$tar_list_desc\" ($tar_list_name)"; - } elsif ($verb eq 'list_user_subscribed') { - $g .= "$sou_sn is now following the list \"$tar_list_desc\" ($tar_list_name) from $tar_sn"; - } elsif ($verb eq 'list_user_unsubscribed') { - $g .= "$sou_sn is no longer following the list \"$tar_list_desc\" ($tar_list_name) from $tar_sn"; - } elsif ($verb eq 'list_created') { - $g .= "$sou_sn created the new list \"$tar_list_desc\" ($tar_list_name)"; - } elsif ($verb eq 'list_destroyed') { - $g .= "$sou_sn destroyed the list \"$tar_list_desc\" ($tar_list_name)"; - } elsif ($verb eq 'list_updated') { - $g .= "$sou_sn updated the list \"$tar_list_desc\" ($tar_list_name)"; - } elsif ($verb eq 'block' || $verb eq 'unblock') { - $g .= "$sou_sn ${verb}ed $tar_sn ($tar_sn is not ". - "notified)"; - } elsif ($verb eq 'access_revoked') { - $g .= "$sou_sn revoked oAuth access to $tar_sn"; - } elsif ($verb eq 'access_unrevoked') { - $g .= "$sou_sn restored oAuth access to $tar_sn"; - } else { - # try to handle new types of events we don't - # recognize yet. - $verb .= ($verb =~ /e$/) ? 'd' : 'ed'; - $g .= "$sou_sn $verb $tar_sn (basic)"; - } - - # server events ("public stream messages") are handled differently. - # we support almost all except for the ones that are irrelevant to - # this medium. - - } elsif ($ref->{'delete'}) { - # this is the best we can do -- it's already on the screen! - # we don't want to make it easy which tweet it is, since that - # would be embarrassing, so just say a delete occurred. - $g .= - "tweet ID# ".$ref->{'delete'}->{'status'}->{'id_str'}. - " deleted by server"; - } elsif ($ref->{'status_withheld'}) { - # Twitter doesn't document id_str as available here. check. - if (!length($ref->{'status_withheld'}->{'id_str'})) { - # do nothing right now - } else { $g .= - "tweet ID# ".$ref->{'status_withheld'}->{'id_str'}. - " censored by server in your country"; - } - } elsif ($ref->{'user_withheld'}) { - $g .= - "user ID# ".$ref->{'user_withheld'}->{'user_id'}. - " censored by server in your country"; - } elsif ($ref->{'disconnect'}) { - $g .= - "DISCONNECTED BY SERVER (".$ref->{'disconnect'}->{'code'}. - "); will retry: ".$ref->{'disconnect'}->{'reason'}; - } else { - # we have no idea what this is. just BS our way out. - $g .= "unknown server event received (non-fatal)"; - } - - if ($timestamp) { - my ($time, $ts) = &$wraptime($ref->{'created_at'}); - $g = "[$ts] $g"; - } - - $g = &wwrap("$g\n", ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0); - # highlight screen names - $g =~ -s/(^|[^a-zA-Z0-9_])\@([a-zA-Z0-9_\-\/]+)/\1\@${UNDER}\2${OFF}/g - unless ($nocolour); - - return $g; -} - -# for future expansion: this is the declared API callable method -# for executing a command as if the console had typed it. -sub ucommand { - die("** can't call &ucommand during multi-module loading.\n") - if ($multi_module_mode == -1); - &prinput(@_); -} - -# your application can also call &grabjson to get a hashref -# corresponding to parsed JSON from an arbitrary resource. -# see that function later on. - - -#### DEFAULT TTYtter INTERNAL API METHODS #### -# don't change these here. instead, use -exts=yourlibrary.pl and set there. -# note that these are all anonymous subroutine references. -# anything you don't define is overwritten by the defaults. -# it's better'n'superclasses. -# NOTE: defaultaddaction, defaultmain and defaultprompt -# are all defined in the "console" section above for -# clarity. - -# this first set are the multi-module aware ones. - -# the standard iterator for multi-module methods -sub multi_module_dispatch { - my $default = shift; - my $dispatch_chain = shift; - my $rv_handler = shift; - my @args = @_; - - local $dispatch_ref; # on purpose; get_key/set_key may need it - # $*_call_default is a global - $did_call_default = 0; - $this_call_default = 0; - $multi_module_context = 0; - - if ($rv_handler == 0) { - $rv_handler = sub { - return 0; - }; - } - - # fall through to default if no dispatch chain - if (!scalar(@{ $dispatch_chain })) { - return &$default(@args); - } - foreach $dispatch_ref (@{ $dispatch_chain }) { - # each reference has the code, and the file that specified it. - # set up a multi-module context and run that function. if the - # default ever gets called, we log it to tell the multi-module - # handler to call the default at the end. - - my $rv; - my $irv; - my $caller = (caller(1))[3]; - $caller =~ s/^main::multi//; - - $multi_module_context = 1; # defaults then know to defer - $this_call_default = 0; - $store = $master_store->{ $dispatch_ref->[0] }; - print "-- calling \$$caller in $dispatch_ref->[0]\n" - if ($verbose); - my $code_ref = $dispatch_ref->[1]; - $rv = &$rv_handler(@irv = &$code_ref(@args)); - $multi_module_context = 0; - if ($rv & 4) { - # rv_handler indicating to call default and halt - # if it was called. - return &$default(@args) if ($did_call_default); - } - if ($rv & 2) { - # rv_handler indicating to make new @args from @irv - @args = @irv; - } - if ($rv & 1) { - # rv_handler indicating to halt early. do so. - return (wantarray) ? @irv : $irv[0]; - } - } - $multi_module_context = 0; - return &$default(@args) if ($did_call_default); - return (wantarray) ? @irv : $irv[0]; -} - -# these are the stubs that call the dispatcher. -sub multiaddaction { - &multi_module_dispatch(\&defaultaddaction, \@m_addaction, sub{ - # return immediately on the first extension to accept - return (shift>0); - }, @_); -} -sub multiconclude { - &multi_module_dispatch(\&defaultconclude, \@m_conclude, 0, @_); -} -sub multidmconclude { - &multi_module_dispatch(\&defaultdmconclude, \@m_dmconclude, 0, @_); -} -sub multidmhandle { - &multi_module_dispatch(\&defaultdmhandle, \@m_dmhandle, sub { - my $rv = shift; - - # skip default calls. - return 0 if ($this_call_default); - - # if not a default call, and the DM was refused for - # processing by this extension, then the DM is now - # suppressed. do not call any other extensions after this. - # even if it ends in suppression, we still call the default - # if it was ever called before. - return 5 if ($rv == 0); - - # if accepted in any manner, keep calling. - return 0; - }, @_); -} -sub multieventhandle { - &multi_module_dispatch(\&defaulteventhandle, \@m_eventhandle, sub { - my $rv = shift; - - # skip default calls. - return 0 if ($this_call_default); - - # if not a default call, and the event was refused for - # processing by this extension, then the event is now - # suppressed. do not call any other extensions after this. - # even if it ends in suppression, we still call the default - # if it was ever called before. - return 5 if ($rv == 0); - - # if accepted in any manner, keep calling. - return 0; - }, @_); -} -sub multiexception { - # this is a secret option for people who want to suppress errors. - if ($exception_is_maskable) { - &multi_module_dispatch(\&defaultexception, \@m_exception, sub { - my $rv = shift; - - # same logic as handle/dmhandle, except return -1- - # to mask from subsequent extensions. - return 0 if ($this_call_default); - return 5 if ($rv); - return 0; - }, @_); - } else { - &multi_module_dispatch( - \&defaultexception, \@m_exception, 0, @_); - } -} -sub multishutdown { - return if ($shutdown_already_called++); - &multi_module_dispatch(\&defaultshutdown, \@m_shutdown, 0, @_); -} - -sub multiuserhandle { - &multi_module_dispatch(\&defaultuserhandle, \@m_userhandle, sub{ - # skip default calls. - return 0 if ($this_call_default); - - # return immediately on the first extension to accept - return (shift>0); - }, @_); -} -sub multilisthandle { - &multi_module_dispatch(\&defaultlisthandle, \@m_listhandle, sub{ - # skip default calls. - return 0 if ($this_call_default); - - # return immediately on the first extension to accept - return (shift>0); - }, @_); -} -sub multihandle { - &multi_module_dispatch(\&defaulthandle, \@m_handle, sub { - my $rv = shift; - - # skip default calls. - return 0 if ($this_call_default); - - # if not a default call, and the tweet was refused for - # processing by this extension, then the tweet is now - # suppressed. do not call any other extensions after this. - # even if it ends in suppression, we still call the default - # if it was ever called before. - return 5 if ($rv==0); - - # if accepted in any manner, keep calling. - return 0; - }, @_); -} -sub multiheartbeat { - &multi_module_dispatch(\&defaultheartbeat, \@m_heartbeat, 0, @_); -} -sub multiprecommand { - &multi_module_dispatch(\&defaultprecommand, \@m_precommand, sub { - return 2; # feed subsequent chains the result. - }, @_); -} -sub multiprepost { - &multi_module_dispatch(\&defaultprepost, \@m_prepost, sub { - return 2; # feed subsequent chains the result. - }, @_); -} -sub multipostpost { - &multi_module_dispatch(\&defaultpostpost, \@m_postpost, 0, @_); -} -sub multitweettype { - &multi_module_dispatch(\&defaulttweettype, \@m_tweettype, sub { - # if this module DID NOT call default, exit now. - return (!$this_call_default); - }, @_); -} - -sub flag_default_call { $this_call_default++; $did_call_default++; } - -# now the actual default methods - -sub defaultexception { - (&flag_default_call, return) if ($multi_module_context); - my $msg_code = shift; - return if ($msg_code == 2 && $muffle_server_messages); - my $message = "@_"; - $message =~ s/\n*$//sg; - if ($timestamp) { - my ($time, $ts) = &$wraptime(scalar(localtime)); - $message = "[$ts] $message"; - $message =~ s/\n/\n[$ts] /sg; - } - &send_removereadline if ($termrl); - $wrapseq = 1; - print $stdout "${MAGENTA}${message}${OFF}\n"; - &send_repaint if ($termrl); - $laststatus = 1; -} -sub defaultshutdown { - (&flag_default_call, return) if ($multi_module_context); -} -sub defaultlisthandle { - (&flag_default_call, return) if ($multi_module_context); - my $list_ref = shift; - - print $streamout "*** for future expansion ***\n"; - - return 1; -} -sub defaulthandle { - (&flag_default_call, return) if ($multi_module_context); - my $tweet_ref = shift; - my $class = shift; - my $dclass = ($verbose) ? "{$class,$tweet_ref->{'id_str'}} " : ''; - my $sn = &descape($tweet_ref->{'user'}->{'screen_name'}); - my $tweet = &descape($tweet_ref->{'text'}); - my $stweet = &standardtweet($tweet_ref); - my $menu_select = $tweet_ref->{'menu_select'}; - - $menu_select = (length($menu_select) && !$script) - ? (($menu_select =~ /^z/) ? - "${EM}${menu_select}>${OFF} " : - "${menu_select}> ") - : ''; - - print $streamout $menu_select . $dclass . $stweet; - &sendnotifies($tweet_ref, $class); - return 1; -} -sub defaultuserhandle { - (&flag_default_call, return) if ($multi_module_context); - - my $user_ref = shift; - &userline($user_ref, $streamout); - my $desc = &strim(&descape($user_ref->{'description'})); - my $klen = ($wrap || 79) - 9; - $klen = 10 if ($klen < 0); - $desc = substr($desc, 0, $klen)."..." if (length($desc) > $klen); - print $streamout (' "' . $desc . '"' . "\n") if (length($desc)); - return 1; -} -sub userline { # used by both $userhandle and /whois - my $my_json_ref = shift; - my $fh = shift; - - my $verified = - ($my_json_ref->{'verified'} eq 'true') ? - "${EM}(Verified)${OFF} " : ''; - my $protected = - ($my_json_ref->{'protected'} eq 'true') ? - "${EM}(Protected)${OFF} " : ''; - print $fh <<"EOF"; -${CCprompt}@{[ &descape($my_json_ref->{'name'}) ]}${OFF} (@{[ &descape($my_json_ref->{'screen_name'}) ]}) (f:$my_json_ref->{'friends_count'}/$my_json_ref->{'followers_count'}) (u:$my_json_ref->{'statuses_count'}) ${verified}${protected} -EOF - return; -} -sub sendnotifies { # this is a default subroutine of a sort, right? - my $tweet_ref = shift; - my $class = shift; - - my $sn = &descape($tweet_ref->{'user'}->{'screen_name'}); - my $tweet = &descape($tweet_ref->{'text'}); - - # interactive? first time? - unless (length($class) || !$last_id || !length($tweet)) { - $class = scalar(&$tweettype($tweet_ref, $sn, $tweet)); - ¬ifytype_dispatch($class, - &standardtweet($tweet_ref, 1), $tweet_ref) - if ($notify_list{$class}); - } -} - -sub defaulttweettype { - (&flag_default_call, return) if ($multi_module_context); - my $ref = shift; - my $sn = shift; - my $tweet = shift; - - # br3nda's and smb's modified colour patch - unless ($anonymous) { - if (lc($sn) eq $whoami) { - # if it's me speaking, colour the line yellow - return 'me'; - } elsif ($tweet =~ /\@$whoami(\b|$)/i) { - # if I'm in the tweet, colour red - return 'reply'; - } - } - if ($ref->{'class'} eq 'search') { # anonymous allows this too - # if this is a search result, colour cyan - return 'search'; - } - if ($ref->{'tag'}->{'type'} eq 'list') { # anonymous allows this too - return 'list'; - } - return 'default'; -} - -sub defaultconclude { - (&flag_default_call, return) if ($multi_module_context); - if ($filtered && $filter_attribs{'count'}) { - print $stdout "-- (filtered $filtered tweets)\n"; - $filtered = 0; - } -} - -sub defaultdmhandle { - (&flag_default_call, return) if ($multi_module_context); - my $dm_ref = shift; - my $sns = &descape($dm_ref->{'sender'}->{'screen_name'}); - - print $streamout &standarddm($dm_ref); - &senddmnotifies($dm_ref) if ($sns ne $whoami); - return 1; -} - -sub senddmnotifies { - my $dm_ref = shift; - ¬ifytype_dispatch('DM', &standarddm($dm_ref, 1), $dm_ref) - if ($notify_list{'dm'} && $last_dm); -} - -sub defaulteventhandle { - (&flag_default_call, return) if ($multi_module_context); - my $event_ref = shift; - # in this version, we silently filter delete events, but your - # extension would still get them delivered. - return 1 if ($event_ref->{'delete'}); - print $streamout &standardevent($event_ref); - return 1; -} - -sub defaultdmconclude { - (&flag_default_call, return) if ($multi_module_context); -} - -sub defaultheartbeat { - (&flag_default_call, return) if ($multi_module_context); -} - -# not much sense to multi-module protect these. -sub defaultprecommand { return ("@_"); } -sub defaultprepost { return ("@_"); } - -sub defaultpostpost { - (&flag_default_call, return) if ($multi_module_context); - my $line = shift; - return if (!$termrl); - - # populate %readline_completion if readline is on - while($line =~ s/^\@(\w+)\s+//) { - $readline_completion{'@'.lc($1)}++; - } - if ($line =~ /^[dD]\s+(\w+)\s+/) { - $readline_completion{'@'.lc($1)}++; - } -} - -sub defaultautocompletion { - my ($text, $line, $start) = (@_); - my $qmtext = quotemeta($text); - my @proband; - my @rlkeys; - - # handle / completion - if ($start == 0 && $text =~ m#^/#) { - return sort grep(/^$qmtext/i, '/history', - '/print', '/quit', '/bye', '/again', - '/wagain', '/whois', '/thump', '/dm', - '/refresh', '/dmagain', '/set', '/help', - '/reply', '/url', '/thread', '/retweet', '/replyall', - '/replies', '/ruler', '/exit', '/me', '/vcheck', - '/oretweet', '/eretweet', '/fretweet', '/liston', - '/listoff', '/dmsent', '/rtsof', '/rtson', '/rtsoff', - '/lists', '/withlist', '/add', '/padd', '/push', - '/pop', '/followers', '/friends', '/lfollow', - '/lleave', '/listfollowers', '/listfriends', - '/unset', '/verbose', '/short', '/follow', '/unfollow', - '/doesfollow', '/search', '/tron', '/troff', - '/delete', '/deletelast', '/dump', - '/track', '/trends', '/block', '/unblock', - '/fave', '/faves', '/unfave', '/eval'); - } - @rlkeys = keys(%readline_completion); - - # handle @ completion. this works slightly weird because - # readline hands us the string WITHOUT the @, so we have to - # test somewhat blindly. this works even if a future readline - # DOES give us the word with @. also handles D, /wa, /wagain, - # /a, /again, etc. - if (($line =~ m#^(D|/wa|/wagain|/a|/again) #i) || - ($start == 1 && substr($line, 0, 1) eq '@') || - # this code is needed to prevent inline @ from flipping out - ($start >= 1 && substr($line, ($start-2), 2) eq ' @')) { - @proband = grep(/^\@$qmtext/i, @rlkeys); - if (scalar(@proband)) { - @proband = map { s/^\@//;$_ } @proband; - return @proband; - } - } - # definites that are left over, including @ if it were included - if(scalar(@proband = grep(/^$qmtext/i, @rlkeys))) { - return @proband; - } - - # heuristics - # URL completion (this doesn't always work of course) - if ($text =~ m#https?://#) { - return (&urlshorten($text) || $text); - } - - # "I got nothing." - return (); -} - -#### built-in notification routines #### - -# growl for Mac OS X -sub notifier_growl { - my $class = shift; - my $text = shift; - my $ref = shift; # not used in this version - - if (!defined($class) || !length($notify_tool_path)) { - # we are being asked to initialize - $notify_tool_path = &wherecheck("trying to find growlnotify", - "growlnotify", -"growlnotify must be installed to use growl notifications. check your\n" . - "documentation for how to do this.\n") - unless ($notify_tool_path); - if (!defined($class)) { - return 1 if ($script || $notifyquiet); - $class = 'Growl support activated'; - $text = -'You can configure notifications for TTYtter in the Growl preference pane.'; - } - } - # handle this in the background for faster performance. - # to avoid problems with SIGCHLD, we fork ourselves twice (mmm!), - # leaving an orphan which init should grab (we need SIGCHLD for - # proper backticks, so it can't be IGNOREd). - my $gchild; - if ($gchild = fork()) { - # the parent harvests the child, which will die immediately. - waitpid($gchild, 0); - return 1; - } elsif (!defined ($gchild)) { - print $stdout "warning: failed growl fork: $!\n"; - return 1; - } - # this is the child. spawn, then exit and abandon our own child, - # which init will reap. the problem with teen pregnancy is mounting. - $in_backticks = 1; - my $hchild; - if ($hchild = fork()) { - exit; - } elsif (!defined ($hchild)) { - print $stdout "warning: failed growl fork: $!\n"; - exit; - } - # this is the subchild, which is abandoned at a fire sta^W^W^Winit. - open(GROWL, "|$notify_tool_path -n 'TTYtter' 'TTYtter: $class'"); - binmode(GROWL, ":utf8") unless ($seven); - print GROWL $text; - close(GROWL); - exit; -} - -# libnotify for {Linux,whatevs} -# this is EXPERIMENTAL, and requires this patch to notify-send: -# http://www.floodgap.com/software/ttytter/libnotifypatch.txt -# why it has not already been applied is fricking beyond me, it makes -# sense. would YOU want arbitrary characters on the command line -# separated only from overwriting your home directory by a quoting routine? -sub notifier_libnotify { - my $class = shift; - my $text = shift; - my $ref = shift; # not used in this version - - if (!defined($class) || !defined($notify_tool_path)) { - # we are being asked to initialize - $notify_tool_path = &wherecheck("trying to find notify-send", - "notify-send", -"notify-send must be installed to use libnotify, and it must be modified\n". -"for standard input. see the documentation for how to do this.\n") - unless ($notify_tool_path); - if (!defined($class)) { - return 1 if ($script || $notifyquiet); - $class = 'libnotify support activated'; - $text = -'Congratulations, your notify-send is correctly configured for TTYtter.'; - } - } - # figure out the time to display based on length of tweet - my $t = 1000+50*length($text); # about 150-180wpm read speed - open(NOTIFYSEND, - "|$notify_tool_path -t $t -f - 'TTYtter: $class'"); - binmode(NOTIFYSEND, ":utf8") unless ($seven); - print NOTIFYSEND $text; - close(NOTIFYSEND); - return 1; -} - -#### IPC routines for communicating between the foreground + background #### - -# this is the central routine that takes a rolling tweet code, figures -# out where that tweet is, and returns something approximating a tweet -# structure (or the actual tweet structure itself if it can). -sub get_tweet { - my $code = lc(shift); - -#TODO -# implement querying the id_cache here. we need IPC for it, though. - # if the code is all numbers, treat it like an id_str, and try - # to get it from the server. we have similar code in get_dm. - # the first tweet that is of relevance is ID 20. try /dump 20 :) - return &grabjson("${idurl}?id=${code}", 0, 0, 0, undef, 1) - if ($code =~ /^[0-9]+$/ && (0+$code > 19)); - - return undef if ($code !~ /^z?[a-z][0-9]$/); - my $source = ($code =~ /^z/) ? 1 : 0; - my $k = ''; - my $l = ''; - my $w = {'user' => {}}; - - if ($is_background) { - if ($source == 1) { # foreground only - return undef; - } - return $store_hash{$code}; - } - return $store_hash{$code} if ($source); # foreground c/foreground twt - - print $stdout "-- querying background: $code\n" if ($verbose); - kill $SIGUSR2, $child if ($child); - print C "pipet $code ----------\n"; - while(length($k) < 1024) { - sysread(W, $l, 1024); - $k .= $l; - } - return undef if ($k !~ /[^\s]/); - $k =~ s/\s+$//; # remove trailing spaces - print $stdout "-- background store fetch: $k\n" if ($verbose); - ($w->{'menu_select'}, $w->{'id_str'}, $w->{'in_reply_to_status_id_str'}, - $w->{'retweeted_status'}->{'id_str'}, - $w->{'user'}->{'geo_enabled'}, - $w->{'geo'}->{'coordinates'}->[0], - $w->{'geo'}->{'coordinates'}->[1], - $w->{'place'}->{'id'}, - $w->{'place'}->{'country_code'}, - $w->{'place'}->{'place_type'}, - $w->{'place'}->{'full_name'}, - $w->{'tag'}->{'type'}, - $w->{'tag'}->{'payload'}, - $w->{'retweet_count'}, - $w->{'user'}->{'screen_name'}, $w->{'created_at'}, - $l) = split(/\s/, $k, 17); - ($w->{'source'}, $k) = split(/\|/, $l, 2); - $w->{'text'} = pack("H*", $k); - $w->{'place'}->{'full_name'} = pack("H*",$w->{'place'}->{'full_name'}); - $w->{'tag'}->{'payload'} = pack("H*", $w->{'tag'}->{'payload'}); - return undef if (!length($w->{'text'})); # unpossible - $w->{'created_at'} =~ s/_/ /g; - return $w; -} - -# this is the analogous function for a rolling DM code. it is somewhat -# simpler as DM codes are always rolling and have no foreground store -# currently, so it always executes a background request. -sub get_dm { - my $code = lc(shift); - my $k = ''; - my $l = ''; - my $w = {'sender' => {}}; - return undef if (length($code) < 3 || $code !~ s/^d//); - - # this is the aforementioned "similar code" (see get_tweet). - # optimization: I doubt ANY of us can get DMIDs less than 9. - return &grabjson("${dmidurl}?id=$code", 0, 0, 0, undef, 1) - if ($code =~ /^[0-9]+$/ && (0+$code > 9)); - - return undef if ($code !~ /^[a-z][0-9]$/); - - kill $SIGUSR2, $child if ($child); # prime pipe - print C "piped $code ----------\n"; # internally two alphanum, recall - while(length($k) < 1024) { - sysread(W, $l, 1024); - $k .= $l; - } - return undef if ($k !~ /[^\s]/); - $k =~ s/\s+$//; # remove trailing spaces - print $stdout "-- background store fetch: $k\n" if ($verbose); - ($w->{'menu_select'}, $w->{'id_str'}, - $w->{'sender'}->{'screen_name'}, $w->{'created_at'}, - $l) = split(/\s/, $k, 5); - $w->{'text'} = pack("H*", $l); - return undef if (!length($w->{'text'})); # not possible - $w->{'created_at'} =~ s/_/ /g; - return $w; -} - -# this function requests a $store key from the background. it only works -# if foreground. -sub getbackgroundkey { - if ($is_background) { - print $stdout "*** can't call getbackgroundkey from background\n"; - return undef; - } - my $key = shift; - my $l; - my $k; - print C substr("ki $key ---------------------", 0, 19)."\n"; - my $ref = (length($dispatch_ref->[0])) ? ($dispatch_ref->[0]) : - "DEFAULT"; - print C substr(unpack("${pack_magic}H*", $ref).$space_pad, 0, 1024); - while(length($k) < 1024) { - sysread(W, $l, 1024); - $k .= $l; - } - $k =~ s/[^0-9a-fA-F]//g; - print $stdout "-- background store fetch: $k\n" if ($verbose); - return pack("H*", $k); -} - -# this function sends a $store key to the background. it only works if -# foreground. -sub sendbackgroundkey { - if ($is_background) { - print $stdout "*** can't call sendbackgroundkey from background\n"; - return; - } - my $key = shift; - my $value = shift; - if (ref($value)) { - print $stdout "*** send_key only supported for scalars\n"; - return; - } - if (!length($value)) { - print C substr("kn $key ---------------------", 0, 19)."\n"; - } else { - print C substr("ko $key ---------------------", 0, 19)."\n"; - } - my $ref = (length($dispatch_ref->[0])) ? ($dispatch_ref->[0]) : - "DEFAULT"; - print C substr(unpack("${pack_magic}H*", $ref).$space_pad, 0, 1024); - return if (!length($value)); - print C substr(unpack("${pack_magic}H*", $value).$space_pad, 0, 1024); -} - -sub thump { print C "update-------------\n"; &sync_semaphore; } -sub dmthump { print C "dmthump------------\n"; &sync_semaphore; } - -sub sync_n_quit { - if ($child) { - print $stdout "waiting for child ...\n" unless ($silent); - print C "sync---------------\n"; - waitpid $child, 0; - $child = 0; - print $stdout "exiting.\n" unless ($silent); - exit ($? >> 8); - } - exit; -} - -# setter for internal variables, with all the needed side effects for those -# variables that are programmed to trigger internal actions when changed. -sub setvariable { - my $key = shift; - my $value = shift; - my $interactive = 0+shift; - - $value =~ s/^\s+//; - $value =~ s/\s+$//; # mostly to avoid problems with /(p)add - - if ($key eq 'script') { # this can never be changed by this routine - print $stdout "*** script may only be changed on init\n"; - return 1; - } - if ($key eq 'tquery' && $value eq '0') { # undo tqueries - $tquery = undef; - $key = 'track'; - $value = $track; # falls thru to sync - &tracktags_makearray; - } - if ($opts_can_set{$key} || - # we CAN set read-only variables during initialization - ($multi_module_mode == -1 && $valid{$key})) { - if (length($value) > 1023) { - # can't transmit this in a packet - print $stdout "*** value too long\n"; - return 1; - } elsif ($opts_boolean{$key} && $value ne '0' && - $value ne '1') { - print $stdout "*** 0|1 only (boolean): $key\n"; - return 1; - } elsif ($opts_urls{$key} && - $value !~ m#^(http|https|gopher)://#) { - print $stdout "*** must be valid URL: $key\n"; - return 1; - } else { - KEYAGAIN: $$key = $value; - print $stdout "*** changed: $key => $$key\n" - if ($interactive || $verbose); - - # handle special values - &generate_ansi if ($key eq 'ansi' || - $key =~ /^colour/); - &generate_shortdomain if ($key eq 'shorturl'); - &tracktags_makearray if ($key eq 'track'); - &filter_compile if ($key eq 'filter'); - ¬ify_compile if ($key eq 'notifies'); - &list_compile if ($key eq 'lists'); - &filterflags_compile if ($key eq 'filterflags'); - $filterrts_sub = &filteruserlist_compile( - $filterrts_sub, $value) - if ($key eq 'filterrts'); - $filterusers_sub = &filteruserlist_compile( - $filterusers_sub,$value) - if ($key eq 'filterusers'); - $filteratonly_sub = &filteruserlist_compile( - $filteratonly_sub, $value) - if ($key eq 'filteratonly'); - &filterats_compile if ($key eq 'filterats'); - - # transmit to background process sync-ed values - if ($opts_sync{$key}) { - &synckey($key, $value, $interactive); - } - if ($key eq 'superverbose') { - if ($value eq '0') { - $key = 'verbose'; - $value = $supreturnto; - goto KEYAGAIN; - } - $supreturnto = $verbose; - } - } - # virtual keys - } elsif ($key eq 'tquery') { - my $ivalue = &tracktags_tqueryurlify($value); - if (length($ivalue) > 139) { - print $stdout - "*** custom query is too long (encoded: $ivalue)\n"; - return 1; - } else { - $tquery = $value; - &synckey($key, $ivalue, $interactive); - } - } elsif ($valid{$key}) { - print $stdout - "*** read-only, must change on command line: $key\n"; - return 1; - } else { - print $stdout - "*** not a valid option or setting: $key\n"; - return 1; - } - return 0; -} -sub synckey { - my $key = shift; - my $value = shift; - my $interactive = 0+shift; - my $commchar = ($interactive) ? '=' : '+'; - print $stdout "*** (transmitting to background)\n" - if ($interactive || $verbose); - return if (!$child); - kill $SIGUSR2, $child if ($child); - print C - (substr("${commchar}$key ", 0, 19) . "\n"); - print C (substr(($value . $space_pad), 0, 1024)); - sleep 1; -} - -# getter for internal variables. right now this just returns the variable by -# name and a couple virtuals, but in the future this might be expanded. -sub getvariable { - my $key = shift; - if ($valid{$key}) { - return $$key; - } - if ($key eq 'effpause' || - $key eq 'rate_limit_rate' || - $key eq 'rate_limit_left') { - my $value; - kill $SIGUSR2, $child if ($child); - print C (substr("?$key ", 0, 19) . "\n"); - sysread(W, $value, 1024); - $value =~ s/\s+$//; - return $value; - } - return undef; -} - -# compatibility stub for extensions calling the old wraptime -sub wraptime { return &$wraptime(@_); } - -#### url management (/url, /short) #### - -sub generate_shortdomain { - my $x; - my $y; - - undef $shorturldomain; - ($shorturl =~ m#^http://([^/]+)/#) && ($x = $1); - # chop off any leading hostname stuff (like api., etc.) - while(1) { - $y = $x; - $x =~ s/^[^\.]*\.//; - if ($x !~ /\./) { # a cut too far - $shorturldomain = "http://$y/"; - last; - } - } - print $stdout "-- warning: couldn't parse shortener service\n" - if (!length($shorturldomain)); -} - -sub openurl { - my $comm = $urlopen; - my $url = shift; - $url = "http://gopher.floodgap.com/gopher/gw?".&url_oauth_sub($url) - if ($url =~ m#^gopher://# && $comm !~ /^[^\s]*lynx/); - $urlshort = $url; - $comm =~ s/\%U/'$url'/g; - print $stdout "($comm)\n"; - system("$comm"); -} - -sub urlshorten { - my $url = shift; - my $rc; - my $cl; - - $url = "http://gopher.floodgap.com/gopher/gw?".&url_oauth_sub($url) - if ($url =~ m#^gopher://#); - return $url if ($url =~ /^$shorturldomain/i); # stop loops - $url = &url_oauth_sub($url); - $cl = "$simple_agent \"${shorturl}$url\""; - print $stdout "$cl\n" if ($superverbose); - chomp($rc = `$cl`); - return ($urlshort = (($rc =~ m#^http://#) ? $rc : undef)); -} - -##### optimizers -- these compile into an internal format ##### - -# utility routine for tquery support -sub tracktags_tqueryurlify { - my $value = shift; - $value =~ s/([^ a-z0-9A-Z_])/"%".unpack("H2",$1)/eg; - $value =~ s/\s/+/g; - $value = "q=$value" if ($value !~ /^q=/); - return $value; -} - -# tracking subroutines -# run when a string is passed -sub tracktags_makearray { - @tracktags = (); - $track =~ s/^'//; $track =~ s/'$//; $track = lc($track); - if (!length($track)) { - @trackstrings = (); - return; - } - my $k; - my $l = ''; - my $q = 0; - my %w; - my (@ptags) = split(/\s+/, $track); - - # filter duplicates and merge quoted strings - foreach $k (@ptags) { - if ($q && $k =~ /"$/) { # this has to be first - $l .= " $k"; - $q = 0; - } elsif ($k =~ /^"/ || $q) { - $l .= (length($l)) ? " $k" : $k; - $q = 1; - next; - } else { - $l = $k; - } - - if ($w{$l}) { - print $stdout - "-- warning: dropping duplicate track term \"$l\"\n"; - } elsif (uc($l) eq 'OR' || uc($l) eq 'AND') { - print $stdout - "-- warning: dropping unnecessary logical op \"$l\"\n"; - } else { - $w{$l} = 1; - push(@tracktags, $l); - } - $l = ''; - } - print $stdout "-- warning: syntax error, missing quote?\n" if ($q); - $track = join(' ', @tracktags); - &tracktags_compile; -} -# run when array is altered (based on @kellyterryjones' code) -sub tracktags_compile { - @trackstrings = (); - return if (!scalar(@tracktags)); - - my $k; - my $l = ''; - # need to limit track tags to a certain number of pieces - TAGBAG: foreach $k (@tracktags) { - if (length($k) > 130) { # I mean, really - print $stdout - "-- warning: track tag \"$k\" is TOO LONG\n"; - next TAGBAG; - } - if (length($l)+length($k) > 150) { # balance of size/querytime - push(@trackstrings, "q=".&url_oauth_sub($l)); - $l = ''; - } - $l = (length($l)) ? "${l} OR ${k}" : "${k}"; - } - push(@trackstrings, "q=".&url_oauth_sub($l)) if (length($l)); -} - -# notification multidispatch -sub notifytype_dispatch { - return if (!scalar(@notifytypes)); - my $nt; foreach $nt (@notifytypes) { &$nt(@_); } -} - -# notifications compiler -sub notify_compile { - if ($notifies) { - my $w; - - undef %notify_list; - foreach $w (split(/\s*,\s*/, $notifies)) { - $notify_list{$w} = 1; - } - $notifies = join(',', keys %notify_list); - } -} - -# lists compiler -# we don't check the validity of lists here; /liston and /listoff do that. -sub list_compile { - my @oldlistlist = @listlist; - my %already; - - undef @listlist; - if ($lists) { - my $w; - my $u; - my $l; - foreach $w (split(/\s*,\s*/, $lists)) { - $w =~ s/^@//; - if ($w =~ m#/#) { - ($u, $l) = split(m#\s*/\s*#, $w, 2); - } else { - $l = $w; - } - if (!length($u) && $anonymous) { -print $stdout "*** must use fully specified lists when anonymous\n"; - @listlist = @oldlistlist; - return 0; - } - $u ||= $whoami; - if ($l =~ m#/#) { -print $stdout "*** syntax error in list $u/$l\n"; - @listlist = @oldlistlist; - return 0; - } - if ($already{"$u/$l"}++) { - print $stdout "*** duplicate list $u/$l ignored\n"; - } else { - push(@listlist, [ $u, $l ]); - } - } - $lists = join(',', keys %already); - } - return 1; -} - -# -filterflags compiler (replaces old -filter syntax) -sub filterflags_compile { - my $s = $filterflags; - undef %filter_attribs; - $s =~ s/^\s*['"]?\s*//; - $s =~ s/\s*['"]?\s*$//; - return if (!length($s)); - %filter_attribs = map { $_ => 1 } split(/\s*,\s*/, $s); -} - -# -filterrts and -filterusers compiler. these simply use a list of usernames, -# so they are fast and the same code suffices. emit code to compile that -# just is one if-expression after another. -sub filteruserlist_compile { - my $old = shift; - my $s = shift; - undef $k; - $s =~ s/^\s*['"]?\s*//; - $s =~ s/\s*['"]?\s*$//; - return $k if (!length($s)); - my @us = map { $k=lc($_); "\$sn eq '$k'" } split(/\s*,\s*/, $s); - my $uus = join(' || ', @us); - my $uuus = <<"EOF"; - \$k = sub { - my \$sn = shift; - return 1 if ($uus); - return 0; - }; -EOF -# print $stdout $uuus; - eval $uuus; - if (!defined($k)) { - print $stdout "** bogus name in user list (error = $@)\n"; - return $old; - } - return $k; -} - -# -filterats compiler. this takes a list of usernames and then compiles a -# whole bunch of regexes. -sub filterats_compile { - undef $filterats_c; - my $s = $filterats; - $s =~ s/^\s*['"]?\s*//; - $s =~ s/\s*['"]?\s*$//; - return 1 if (!length($s)); # undef - my @us = map { $k=lc($_); "\$x=~/\\\@$k\\b/i" } split(/\s*,\s*/, $s); - my $uus = join(' || ', @us); - my $uuus = <<"EOF"; - \$filterats_c = sub { - my \$x = shift; - return 1 if ($uus); - return 0; - }; -EOF -# print $stdout $uuus; - eval $uuus; - if (!defined($filterats_c)) { - print $stdout "** bogus name in user list (error = $@)\n"; - return 0; - } - return 1; -} - -# -filter compiler. this is the generic case. -sub filter_compile { - undef %filter_attribs unless (length($filterflags)); - undef $filter_c; - if (length($filter)) { - my $tfilter = $filter; - $tfilter =~ s/^['"]//; - $tfilter =~ s/['"]$//; - # note attributes (compatibility) - while ($tfilter =~ s/^([a-z]+),//) { - my $atkey = $1; - $filter_attribs{$atkey}++; - print $stdout - "** $atkey filter parameter should be in -filterflags\n"; - } - my $b = <<"EOF"; - \$filter_c = sub { - local \$_ = shift; - return ($tfilter); - }; -EOF - #print $b; - eval $b; - if (!defined($filter_c)) { - print $stdout ("** syntax error in your filter: $@\n"); - return 0; - } - } - return 1; -} - -#### common system subroutines follow #### - -sub updatecheck { - my $vcheck_url = - "http://www.floodgap.com/software/ttytter/02current.txt"; - my $vrlcheck_url = - "http://www.floodgap.com/software/ttytter/01readlin.txt"; - my $update_url = shift; - - my $vs = ''; - my $vvs; - my $tverify; - my $inversion; - my $bversion; - my $rcnum; - my $download; - my $maj; - my $min; - my $s1, $s2, $s3; - my $update_trlt = undef; - - if ($termrl && $termrl->ReadLine eq 'Term::ReadLine::TTYtter') { - my $trlv = $termrl->Version; - print $stdout - "-- checking Term::ReadLine::TTYtter version: $vrlcheck_url\n"; - $vvs = `$simple_agent $vrlcheck_url`; - print $stdout "-- server response: $vvs\n" if ($verbose); - ($vvs, $s1, $s2, $s3) = split(/--__--\n/s, $vvs); - $s1 = undef if ($s1 !~ /^\*/) ; - $s2 = undef if ($s2 !~ /^\*/) ; - $s3 = undef if ($s3 !~ /^\*/) ; - chomp($vvs); - # right now we're only using $inversion (no betas/rcs). - ($tverify, $inversion, $bversion, $rcnum, $download, - $bdownload) = split(/;/, $vvs, 6); - if ($tverify ne 'trlt') { -$vs .= "-- warning: unable to verify Term::ReadLine::TTYtter version\n"; - } else { - if ($trlv < 0+$inversion) { -$vs .= "** NEW Term::ReadLine::TTYtter VERSION AVAILABLE: $inversion **\n" . - "** GET IT: $download\n"; - $update_trlt = $download; - } else { -$vs .= "-- your version of Term::ReadLine::TTYtter is up to date ($trlv)\n"; - } - } - } - - print $stdout "-- checking TTYtter version: $vcheck_url\n"; - $vvs = `$simple_agent $vcheck_url`; - print $stdout "-- server response: $vvs\n" if ($verbose); - ($vvs, $s1, $s2, $s3) = split(/--__--\n/s, $vvs); - $s1 = undef if ($s1 !~ /^\*/) ; - $s2 = undef if ($s2 !~ /^\*/) ; - $s3 = undef if ($s3 !~ /^\*/) ; - chomp($vvs); - ($tverify, $inversion, $bversion, $rcnum, $download, $bdownload) = - split(/;/, $vvs, 6); - if ($tverify ne 'ttytter') { - $vs .= "-- warning: unable to verify TTYtter version\n"; - } else { - if ($my_version_string eq $bversion) { - $vs .= -"** REMINDER: you are using a beta version (${my_version_string}b${TTYtter_RC_NUMBER})\n"; - $vs .= -"** NEW TTYtter RELEASE CANDIDATE AVAILABLE: build $rcnum **\n" . -"** get it: $bdownload\n$s2" - if ($TTYtter_RC_NUMBER < $rcnum); - $vs .= "** (this is the most current beta)\n" - if ($TTYtter_RC_NUMBER == $rcnum); - $vs .= "$s1$s3"; - if ($TTYtter_RC_NUMBER < $rcnum) { - if ($update_url) { - $vs .= -"-- %URL% is now $bdownload (/short shortens, /url opens)\n"; - $urlshort = $bdownload; - } - } elsif (length($update_trlt) && $update_url) { - $urlshort = $update_trlt; - $vs .= "-- %URL% is now $urlshort (/short shortens, /url opens)\n"; - } - return $vs; - } - if ($my_version_string eq $inversion && $TTYtter_RC_NUMBER) { - $vs .= -"** FINAL TTYtter RELEASE NOW AVAILABLE for version $inversion **\n" . -"** get it: $download\n$s2$s1"; - if ($update_url) { - $vs .= -"-- %URL% is now $bdownload (/short shortens, /url opens)\n"; - $urlshort = $bdownload; - } - return $vs; - } - ($inversion =~/^(\d+\.\d+)\.(\d+)$/) && ($maj = 0+$1, - $min = 0+$2); - if (0+$TTYtter_VERSION < $maj || - (0+$TTYtter_VERSION == $maj && - $TTYtter_PATCH_VERSION < $min)) { - $vs .= - "** NEWER TTYtter VERSION NOW AVAILABLE: $inversion **\n" . - "** get it: $download\n$s2$s1"; - if ($update_url) { - $vs .= -"-- %URL% is now $download (/short shortens, /url opens)\n"; - $urlshort = $download; - } - return $vs; - } elsif (0+$TTYtter_VERSION > $maj || - (0+$TTYtter_VERSION == $maj && - $TTYtter_PATCH_VERSION > $min)) { - $vs .= - "** unable to identify your version of TTYtter\n$s1"; - } else { - $vs .= - "-- your version of TTYtter is up to date ($inversion)\n$s1"; - } - } - - # if we got this far, then there is no TTYtter update, but maybe a - # T:RL:T update, so we offer that as the URL - if (length($update_trlt) && $update_url) { - $urlshort = $update_trlt; - $vs .= "-- %URL% is now $urlshort (/short shortens, /url opens)\n"; - } - return $vs; -} - -sub generate_otabcomp { - if (scalar(@j = keys(%readline_completion))) { - # print optimized readline. include all that we - # manually specified, plus/including top @s, total 10. - @keys = sort { $readline_completion{$b} <=> - $readline_completion{$a} } @j; - $factor = $readline_completion{$keys[0]}; - foreach(keys %original_readline) { - $readline_completion{$_} += $factor; - } - print $stdout "*** optimized readline:\n"; - @keys = sort { $readline_completion{$b} <=> - $readline_completion{$a} } keys - %readline_completion; - @keys = @keys[0..14] if (scalar(@keys) > 15); - print $stdout "-readline=\"@keys\"\n"; - } -} -sub end_me { exit; } # which falls through to, via END, ... -sub killkid { - # for streaming assistance - if ($child) { - print $stdout "\n\ncleaning up.\n"; - kill $SIGHUP, $child; # warn it about shutdown - if (length($track)) { - print $stdout "*** you were tracking:\n"; - print $stdout "-track='$track'\n"; - } - if (length($filter)) { - print $stdout "*** your current filter expression:\n"; - print $stdout "-filter='$filter'\n"; - } - &generate_otabcomp; - sleep 2 if ($dostream); - kill 9, $curlpid if ($curlpid); - kill 9, $child; - } - &$shutdown unless (!$shutdown); -} - -sub generate_ansi { - my $k; - - $BLUE = ($ansi) ? "${ESC}[34;1m" : ''; - $RED = ($ansi) ? "${ESC}[31;1m" : ''; - $GREEN = ($ansi) ? "${ESC}[32;1m" : ''; - $YELLOW = ($ansi) ? "${ESC}[33m" : ''; - $MAGENTA = ($ansi) ? "${ESC}[35m" : ''; - $CYAN = ($ansi) ? "${ESC}[36m" : ''; - - $EM = ($ansi) ? "${ESC}[1m" : ''; - $UNDER = ($ansi) ? "${ESC}[4m" : ''; - $OFF = ($ansi) ? "${ESC}[0m" : ''; - - foreach $k (qw(prompt me dm reply warn search list default)) { - ${"colour$k"} = uc(${"colour$k"}); - if (!defined($${"colour$k"})) { - print $stdout - "-- warning: bogus colour '".${"colour$k"}."'\n"; - } else { - eval("\$CC$k = \$".${"colour$k"}); - } - } - - eval '$termrl->hook_use_ansi' if ($termrl); -} - -# always POST -sub postjson { - my $url = shift; - my $postdata = shift; # add _method=DELETE for delete - my $data; - - # this is copied mostly verbatim from grabjson - chomp($data = &backticks($baseagent, '/dev/null', undef, $url, - $postdata, 0, @wend)); - my $k = $? >> 8; - - $data =~ s/[\r\l\n\s]*$//s; - $data =~ s/^[\r\l\n\s]*//s; - - if (!length($data) || $k == 28 || $k == 7 || $k == 35) { - &$exception(1, "*** warning: timeout or no data\n"); - return undef; - } - - # old non-JSON based error reporting code still supported - if ($data =~ /^\[?\]?<!DOCTYPE\s+html/i || $data =~ /^(Status:\s*)?50[0-9]\s/ || $data =~ /^<html>/i || $data =~ /^<\??xml\s+/) { - print $stdout $data if ($superverbose); - if (&is_fail_whale($data)) { - &$exception(2, "*** warning: Twitter Fail Whale\n"); - } else { - &$exception(2, "*** warning: Twitter error message received\n" . - (($data =~ /<title>Twitter:\s*([^<]+)</) ? - "*** \"$1\"\n" : '')); - } - return undef; - } - if ($data =~ /^rate\s*limit/i) { - print $stdout $data if ($superverbose); - &$exception(3, -"*** warning: exceeded API rate limit for this interval.\n" . -"*** no updates available until interval ends.\n"); - return undef; - } - - if ($k > 0) { - &$exception(4, -"*** warning: unexpected error code ($k) from user agent\n"); - return undef; - } - - # handle things like 304, or other things that look like HTTP - # error codes - if ($data =~ m#^HTTP/\d\.\d\s+(\d+)\s+#) { - $code = 0+$1; - print $stdout $data if ($superverbose); - - # 304 is actually a cop-out code and is not usually - # returned, so we should consider it a non-fatal error - if ($code == 304 || $code == 200 || $code == 204) { - &$exception(1, "*** warning: timeout or no data\n"); - return undef; - } - &$exception(4, -"*** warning: unexpected HTTP return code $code from server\n"); - return undef; - } - - # test for error/warning conditions with trivial case - if ($data =~ /^\s*\{\s*(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1/s - || $data =~ /(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1\}/s) { - print $stdout $data if ($superverbose); - &$exception(2, "*** warning: server $2 message received\n" . - "*** \"$3\"\n"); - return undef; - } - - return &parsejson($data); -} - -# always GET -sub grabjson { - my $data; - my $url = shift; - my $last_id = shift; - my $is_anon = shift; - my $count = shift; - my $tag = shift; - my $do_entities = shift; - - my $kludge_search_api_adjust = 0; - my $my_json_ref = undef; # durrr hat go on foot - my $i; - my $tdata; - my $seed; - - #undef $/; $data = <STDIN>; - - # we may need to sort our args for more flexibility here. - my @xargs = (); my $i = index($url, "?"); - if ($i > -1) { - # throw an error if "?" is at the end. - push(@xargs, split(/\&/, substr($url, ($i+1)))); - $url = substr($url, 0, $i); - } - - # count needs to be removed for the default case due to show, etc. - push(@xargs, "count=$count") if ($count); - # timeline control. this speeds up parsing since there's less data. - # can't use skip_user: no SN - push (@xargs, "since_id=${last_id}") if ($last_id); - - # request entities, which should be supported everywhere now - push (@xargs, "include_entities=1") if ($do_entities); - - my $resource = (scalar(@xargs)) ? - [ $url, join('&', sort @xargs) ] : $url; - - chomp($data = &backticks($baseagent, - '/dev/null', undef, $resource, undef, - $is_anon + $anonymous, @wind)); - my $k = $? >> 8; - - $data =~ s/[\r\l\n\s]*$//s; - $data =~ s/^[\r\l\n\s]*//s; - - if (!length($data) || $k == 28 || $k == 7 || $k == 35) { - &$exception(1, "*** warning: timeout or no data\n"); - return undef; - } - - # old non-JSON based error reporting code still supported - if ($data =~ /^\[?\]?<!DOCTYPE\s+html/i || $data =~ /^(Status:\s*)?50[0-9]\s/ || $data =~ /^<html>/i || $data =~ /^<\??xml\s+/) { - print $stdout $data if ($superverbose); - if (&is_fail_whale($data)) { - &$exception(2, "*** warning: Twitter Fail Whale\n"); - } else { - &$exception(2, "*** warning: Twitter error message received\n" . - (($data =~ /<title>Twitter:\s*([^<]+)</) ? - "*** \"$1\"\n" : '')); - } - return undef; - } - if ($data =~ /^rate\s*limit/i) { - print $stdout $data if ($superverbose); - &$exception(3, -"*** warning: exceeded API rate limit for this interval.\n" . -"*** no updates available until interval ends.\n"); - return undef; - } - - if ($k > 0) { - &$exception(4, -"*** warning: unexpected error code ($k) from user agent\n"); - return undef; - } - - # handle things like 304, or other things that look like HTTP - # error codes - if ($data =~ m#^HTTP/\d\.\d\s+(\d+)\s+#) { - $code = 0+$1; - print $stdout $data if ($superverbose); - - # 304 is actually a cop-out code and is not usually - # returned, so we should consider it a non-fatal error - if ($code == 304 || $code == 200 || $code == 204) { - &$exception(1, "*** warning: timeout or no data\n"); - return undef; - } - &$exception(4, -"*** warning: unexpected HTTP return code $code from server\n"); - return undef; - } - - # test for error/warning conditions with trivial case - if ($data =~ /^\s*\{\s*(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1/s - || $data =~ /(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1\}/s) { - print $stdout $data if ($superverbose); - &$exception(2, "*** warning: server $2 message received\n" . - "*** \"$3\"\n"); - return undef; - } - - # if wrapped in statuses object, unwrap it - # (and tag it to do more later) - if ($data =~ s/^\s*(\{)\s*['"]statuses['"]\s*:\s*(\[.*\]).*$/$2/isg) { - $kludge_search_api_adjust = 1; - } - - $my_json_ref = &parsejson($data); - - # normalize the data into a standard form. - # single tweets such as from statuses/show aren't arrays, so - # we special-case for them. - if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' && - $my_json_ref->{'favorited'} && - $my_json_ref->{'source'} && - ((0+$my_json_ref->{'id'}) || - length($my_json_ref->{'id_str'}))) { - $my_json_ref = &normalizejson($my_json_ref); - } - if (defined($my_json_ref) && ref($my_json_ref) eq 'ARRAY') { - foreach $i (@{ $my_json_ref }) { - $i = &normalizejson($i,$kludge_search_api_adjust,$tag); - } - } - - $laststatus = 0; - return $my_json_ref; -} - -# convert t.co into actual URLs. separate from normalizejson because other -# things need this. modified from /entities. -sub destroy_all_tco { - my $hash = shift; - return $hash if ($notco); - my $v; - my $w; - - # Twitter puts entities in multiple fields. - foreach $w (qw(media urls)) { - my $p = $hash->{'entities'}->{$w}; - next if (!defined($p) || ref($p) ne 'ARRAY'); - foreach $v (@{ $p }) { - next if (!defined($v) || ref($v) ne 'HASH'); - next if (!length($v->{'url'}) || - (!length($v->{'expanded_url'}) && - !length($v->{'media_url'}))); - my $u1 = quotemeta($v->{'url'}); - my $u2 = $v->{'expanded_url'}; - my $u3 = $v->{'media_url'}; - my $u4 = $v->{'media_url_https'}; - $u2 = $u4 || $u3 || $u2; - $hash->{'text'} =~ s/$u1/$u2/; - } - } - return $hash; -} - -# takes a tweet structure and normalizes it according to settings. -# what this currently does is the following gyrations: -# - if there is no id_str, see if we can convert id into one. if -# there is loss of precision, warn the user. same for -# in_reply_to_status_id_str. -# - if the source of this JSON data source is the Search API, translate -# its fields into the standard API. -# - if the calling function has specified a tag, tag the tweets, since -# we're iterating through them anyway. the tag should be a hashref payload. -# - if the tweet is an newRT, unwrap it so that the full tweet text is -# revealed (unless -nonewrts). -# - if this appears to be a tweet, put in a stub geo hash if one does -# not yet exist. -# - if coordinates are flat string 'null', turn into a real null. -# one day I would like this code to go the hell away. -sub normalizejson { - my $i = shift; - my $kludge_search_api_adjust = shift; - my $tag = shift; - my $rt; - - # tag the tweet - $i->{'tag'} = $tag if (defined($tag)); - - # id -> id_str if needed - if (!length($i->{'id_str'})) { - my $k = "" + (0 + $i->{'id'}); - if ($k !~ /[eE][+-]/) { - $i->{'id_str'} = $k; - } else { - # desperately try to convert - $k =~ s/[eE][+-]\d+$//; - $k =~ s/\.//g; - # this is a hack, so we warn. - &$exception(13, -"*** impending doom: ID overflows Perl precision; stubbed to $k\n"); - $i->{'id_str'} = $k; - } - } - # irtsid -> irtsid_str (if there is one) - if (!length($i->{'in_reply_to_status_id_str'}) && - $i->{'in_reply_to_status_id'}) { - my $k = "" + (0+$i->{'in_reply_to_status_id'}); - if ($k !~ /[eE][+-]/) { - $i->{'in_reply_to_status_id_str'} = $k; - } else { - # desperately try to convert - $k =~ s/[eE][+-]\d+$//; - $k =~ s/\.//g; - # this is a hack, so we warn. - &$exception(13, -"*** impending doom: IRT-ID overflows Perl precision; stubbed to $k\n"); - $i->{'in_reply_to_status_id_str'} = $k; - } - } - - # normalize geo. if this has a source and it has a - # favorited, then it is probably a tweet and we will - # add a stub geo hash if one doesn't exist yet. - if ($kludge_search_api_adjust || - ($i->{'favorited'} && $i->{'source'})){ - $i = &fix_geo_api_data($i); - } - - # hooray! this just tags it - if ($kludge_search_api_adjust) { - $i->{'class'} = "search"; - } - - # normalize newRTs - # if we get newRTs with -nonewrts, oh well - if (!$nonewrts && ($rt = $i->{'retweeted_status'})) { - # reconstruct the RT in a "canonical" format - # without truncation, but detco it first - $rt = &destroy_all_tco($rt); - $i->{'retweeted_status'} = $rt; - $i->{'text'} = - "RT \@$rt->{'user'}->{'screen_name'}" . ': ' . $rt->{'text'}; - } - - return &destroy_all_tco($i); -} - -# process the JSON data ... simplemindedly, because I just write utter crap, -# am not a professional programmer, and don't give a flying fig whether -# kludges suck or no. this used to be part of grabjson, but I split it out. -sub parsejson { - my $data = shift; - my $my_json_ref = undef; # durrr hat go on foot - my $i; - my $tdata; - my $seed; - my $bbqqmask; - my $ddqqmask; - my $ssqqmask; - - # test for single logicals - return { - 'ok' => 1, - 'result' => (($1 eq 'true') ? 1 : 0), - 'literal' => $1, - } if ($data =~ /^['"]?(true|false)['"]?$/); - - # first isolate escaped backslashes with a unique sequence. - $bbqqmask = "BBQQ"; - $seed = 0; - $seed++ while ($data =~ /$bbqqmask$seed/); - $bbqqmask .= $seed; - $data =~ s/\\\\/$bbqqmask/g; - - # next isolate escaped quotes with another unique sequence. - $ddqqmask = "DDQQ"; - $seed = 0; - $seed++ while ($data =~ /$ddqqmask$seed/); - $ddqqmask .= $seed; - $data =~ s/\\\"/$ddqqmask/g; - - # then turn literal ' into another unique sequence. you'll see - # why momentarily. - $ssqqmask = "SSQQ"; - $seed = 0; - $seed++ while ($data =~ /$ssqqmask$seed/); - $ssqqmask .= $seed; - $data =~ s/\'/$ssqqmask/g; - - # here's why: we're going to turn doublequoted strings into single - # quoted strings to avoid nastiness like variable interpolation. - $data =~ s/\"/\'/g; - - # and then we're going to turn the inline ones all back except - # ssqq, which we'll do last so that our syntax checker still works. - $data =~ s/$bbqqmask/\\\\/g; - $data =~ s/$ddqqmask/"/g; - - print $stdout "$data\n" if ($superverbose); - - # trust, but verify. I'm sure twitter wouldn't send us malicious - # or bogus JSON, but one day this might talk to something that would. - # in particular, need to make sure nothing in this will eval badly or - # run arbitrary code. that would really suck! - # first, generate a syntax tree. - $tdata = $data; - 1 while $tdata =~ s/'[^']*'//; # empty strings are valid too ... - $tdata =~ s/-?[0-9]+\.?[0-9]*([eE][+-][0-9]+)?//g; - # have to handle floats *and* their exponents - $tdata =~ s/(true|false|null)//g; - $tdata =~ s/\s//g; - - print $stdout "$tdata\n" if ($superverbose); - - # now verify the syntax tree. - # the remaining stuff should just be enclosed in [ ], and only {}:, - # for example, imagine if a bare semicolon were in this ... - if ($tdata !~ s/^\[// || $tdata !~ s/\]$// || $tdata =~ /[^{}:,]/) { - $tdata =~ s/'[^']*$//; # cut trailing strings - if (($tdata =~ /^\[/ && $tdata !~ /\]$/) - || ($tdata =~ /^\{/ && $tdata !~ /\}$/)) { - # incomplete transmission - &$exception(10, "*** JSON warning: connection cut\n"); - return undef; - } -# it seems that :[], or :[]} should be accepted as valid in the syntax tree -# since identica uses this as possible for null properties -# ,[], shouldn't be, etc. - if ($tdata =~ /(^|[^:])\[\]($|[^},])/) { # oddity - &$exception(11, "*** JSON warning: null list\n"); - return undef; - } - # at this point all we should have are structural elements. - # if something other than JSON structure is visible, then - # the syntax tree is mangled. don't try to run it, it - # might be unsafe. this exception was formerly uniformly - # fatal. it is now non-fatal as of 2.1. - if ($tdata =~ /[^\[\]\{\}:,]/) { - &$exception(99, "*** JSON syntax error\n"); - print $stdout <<"EOF" if ($verbose); ---- data received --- -$data ---- syntax tree --- -$tdata ---- JSON PARSING ABORTED DUE TO SYNTAX TREE FAILURE -- -EOF - return undef; - } - } - - # syntax tree passed, so let's turn it into a Perl reference. - # have to turn colons into ,s or Perl will gripe. but INTELLIGENTLY! - 1 while - ($data =~ s/([^'])'\s*:\s*(true|false|null|\'|\{|\[|-?[0-9])/\1\',\2/); - - # finally, single quotes, just before interpretation. - $data =~ s/$ssqqmask/\\'/g; - - # now somewhat validated, so safe (?) to eval() into a Perl struct - eval "\$my_json_ref = $data;"; - print $stdout "$data => $my_json_ref $@\n" if ($superverbose); - - # do a sanity check - if (!defined($my_json_ref)) { - &$exception(99, "*** JSON syntax error\n"); - print $stdout <<"EOF" if ($verbose); ---- data received --- -$data ---- syntax tree --- -$tdata ---- JSON PARSING FAILED -- -$@ ---- JSON PARSING FAILED -- -EOF - } - - return $my_json_ref; -} - -sub fix_geo_api_data { - my $ref = shift; - $ref->{'geo'}->{'coordinates'} = undef - if ($ref->{'geo'}->{'coordinates'} eq 'null' || - $ref->{'geo'}->{'coordinates'}->[0] eq '' || - $ref->{'geo'}->{'coordinates'}->[1] eq ''); - $ref->{'geo'}->{'coordinates'} ||= [ "undef", "undef" ]; - return $ref; -} - -sub is_fail_whale { - # is this actually the dump from a fail whale? - my $data = shift; - return ($data =~ m#<title>Twitter.+Over.+capacity.*</title>#i || - $data =~ m#[\r\l\n\s]*DB_DataObject Error: Connect failed#s); -} - -# {'errors':[{'message':'Rate limit exceeded','code':88}]} -sub is_json_error { - # is this actually a JSON error message? if so, extract it - my $data = shift; - if ($data =~ /(['"])(warning|errors?)\1\s*:\s*/s) { - if ($data =~ /^\s*\{/s) { # JSON object? - my $dref = &parsejson($data); - print $stdout "*** is_json_error returning true\n" - if ($verbose); - # support 1.0 and 1.1 error objects - return $dref->{'error'} if (length($dref->{'error'})); - return $dref->{'errors'}->[0]->{'message'} - if (length($dref->{'errors'}->[0]->{'message'})); - return (split(/\\n/, $dref->{'errors'}))[0] - if(length($dref->{'errors'})); - } - return $data; - } - return undef; -} - -sub backticks { - # more efficient/flexible backticks system - my $comm = shift; - my $rerr = shift; - my $rout = shift; - my $resource = shift; - my $data = shift; - my $dont_do_auth = shift; - my $buf = ''; - my $undersave = $_; - my $pid; - my $args; - - ($comm, $args, $data) = &$stringify_args($comm, $resource, - $data, $dont_do_auth, @_); - print $stdout "$comm\n$args\n$data\n" if ($superverbose); - if(open(BACTIX, '-|')) { - while(<BACTIX>) { - $buf .= $_; - } close(BACTIX); - $_ = $undersave; - return $buf; # and $? is still in $? - } else { - $in_backticks = 1; - &sigify(sub { - die( - "** user agent not honouring timeout (caught by sigalarm)\n"); - }, qw(ALRM)); - alarm 120; # this should be sufficient - if (length($rerr)) { - close(STDERR); - open(STDERR, ">$rerr"); - } - if (length($rout)) { - close(STDOUT); - open(STDOUT, ">$rout"); - } - if(open(FRONTIX, "|$comm")) { - print FRONTIX "$args\n"; - print FRONTIX "$data" if (length($data)); - close(FRONTIX); - } else { - die( - "backticks() failure for $comm $rerr $rout @_: $!\n"); - } - $rv = $? >> 8; - exit $rv; - } -} - -sub wherecheck { - my ($prompt, $filename, $fatal) = (@_); - my (@paths) = split(/\:/, $ENV{'PATH'}); - my $setv = ''; - - push(@paths, '/usr/bin'); # the usual place - @paths = ('') if ($filename =~ m#^/#); # for absolute paths - - print $stdout "$prompt ... " unless ($silent); - foreach(@paths) { - if (-r "$_/$filename") { - $setv = "$_/$filename"; - 1 while $setv =~ s#//#/#; - print $stdout "$setv\n" unless ($silent); - last; - } - } - if (!length($setv)) { - print $stdout "not found.\n"; - if ($fatal) { - print $stdout $fatal; - exit(1); - } - } - return $setv; -} - -sub screech { - print $stdout "\n\n${BEL}${BEL}@_"; - if ($is_background) { - kill 9, $parent; - kill 9, $$; - } elsif ($child) { - kill 9, $child; - kill 9, $$; - } - die("death not achieved conventionally"); -} - -# &in($x, @y) returns true if $x is a member of @y -sub in { my $key = shift; my %mat = map { $_ => 1 } @_; - return $mat{$key}; } - -sub descape { - my $x = shift; - my $mode = shift; - - $x =~ s#\\/#/#g; - - # try to do something sensible with unicode - if ($mode) { # this probably needs to be revised - $x =~ s/\\u([0-9a-fA-F]{4})/"&#" . hex($1) . ";"/eg; - } else { - # intermediate form if HTML entities get in - $x =~ s/\&\#([0-9]+);/'\u' . sprintf("%04x", $1)/eg; - - $x =~ s/\\u202[89]/\\n/g; - - # canonicalize Unicode whitespace - 1 while ($x =~ s/\\u(00[aA]0)/ /g); - 1 while ($x =~ s/\\u(200[0-9aA])/ /g); - 1 while ($x =~ s/\\u(20[25][fF])/ /g); - if ($seven) { - # known UTF-8 entities (char for char only) - $x =~ s/\\u201[89]/\'/g; - $x =~ s/\\u201[cCdD]/\"/g; - - # 7-bit entities (32-126) also ok - $x =~ s/\\u00([2-7][0-9a-fA-F])/chr(((hex($1)==127)?46:hex($1)))/eg; - - # dot out the rest - $x =~ s/\\u([0-9a-fA-F]{4})/./g; - $x =~ s/[\x80-\xff]/./g; - } else { - # try to promote to UTF-8 - &$utf8_decode($x); - - # Twitter uses UTF-16 for high code points, which - # Perl's UTF-8 support does not like as surrogates. - # try to decode these here; they are always back-to- - # back surrogates of the form \uDxxx\uDxxx - $x =~ -s/\\u([dD][890abAB][0-9a-fA-F]{2})\\u([dD][cdefCDEF][0-9a-fA-F]{2})/&deutf16($1,$2)/eg; - - # decode the rest - $x =~ s/\\u([0-9a-fA-F]{4})/chr(hex($1))/eg; - $x = &uforcemulti($x); - } - $x =~ s/\"/"/g; - $x =~ s/\'/'/g; - $x =~ s/\</\</g; - $x =~ s/\>/\>/g; - $x =~ s/\&/\&/g; - } - if ($newline) { - $x =~ s/\\n/\n/sg; - $x =~ s/\\r//sg; - } - return $x; -} - -# used by descape: turn UTF-16 surrogates into a Unicode character -sub deutf16 { - my $one = hex(shift); - my $two = hex(shift); - # subtract 55296 from $one to yield top ten bits - $one -= 55296; # $d800 - # subtract 56320 from $two to yield bottom ten bits - $two -= 56320; # $dc00 - - # experimentally, Twitter uses this endianness below (we have no BOM) - # see RFC 2781 4.3 - return chr(($one << 10) + $two + 65536); -} -sub max { return ($_[0] > $_[1]) ? $_[0] : $_[1]; } -sub min { return ($_[0] < $_[1]) ? $_[0] : $_[1]; } -sub prolog { my $k = shift; - return "" if (!scalar(@_)); - my $l = shift; return (&$k($l) . &$k(@_)); } -# this is mostly a utility function for /eval. it is a recursive descent -# pretty printer. -sub a { - my $w; - my $x; - return '' if(scalar(@_) < 1); - if(scalar(@_) > 1) { $x = "("; - foreach $w (@_) { - $x .= &a($w); - } - return $x."), "; - } - $w = shift; - if(ref($w) eq 'SCALAR') { return "\\\"". $$w . "\", "; } - if(ref($w) eq 'HASH') { my %m = %{ $w }; - return "\n\t{".&prolog(\&a, %m)."}, "; } - if(ref($w) eq 'ARRAY') { return "\n\t[".&prolog(\&a, @{ $w })."], "; } - return "\"$w\", "; -} -sub ssa { return (scalar(@_) ? ("('" . join("', '", @_) . "')") : "NULL"); } - -sub strim { my $x=shift; $x=~ s/^\s+//; $x=~ s/\s+$//; return $x; } - -sub wwrap { - return shift if (!$wrap); - - my $k; - my $klop = ($wrap > 1) ? $wrap : ($ENV{'COLUMNS'} || 79); - $klop--; # don't ask me why - my $lop; - my $buf = ''; - my $string = shift; - my $indent = shift; # for very first time with the prompt - my $needspad = 0; - my $stringpad = " " x 3; - - $indent += 4; # for the menu select string - - $lop = $klop - $indent; - $lop -= $indent; - W: while($k = length($string)) { - $lop += $indent if ($lop < $klop); - ($buf .= $string, last W) if ($k <= $lop && $string !~ /\n/); - ($string =~ s/^\s*\n//) && ($buf .= "\n", - $needspad = 1, - next W); - if ($needspad) { - $string = " $string"; - $needspad = 0; - } - # I don't know if people will want this, so it's commented out. - #($string =~ s#^(http://[^\s]+)# #) && ($buf .= "$1\n", - # next W); - ($string =~ s/^(.{4,$lop})\s/ /) && ($buf .= "$1\n", - next W); # i.e., at least one char, plus 3 space indent - ($string =~ s/^(.{$lop})/ /) && ($buf .= "$1\n", - next W); - warn - "-- pathologic string somehow failed wordwrap! \"$string\"\n"; - return $buf; - } - 1 while ($buf =~ s/\n\n\n/\n\n/s); # mostly paranoia - $buf =~ s/[ \t]+$//; - return $buf; -} - -# these subs look weird, but they're encoding-independent and run anywhere -sub uforcemulti { # forces multi-byte interpretation by abusing Perl - my $x = shift; - return $x if ($seven); - $x = "\x{263A}".$x; - return pack("${pack_magic}H*", substr(unpack("${pack_magic}H*",$x),6)); -} -sub ulength { my @k; return (scalar(@k = unpack("${pack_magic}C*", shift))); } -sub uhex { - # URL-encode an arbitrary string, even UTF-8 - # more versatile than the miniature one in &updatest - my $k = ''; - my $s = shift; - &$utf8_encode($s); - - foreach(split(//, $s)) { - my $j = unpack("H256", $_); - while(length($j)) { - $k .= '%' . substr($j, 0, 2); - $j = substr($j, 2); - } - } - return $k; -} - -# for t.co -# adapted from github.com/twitter/twitter-text-js/blob/master/twitter-text.js -# this is very hard to get right, and I know there are edge cases. this first -# one is designed to be quick and dirty because it needs to be fast more than -# it needs to be accurate, since T:RL:T calls it a LOT. however, it can be -# fooled, see below. -sub fastturntotco { - my $s = shift; - my $w; - - # turn domain names into http urls. this should look at .com, .net, - # .etc., but things like you.suck.too probably *should* hit this - # filter. this uses the heuristic that a domain name over some limit - # is probably not actually a domain name. - ($s =~ s#\b(([a-zA-Z0-9-_]\.)+([a-zA-Z]){2,})\b#((length($w="$1")>45)?$w:"http://$w")#eg); - - # now turn all http and https URLs into t.co strings - ($s =~ s#\b(https?)://[a-zA-Z0-9-_]+[^\s]*?('|\\|\s|[\.;:,!\?]\s+|[\.;:,!\?]$|$)#\1://t.co/1234567\2#gi); - return $s; -} -# slow t.co converter. this is for future expansion. -sub turntotco { - return &fastturntotco(shift); -} - -sub ulength_tco { - my $w = shift; - return &ulength(($notco) ? $w : &turntotco($w)); -} -sub length_tco { - my $w = shift; - return length(($notco) ? $w : &turntotco($w)); -} -# take a string and return up to $linelength CHARS plus the rest. -sub csplit { return &cosplit(@_, sub { return &length_tco(shift); }); } -# take a string and return up to $linelength BYTES plus the rest. -sub usplit { return &cosplit(@_, sub { return &ulength_tco(shift); }); } -sub cosplit { - # this is the common code for &csplit and &usplit. - # this is tricky because we don't want to split up UTF-8 sequences, so - # we let Perl do the work since it internally knows where they end. - my $orig_k = shift; - my $mode = shift; - my $lengthsub = shift; - my $z; - my @m; - my $q; - my $r; - - $mode += 0; - $k = $orig_k; - - # optimize whitespace - $k =~ s/^\s+//; - $k =~ s/\s+$//; - $k =~ s/\s+/ /g; - $z = &$lengthsub($k); - return ($k) if ($z <= $linelength); # also handles the trivial case - - # this needs to be reply-aware, so we put @'s at the beginning of - # the second half too (and also Ds for DMs) - $r .= $1 while ($k =~ s/^(\@[^\s]+\s)\s*// || - $k =~ s/^(D\s+[^\s]+\s)\s*//); # we have r/a, so while - $k = "$r$k"; - - my $i = $linelength; - $i-- while(($z = &$lengthsub($q = substr($k, 0, $i))) > $linelength); - $m = substr($k, $i); - - # if we just wanted split-on-byte, return now (mode = 1) - if ($mode) { - # optimize again in case we split on whitespace - $q =~ s/\s+$//; - $m =~ s/^\s+//; - return ($q, "$r$m"); - } - - # else try to do word boundary and cut even more - if (!$autosplit) { # use old mechanism first: drop trailing non-alfanum - ($q =~ s/([^a-zA-Z0-9]+)$//) && ($m = "$1$m"); - # optimize again in case we split on whitespace - $q =~ s/\s+$//; - return (&cosplit($orig_k, 1, $lengthsub)) - if (!length($q) && !$mode); - # it totally failed. fall back on charsplit. - if (&$lengthsub($q) < $linelength) { - $m =~ s/^\s+//; - return($q, "$r$m") - } - } - ($q =~ s/\s+([^\s]+)$//) && ($m = "$1$m"); - return (&cosplit($orig_k, 1, $lengthsub)) if (!length($q) && !$mode); - # it totally failed. fall back on charsplit. - return ($q, "$r$m"); -} - -### OAuth methods, including our own homegrown SHA-1 and HMAC ### -### no Digest:* required! ### -### these routines are not byte-safe and need a use bytes; before you call ### - -# this is a modified, deciphered and deobfuscated version of the famous Perl -# one-liner SHA-1 written by John Allen. hope he doesn't mind. -sub sha1 { - my $string = shift; - print $stdout "string length: @{[ length($string) ]}\n" - if ($showwork); - - my $constant = "D9T4C`>_-JXF8NMS^\$#)4=L/2X?!:\@GF9;MGKH8\\;O-S*8L'6"; - my @A = unpack('N*', unpack('u', $constant)); - my @K = splice(@A, 5, 4); - my $M = sub { # 64-bit warning - my $x; - my $m; - ($x = pop @_) - ($m=4294967296) * int($x / $m); - }; - my $L = sub { # 64-bit warning - my $n = pop @_; - my $x; - ((($x = pop @_) << $n) | ((2 ** $n - 1) & ($x >> 32 - $n))) & - 4294967295; - }; - my $l = ''; - my $r; - my $a; - my $b; - my $c; - my $d; - my $e; - my $us; - my @nuA; - my $p = 0; - $string = unpack("H*", $string); - - do { - my $i; - $us = substr($string, 0, 128); - $string = substr($string, 128); - $l += $r = (length($us) / 2); - print $stdout "pad length: $r\n" if ($showwork); - ($r++, $us .= "80") if ($r < 64 && !$p++); - my @W = unpack('N16', pack("H*", $us) . "\000" x 7); - $W[15] = $l * 8 if ($r < 57); - foreach $i (16 .. 79) { - push(@W, - &$L($W[$i - 3] ^ $W[$i - 8] ^ $W[$i - 14] ^ $W[$i - 16], 1)); - } - ($a, $b, $c, $d, $e) = @A; - foreach $i (0 .. 79) { - my $qq = ($i < 20) ? ($b & ($c ^ $d) ^ $d) : - ($i < 40) ? ($b ^ $c ^ $d) : - ($i < 60) ? (($b | $c) & $d | $b & $c) : - ($b ^ $c ^ $d); - $t = &$M($qq + $e + $W[$i] + $K[$i / 20] + &$L($a, 5)); - $e = $d; - $d = $c; - $c = &$L($b, 30); - $b = $a; - $a = $t; - } - @nuA = ($a, $b, $c, $d, $e); - print $stdout "$a $b $c $d $e\n" if ($showwork); - $i = 0; - @A = map({ &$M($_ + $nuA[$i++]); } @A); - } while ($r > 56); - my $x = sprintf('%.8x' x 5, @A); - @A = unpack("C*", pack("H*", $x)); - return($x, @A); -} - -# heavily modified from MIME::Base64 -sub simple_encode_base64 { - my $result = ''; - my $input = shift; - - pos($input) = 0; - while($input =~ /(.{1,45})/gs) { - $result .= substr(pack("u", $1), 1); - chop($result); - } - $result =~ tr|` -_|AA-Za-z0-9+/|; - my $padding = (3 - length($input) % 3) % 3; - $result =~ s/.{$padding}$/("=" x $padding)/e if ($padding); - - return $result; -} - -# from RFC 2104/RFC 2202 - -sub hmac_sha1 { - my $message = shift; - my @key = (@_); - my $opad; - my $ipad; - my $i; - my @j; - - # sha1 blocksize is 512, so key should be 64 bytes - -print $stdout " KEY HASH \n" if ($showwork); - ($i, @key) = &sha1(pack("C*", @key)) while (scalar(@key) > 64); - push(@key, 0) while(scalar(@key) < 64); - $opad = pack("C*", map { ($_ ^ 92) } @key); - $ipad = pack("C*", map { ($_ ^ 54) } @key); - -print $stdout " MESSAGE HASH \n" if ($showwork); - ($i, @j) = &sha1($ipad . $message); -print $stdout " FINAL HASH \n" if ($showwork); - $i = pack("C*", @j); # output hash is 160 bits - ($i, @j) = &sha1($opad . $i); - $i = &simple_encode_base64(pack("C20", @j)); - - return $i; -} - -# simple encoder for OAuth modified URL encoding (used for lots of things, -# actually) -# this is NOT UTF-8 safe -sub url_oauth_sub { - my $x = shift; - $x =~ s/([^-0-9a-zA-Z._~])/"%".uc(unpack("H*",$1))/eg; return $x; -} - -# default method of getting password: ask for it. only relevant for Basic Auth, -# which is no longer the default. -sub defaultgetpassword { - # original idea by @jcscoobyrs, heavily modified - my $k; - my $l; - my $pass; - - $l = "no termios; password WILL"; - if ($termios) { - $termios->getattr(fileno($stdin)); - $k = $termios->getlflag; - $termios->setlflag($k ^ &POSIX::ECHO); - $termios->setattr(fileno($stdin)); - $l = "password WILL NOT"; - } - print $stdout "enter password for $whoami ($l be echoed): "; - chomp($pass = <$stdin>); - if ($termios) { - print $stdout "\n"; - $termios->setlflag($k); - $termios->setattr(fileno($stdin)); - } - return $pass; -} - -# this returns an immutable token corresponding to the current authenticated -# session. in the case of Basic Auth, it is simply the user:password pair. -# it does not handle OAuth -- that is run by a separate wizard. -# the function then returns (token,secret) which for Basic Auth is token,undef. -# most of the time we will be using tokens in a keyfile, however, so this -# function runs in that case as a stub. -sub authtoken { - my @foo; - my $pass; - my $sig; - my $return; - my $tries = ($hold > 3) ? $hold : 3; - # give up on token if we don't get one - - return (undef,undef) if ($anonymous); - return ($tokenkey,$tokensecret) - if (length($tokenkey) && length($tokensecret)); - @foo = split(/:/, $user, 2); - $whoami = $foo[0]; - die("choose -user=username[:password], or -anonymous.\n") - if (!length($whoami) || $whoami eq '1'); - $pass = length($foo[1]) ? $foo[1] : &$getpassword; - die("a password must be specified.\n") if (!length($pass)); - return ($whoami, $pass); -} - -# this is a sucky nonce generator. I was looking for an awesome nonce -# generator, and then I realized it would only be used once, so who cares? -# *rimshot* -sub generate_nonce { unpack("H9000", pack("u", rand($$).$$.time())); } - -# this signs a request with the token and token secret. the result is undef if -# Basic Auth. payload should already be URL encoded and *sorted*. -# this is typically called by stringify_args to get authentication information. -sub signrequest { - - # this horrible kludge is needed to account for both 5.005, or for - # 5.6+ installs with no stdlibs and just a bare Perl, both of which - # we support. I hope Larry Wall will forgive me for messing with - # compiler internals next time I see him at church. - BEGIN { $^H |= 0x00000008 unless ($] < 5.006); } - - my $resource = shift; - my $payload = shift; - - # when we sign the initial request for an token, we obviously - # don't have one yet, so mytoken/mytokensecret can be null. - - my $nonce = &generate_nonce; - my @keybytes; - my $sig_base; - my $timestamp = time(); - return undef if ($authtype eq 'basic'); - - # stub for oAuth 2.0 - return undef if (!length($oauthkey) || !length($oauthsecret)); - - (@keybytes) = map { ord($_) } - split(//, $oauthsecret.'&'.$mytokensecret); - if (ref($resource) eq 'ARRAY' || length($payload)) { - # split into _a and _b payloads lexically - my $payload_a = ''; - my $payload_b = ''; - my $payload_c = ''; # this is for a special case - my $w; - my $aorb = 0; - my $verifier = ''; - my $method = "GET"; - my $url; - - if (length($payload)) { - $method = "POST"; - # this is a bit problematic since it won't be - # sorted. we'll deal with this as we need to. - if (ref($resource) eq 'ARRAY') { - $url = &url_oauth_sub($resource->[0]); - $payload .= "&" . $resource->[1]; - } else { - $url = &url_oauth_sub($resource); - } - } elsif (ref($resource) eq 'ARRAY') { - $url = &url_oauth_sub($resource->[0]); - $payload = $resource->[1]; - } else { - $url = &url_oauth_sub($resource); - } - - # this is pretty simplistic but it's really all we need. - # the exception is oauth_verifier: that has to be wormed - # into the middle, and we assume it's just that. - if ($payload !~ /^oauth_verifier/) { - foreach $w (split(/\&/, $payload)) { - $aorb = 1 if - ($w =~ /^[p-z]/ || $w =~ /^o[b-z]/); - $w = &url_oauth_sub("${w}&"); - if ($aorb) { - $payload_b .= $w; - } else { - $payload_a .= $w; - } - } - } else { - $payload_c = &url_oauth_sub($payload) . "%26"; - $payload_a = $payload_b = ''; - $payload =~ s/^oauth_verifier=//; - $verifier = ' oauth_verifier=\\"' . $payload . '\\",'; - } - $payload_b =~ s/%26$//; - $sig_base = $method . "&" . - $url . "&" . - (length($payload_a) ? $payload_a : ''). - "oauth_consumer_key%3D" . $oauthkey . "%26" . - "oauth_nonce%3D" . $nonce . "%26" . - "oauth_signature_method%3DHMAC-SHA1%26" . - "oauth_timestamp%3D" . $timestamp . "%26" . - (length($mytoken) ? - ("oauth_token%3D" . $mytoken . "%26") : '') . - $payload_c . - "oauth_version%3D1.0" . - (length($payload_b) ? ("%26" . $payload_b) : ''); - } else { - $sig_base = "GET&" . - &url_oauth_sub($resource) . "&" . - "oauth_consumer_key%3D" . $oauthkey . "%26" . - "oauth_nonce%3D" . $nonce . "%26" . - "oauth_signature_method%3DHMAC-SHA1%26" . - "oauth_timestamp%3D" . $timestamp . "%26" . - (length($mytoken) ? - ("oauth_token%3D" . $mytoken . "%26") : '') . - $payload_c . # could be part of it - "oauth_version%3D1.0" ; - } - print $stdout -"token-secret: $mytokensecret\nconsumer-secret: $oauthsecret\nsig-base: $sig_base\n" - if ($superverbose); - return ($timestamp, $nonce, - &url_oauth_sub(&hmac_sha1($sig_base, @keybytes)), - $verifier); -} - -# this takes a token request and "tries hard" to get it. -sub tryhardfortoken { - my $url = shift; - my $body = shift; - my $tries = shift; - my $rawtoken; - $tries ||= 3; - - while($tries) { - my $i; - $rawtoken = &backticks($baseagent, '/dev/null', undef, - $url, $body, 0, @wend); - print $stdout ("token = $rawtoken\n") - if ($superverbose); - my (@keyarr) = split(/\&/, $rawtoken); - my $got_token = ''; - my $got_secret = ''; - foreach $i (@keyarr) { - my $key; - my $value; - - ($key, $value) = split(/\=/, $i); - $got_token = $value if ($key eq 'oauth_token'); - $got_secret = $value if ($key eq 'oauth_token_secret'); - } - if (length($got_token) && length($got_secret)) { - print $stdout " SUCCEEDED!\n"; - return ($got_token, $got_secret); - } - print $stdout "."; - $tries--; - } - print $stdout " FAILED!: \"$rawtoken\"\n"; -die("unable to fetch token. here are some possible reasons:\n". - " - root certificates are not updated (see documentation)\n". - " - you entered your authentication information wrong\n". - " - your computer's clock is not set correctly\n" . - " - Twitter farted\n" . - "fix these possible problems, or try again later.\n"); - exit; -} |