#!/usr/bin/perl -s ######################################################################### # # Texapp v0.6 (c)2012-4 cameron kaiser (and contributors). # all rights reserved. # http://www.floodgap.com/software/texapp/ # # distributed under the floodgap free software license # http://www.floodgap.com/software/ffsl/ # # Oh Lord, stuck in Lodi again. -- Creedence Clearwater Revival # ######################################################################### 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 = "Texapp"; $Texapp_VERSION = "0.6"; $Texapp_PATCH_VERSION = 9; $Texapp_RC_NUMBER = 0; # non-zero for release candidate $current_rc_version = 2; # this is kludgy, yes. $LANG = $ENV{'LANG'} || $ENV{'GDM_LANG'} || $ENV{'LC_CTYPE'} || $ENV{'ALL'}; $my_version_string = "${Texapp_VERSION}.${Texapp_PATCH_VERSION}"; (warn ("$my_version_string\n"), exit) if ($version); $space_pad = " " x 8192; $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; $filtered = $lastfiltered = 0; $padded_patch_version = substr($Texapp_PATCH_VERSION . " ", 0, 2); %opts_boolean = map { $_ => 1 } qw( ansi noansi verbose superverbose texappistas noprompt seven silent hold daemon script readline ssl manualalsopost newline vcheck verify noratelimit notrack nonewrps notimeline synch exception_is_maskable mentions simplestart location readlinerepaint nocounter notifyquiet signals_use_posix dostream nostreamreplies streamallreplies nofilter personal allats savequit openappnettoo multiline ); %opts_sync = map { $_ => 1 } qw( ansi pause pmpause texappistas verbose superverbose globalurl homeurl notco noifttt chanurl chanbyidurl chansubbyidurl msbyidurl msbycidurl chanmsbyidurl url rlurl newline wrap notimeline lists queryurl track colourprompt colourme notrack colourpm colourreply colourwarn coloursearch colourlist idurl notifies filter colourdefault backload backtrack searchhits nostreamreplies mentions wtrendurl atrendurl filterusers filterats filterrps filteratonly filterflags filterclients nofilter colourfollow colouralien allats threads filterthreads ); %opts_urls = map {$_ => 1} qw( url chanurl uurl rurl wurl uidurl rlurl update shorturl globalurl homeurl chanbyidurl chanmsbyidurl chansubbyidurl msbyidurl msbycidurl streamurl streamsuburl apibase queryurl idurl delurl favsurl favurl favdelurl followurl leaveurl blockedurl credurl muteurl mutedelurl friendsurl blockurl blockdelurl modifyliurl adduliurl delliurl getliurl getlisurl getfliurl creliurl delliurl deluliurl crefliurl delfliurl getuliurl getufliurl rturl rpsofidurl statusliurl followliurl leaveliurl followersurl mutedurl oauthurl oauthauthurl oauthaccurl wtrendurl atrendurl favsofidurl intsofmeurl fridurl ); %opts_secret = map { $_ => 1} qw( superverbose texappistas ); %opts_comma_delimit = map { $_ => 1 } qw( lists notifytype notifies filterflags filterrps filterats filterusers filteratonly filterthreads threads dontautoreply ); %opts_space_delimit = map { $_ => 1 } qw( track ); %opts_can_set = map { $_ => 1 } qw( url pause chanurl pmpause superverbose ansi verbose globalurl homeurl notco noifttt chanbyidurl chanmsbyidurl chansubbyidurl msbyidurl msbycidurl update uurl rurl wurl avatar texappistas track rlurl noprompt shorturl newline wrap verify autosplit notimeline queryurl colourprompt colourme colourpm colourreply colourwarn coloursearch colourlist idurl urlopen delurl notrack favsurl openappnettoo favurl favdelurl slowpost notifies filter colourdefault colourfollow colouralien intsofmeurl blockedurl followurl leaveurl mentions backload blockurl blockdelurl lat long location searchhits muteurl mutedelurl woeid backtrack nocounter linelength friendsurl followersurl lists mutedurl modifyliurl adduliurl delliurl getliurl getlisurl getfliurl creliurl delliurl deluliurl crefliurl delfliurl atrendurl getuliurl getufliurl rturl rpsofidurl wtrendurl fridurl statusliurl followliurl leaveliurl nostreamreplies filterusers filterats filterrps filterflags alsopost manualalsopost filteratonly nofilter favsofidurl allats threads savequit filterclients filterthreads pmlength dontautoreply ); %opts_others = map { $_ => 1 } qw( curl seven silent maxhist noansi hold status daemon timestamp user anonymous script readline leader ssl rc norc rc_version vcheck apibase notifytype exts nonewrps synch runcommand bearertoken vcheckinterval credurl keyf readlinerepaint personal simplestart exception_is_maskable oldperl notify_tool_path oauthurl oauthauthurl oauthaccurl signals_use_posix dostream eventbuf streamallreplies ); %valid = (%opts_can_set, %opts_others); $rc = (defined($rc) && length($rc)) ? $rc : ""; $rcf = ''; $using_rc_file = 0; unless ($norc) { $rcf = # make this global, savestate will use it. ($rc =~ m#^/#) ? $rc : "$ENV{'HOME'}/.texapprc${rc}"; if (open(W, $rcf)) { # 5.14 sets this lazily, so this gives us a way out eval 'binmode(W, ":utf8")' unless ($seven); while() { 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); $using_rc_file = 1; } 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"); } } $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 Texapp is 5.8.6. Perl 5.005 thru 5.8.5 probably can still run Texapp, 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 .texapprc. bug patches will still be accepted for older Perls; see the Texapp home page for info. for Perl 5.005, remember to also specify -seven. EOF } # defaults that our extensions can override. these can be passed on # the command line, but we do NOT want them in .texapprc. $last_id ||= 0; $last_pm ||= 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'}/.texappkey"; $keyf = "$ENV{'HOME'}/.texappkey${keyf}" if ($keyf !~ m#/#); $attempted_keyf = $keyf; if (!length($bearertoken) && !$oauthwizard) { my $keybuf = ''; if(open(W, $keyf)) { while() { chomp; s/\s+//g; $bearertoken .= $_; } close(W); } 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 T@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 ("Texapp", \*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 $lastposted = ''; $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 ADN'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. Texapp 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 Texapp. run one of export PERL_SIGNALS=unsafe # sh, bash, ksh, etc. setenv PERL_SIGNALS unsafe # csh, tcsh, etc. and restart Texapp, 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 Texapp 2.x, or bad things will happen such as signal mismatches, unexpected quits, and dogs and cats living peacefully in the same house. EOF } # 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 $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 posts for the mini-menu (/th, foreground /pm) # leaving 50 posts for the foreground temporary menus $post_counter = 0; %pm_store_hash = (); %pm_context_hash = (); %pm_context_cache = (); $pm_counter = 0; %id_cache = (); %filter_next = (); # set up threading management $in_reply_to = 0; $expected_post_ref = undef; # interpret -script at this level if ($script) { $noansi = $noprompt = 1; $silent = ($verbose) ? 0 : 1; $pause = $vcheck = $slowpost = $verify = 0; $savequit = 0; } ### NO MORE AUTOMATIC MODIFICATION OF VARIABLES BEYOND THIS POINT ### ### now instantiate the Texapp 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 posttype conclude pmhandle pmconclude heartbeat precommand prepost postpost addaction eventhandle listhandle userhandle shutdown collectsave )) { 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 Texapp API and then # dispatch calls through the multi-module system instead. $multi_module_mode = 1; # mark as completed loader $handle = \&multihandle; $exception = \&multiexception; $posttype = \&multiposttype; $conclude = \&multiconclude; $pmhandle = \&multipmhandle; $pmconclude = \&multipmconclude; $heartbeat = \&multiheartbeat; $precommand = \&multiprecommand; $prepost = \&multiprepost; $postpost = \&multipostpost; $addaction = \&multiaddaction; $shutdown = \&multishutdown; $userhandle = \&multiuserhandle; $listhandle = \&multilisthandle; $eventhandle = \&multieventhandle; $collectsave = \&multicollectsave; } else { # the old API single-end-point system $multi_module_mode = 0; # not executing multi module endpoints $handle = \&defaulthandle; $exception = \&defaultexception; $posttype = \&defaultposttype; $conclude = \&defaultconclude; $pmhandle = \&defaultpmhandle; $pmconclude = \&defaultpmconclude; $heartbeat = \&defaultheartbeat; $precommand = \&defaultprecommand; $prepost = \&defaultprepost; $postpost = \&defaultpostpost; $addaction = \&defaultaddaction; $shutdown = \&defaultshutdown; $userhandle = \&defaultuserhandle; $listhandle = \&defaultlisthandle; $eventhandle = \&defaulteventhandle; $collectsave = \&defaultcollectsave; } # 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; } ### update the configuration file for the user *iff* ALL of the following: ### # - savequit is on # - there is no version key in the conf file or the version key is < current # issue a warning if there is a version key in the conf file < current # if neither case is true, nothing happens # this has to occur after the API is loaded so that extensions can intervene if ($using_rc_file) { unless ($savequit) { if (defined($rc_version) && $rc_version < $current_rc_version){ $bad_rc = "\n". "** your .texapprc is version $rc_version, current is $current_rc_version\n". "** some default settings or internal URLs may have changed\n". "** new features in this version of Texapp may not behave correctly\n". "** not automatically modifying it because you aren't using -savequit\n" . "** (restart with -savequit if you want this)\n" ."\n"; print $bad_rc unless ($silent); } } elsif (0+$rc_version < $current_rc_version) { $rc_version += 0; $bad_rc = "** your .texapprc is version $rc_version, automatically updating\n"; # cascade through the versions if ($rc_version < 1) { $bad_rc .= "** updating to version 1\n"; print $bad_rc unless ($silent); # fix track, force bearertoken out of rc file $queryurl = "${apibase}/posts/search" if ($queryurl eq "${apibase}/search/posts.json"); $rc_version = 1; } if ($rc_version < 2) { $bad_rc .= "** updating to version 2\n"; print $bad_rc unless ($silent); # remove oauthbase undef $oauthbase; # merge URLs foreach $k (keys %opts_urls) { my $w = $$k; next if (!length($w)); $w =~ s#^https://alpha-api.app.net/stream/0#https://api.app.net#; $$k = $w; } $rc_version = 2; } $bad_rc .= "** update completed successfully\n"; # done with cascade &savestate; } } # 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' && !length($status)) { # NOT $script! scripts have a use case for notifiers! %dupenet = (); foreach $nt (split(/\s*,\s*/, $notifytype)) { $fnt = ($nt =~ /^notifier_/) ? $nt : "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); @trackstrings = ($xtquery); } else { &tracktags_makearray; } # backtrack is dynamically set based on trackstrings $backtrack ||= &max(int(20 / &max(1, scalar(@tracktags))), 5) if (!defined($backtrack)); # zero is valid! # compile filterflags &filterflags_compile; # compile dontautoreply &dontautoreply_compile; # compile filters exit(1) if (!&filter_compile); $filterusers_sub = &filterlist_compile(undef, $filterusers); $filterrps_sub = &filterlist_compile(undef, $filterrps); $filteratonly_sub = &filterlist_compile(undef, $filteratonly); $filterthreads_sub = &filterlist_compile(undef, $filterthreads); exit(1) if (!&filterats_compile); exit(1) if (!&filterclients_compile); # compile lists exit(1) if (!&list_compile); # compile threads &threads_compile($threads, 0); # finally, compile notifies. we do this regardless of notifytype, so that # an extension can look at it if it wants to. ¬ify_compile; 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 # ADN only supports ssl $http_proto = 'https'; $savequit ||= 0; $vcheck ||= 0; $vcheckinterval ||= 0; if ($vcheckinterval && $vcheckinterval < 20) { warn("-- vcheckinterval too short; using default 86400s\n"); $vcheckinterval = 86400; } $lat ||= undef; $long ||= undef; $location ||= 0; $linelength ||= 256; $pmlength ||= 2048; $apibase ||= "${http_proto}://api.app.net"; #$apibase ||= "${http_proto}://alpha-api.app.net/stream/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; # backtrack is set after tracked terms are compiled $globalurl ||= "${apibase}/posts/stream/global"; $homeurl ||= "${apibase}/posts/stream"; $url ||= (($personal) ? $homeurl : $globalurl); $credurl ||= "${apibase}/token"; $update ||= "${apibase}/posts"; $thurl ||= "${apibase}/posts/%I/replies"; $rurl ||= "${apibase}/users/%U/mentions"; $uurl ||= "${apibase}/users/%U/posts"; $idurl ||= "${apibase}/posts/%I"; $delurl ||= "${apibase}/posts/%I"; # using wdnd $wurl ||= "${apibase}/users/%U"; $uidurl ||= "${apibase}/users/"; # see get_user $followurl ||= "${apibase}/users/%U/follow"; $leaveurl ||= "${apibase}/users/%U/follow"; # using wdnd $blockurl ||= "${apibase}/users/%U/block"; $blockdelurl ||= "${apibase}/users/%U/block"; # using wdnd $blockedurl = "${apibase}/users/me/blocked"; $muteurl ||= "${apibase}/users/%U/mute"; $mutedelurl ||= "${apibase}/users/%U/mute"; # using wdnd $mutedurl ||= "${apibase}/users/me/muted"; $friendsurl ||= "${apibase}/users/%U/following"; $followersurl ||= "${apibase}/users/%U/followers"; $fridurl ||= "${apibase}/users/%U/following/ids"; $favsurl ||= "${apibase}/users/%U/stars"; $favurl ||= "${apibase}/posts/%I/star"; $favdelurl ||= "${apibase}/posts/%I/star"; # with wdnd $favsofidurl ||= "${apibase}/posts/%I/stars"; # not supported yet # $rlurl ||= "${apibase}/application/rate_limit_status.json"; # not supported yet # $rpurl ||= "${apibase}/posts/%I/repost"; $rpsofidurl ||= "${apibase}/posts/%I/reposters"; $intsofmeurl ||= "${apibase}/users/me/interactions"; # channels, channel messages and pms/PMs $chanurl ||= "${apibase}/channels"; $chanbyidurl ||= "${apibase}/channels/%I"; $chanmsbyidurl ||= "${apibase}/channels/%I/messages"; # also POST $chansubbyidurl ||= "${apibase}/channels/%I/subscribe"; # also DELETE $msbyidurl ||= "${apibase}/channels/messages"; $msbycidurl ||= "${apibase}/channels/%U/messages/%I"; # also DELETE # %U in this case is the cid # ^^ see http://developers.app.net/docs/resources/message/lifecycle/ # not supported yet # $getlisurl ||= "${apibase}/lists.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"; # not supported yet # $streamurl ||= ($anonymous) # this doesn't actually work yet. ? "YOU_GOTTA_BE_CRAZY_GOTTA_HAVE_A_REAL_NEED" : "https://stream-channel.app.net/stream/user?auto_delete=1&include_html=0"; $streamsuburl ||= "${apibase}/posts/stream/unified"; $dostream ||= 0; $eventbuf ||= 0; $queryurl ||= "${apibase}/posts/search"; # not supported yet # $wtrendurl ||= "${apibase}/trends/"; $atrendurl ||= "${apibase}/trends/available.json"; # not supported yet # # 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'; $openappnettoo ||= 0; $alsopost ||= ""; $manualalsopost ||= 0; $hold ||= 0; $daemon ||= 0; $maxhist ||= 19; $maxhold ||= 500; undef $shadow_history; $timestamp ||= 0; $noprompt ||= 0; $slowpost ||= 0; $twarg ||= undef; $verbose ||= $superverbose; $pmpause = 3 if (!defined $pmpause); # NOT ||= ... zero is a VALID value! $pmpause = 0 if ($anonymous); $pmpause = 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; $pmpause = ($pmpause) ? 1 : 0; } $pmcount = $pmpause; $lastshort = undef; # ANSI sequences $colourprompt ||= "CYAN"; $colourme ||= "YELLOW"; $colourpm ||= "GREEN"; $colourreply ||= "RED"; $colourwarn ||= "MAGENTA"; $coloursearch ||= "CYAN"; $colourfollow ||= "OFF"; $colouralien ||= "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 our user agent if (length($curl) > 1 && -x "/$curl") { $wend = $curl; print $stdout "cURL forced to $wend\n"; } else { $wend = &wherecheck("trying to find cURL", "curl", "you must have cURL installed to use Texapp.\n"); } $baseagent = $wend; ##### TEXAPP OVERRIDES ##### # these overrides set options we know will work/force options off that don't # $pause = 20 if ($pause eq 'auto'); $nostream = 1; # # these overrides set options we know will work/force options off that don't ##### TEXAPP OVERRIDES ##### # streaming API has multiple prereqs. not fatal; we just fall back on the # REST API if not there. # not yet supported if(0) { unless($status) { if (!$dostream || $script || $anonymous || $synch) { $reason = (!$dostream) ? "(no -dostream)" : ($script) ? "(-script)" : ($anonymous) ? "(-anonymous)" : ($synch) ? "(-synch)" : "(it's funkatron's fault)"; print $stdout "-- User Streams disabled $reason (Texapp will use JSON API only)\n"; $dostream = 0; } else { print $stdout "-- User Streams enabled\n"; # streams change mentions behaviour; we get them automatically. # warn the user if the current settings are suboptimal. #TODO # evaluate this 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 $simple_agent = "$baseagent -s -m 20"; @wend = ('-s', '-m', '20', '-A', "Texapp/$Texapp_VERSION", '-H', 'Expect:'); @wind = @wend; @wdnd = (@wend, '-X', 'DELETE'); @wend = (@wend, '-X', 'POST'); @wjnd = (@wend, '-H', '"Content-Type: application/json"'); $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 unless ($dont_do_auth) { $l .= "-H \"Authorization: Bearer $bearertoken\"\n"; } # if resource is an arrayref, then it's a GET with URL # and args (mostly generated by &grabjadn) $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, 1); } 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 if (!length($bearertoken)) { # 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 TOKEN (run Texapp 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 Texapp: Authorize Texapp by signing into ADN with OAuth |||| +----------------------------------------------------------------------------+ Looks like you're starting Texapp for the first time, and/or creating a keyfile. Welcome to the most user-hostile, highly obfuscated, spaghetti code infested and obscenely obscure ADN client that's out there. You'll love it. Texapp generates a keyfile that contains credentials for you, including your access token. This needs to be done JUST ONCE. You can take this keyfile with you to other systems. If you revoke Texapp'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 Texapp; 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 = ; print $stdout <<"EOF"; 1. Visit, in your browser, ALL ON ONE LINE, https://alpha.app.net/oauth/authenticate?client_id=35UhKXbTqxmE7Hs427haVuRVB8FGzhtx&response_type=token&redirect_uri=http%3a%2f%2fwww.floodgap.com%2fsoftware%2ftexapp%2fcallback&scope=stream+email+write_post+follow+messages 2. If you are not already signed in, fill in your username and password. 3. Verify that Texapp is the requesting application, and that its permissions are as you expect (see basic information, read your stream, send and receive private messages, create posts, add and remove follows, and see your E-mail address). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW! 4. Click Authorize. 5. A bearer token will appear. Paste it below: EOF $j = ''; print $stdout "Token> "; chomp($j = ); open(W, ">$keyf") || die("Failed to write keyfile $keyf: $!\n"); print W "$j\n"; close(W); chmod(0600, $keyf) || print $stdout "Warning: could not change permissions on $keyf : $!\n"; print $stdout <<"EOF"; Written keyfile $keyf Now, restart Texapp to use this keyfile. (To choose between multiple keyfiles other than the default .texappkey, tell Texapp where the key is using -keyf=... .) EOF exit; } # 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 '-') { my @status; if ($multiline) { while() { push(@status, $_); } $status = join('', @status); } else { chomp(@status = ); $status = join("\n", @status); } } for(;;) { $rv = 0; die( "sorry, you can't post anonymously. use an authenticated username.\n") if ($anonymous && length($status)); $error = ($multiline) ? "or don't use -multiline.\n" : "or use -autosplit={word,char,cut}.\n"; $autosplit = 0 if ($multiline); die( "sorry, status too long: reduce by @{[ length($status)-$linelength ]} chars, ". $error) if (length($status) > $linelength && !$autosplit); unless ($multiline) { ($status, $next) = &csplit($status, ($autosplit eq 'char' || $autosplit eq 'cut') ? 1 : 0, $linelength) if (!length($next)); } else { $next = ''; } if ($autosplit eq 'cut' && length($next)) { print "-- warning: input autotrimmed to $linelength bytes\n"; $next = ""; } if (!length($whoami) && !length($status)) { # we must be using OAuth tokens. we'll need # to get our screen name from ADN. 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); print $stdout $data if ($superverbose); } 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 ($rv == 96 || $rv == 97 || $rv == 99) { print "post CANCELLED!\n"; exit(1); } elsif (&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('IGNORE', qw(USR1 PWR XCPU)); if (length($credentials)) { print "-- processing credentials: "; $my_json_ref = &parsejson($credentials); $whoami = lc($my_json_ref->{'data'}->{'user'}->{'username'}); $whoamid = $my_json_ref->{'data'}->{'user'}->{'id'}; 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 ${EM}$whoami${OFF}\n"; } $connection_id = "${whoami}-${whoamid}-$$"; $feedwhere = ($url eq $homeurl) ? "-- you are viewing your ${EM}personal stream${OFF} (${EM}/global${OFF} for global)\n" : "-- you are viewing the ${EM}global feed${OFF} (${EM}/personal${OFF} for personal stream)\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; $pmcount = 1 if ($pmpause); # force fetch $is_background = 1; DAEMONLOOP: for(;;) { my $snooze; my $nfound; my $wake; &$heartbeat; &update_effpause; &refresh(0); $dont_refresh_first_time = 0; if ($pmpause) { if (!--$pmcount) { &pmrefresh(0); $pmcount = $pmpause; } } # 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) { $V = "${Texapp_VERSION}.${padded_patch_version}"; $e = <<'EOF'; ${RED} /\ /\${OFF} ${CYAN}################################################################${OFF} ${RED}/ ${YELLOW}M${RED}\ /${YELLOW}M${RED} \ ${CYAN}#${OFF} ${EM}texapp ${V} (c)2014 cameron kaiser${OFF} ${CYAN}#${OFF} ${RED}\ ${YELLOW}MM${RED}\ /${YELLOW}MM${RED} / ${CYAN}#${OFF} ${CYAN}#${OFF} ${RED} \ ${YELLOW}MM${RED}\/${YELLOW}MM${RED} / ${CYAN}#${OFF} based on TTYtter 2.1 - all rights reserved. ${CYAN}#${OFF} ${RED} \ ${YELLOW}MMMM${RED} / ${CYAN}#${OFF} freeware under the Floodgap Free Software License ${CYAN}#${OFF} ${RED} \ ${YELLOW}MM${RED} / ${CYAN}#${OFF} ${CYAN}#${OFF} ${RED} \ / ${CYAN}#${OFF} post comments to ${EM}@doctorlinguist${OFF} -or- ${EM}ckaiser@floodgap.com${OFF} ${CYAN}#${OFF} ${RED}\/ ${CYAN}###########${OFF} ${EM}http://www.floodgap.com/software/texapp/${OFF} ${CYAN}###########${OFF} # # when ready, hit RETURN/ENTER for a prompt. # type /help for commands or /quit to quit. # starting background monitoring process. # EOF $e =~ s/\$\{([A-Z]+)\}/${$1}/eg; print $stdout $e; } else { print <<"EOF"; Texapp ${Texapp_VERSION}.${padded_patch_version} (c)2014 cameron kaiser all rights reserved. freeware under the floodgap free software license. http://www.floodgap.com/software/ffsl/ post me: \@doctorlinguist * 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); } # XXX: consider forking this $pmchecked = 0; $last_pm_req = &pmscan(-1); #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) ? "" : "Texapp> "; my $rvl = ($noprompt) ? 0 : 8; 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; return; } @history = (); print C "rsga---------------\n"; $dont_use_counter = $nocounter; eval '$termrl->hook_no_counter'; if ($termrl) { # only have the repaint handler on while we're in readline. &sigify(\&repaint, qw(USR1 PWR XCPU)); while(defined ($_ = $termrl->readline((&$prompt(1))[0]))) { # ignore repaints now &sigify("IGNORE", qw(USR1 PWR XCPU)); 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' } # reenable them before we go back to readline &sigify(\&repaint, qw(USR1 PWR XCPU)); } # done with input from readline, no more repainting &sigify("IGNORE", qw(USR1 PWR XCPU)); } else { # ASSERT NO NEW SIGNAL HANDLERS! &$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); } if ($savequit) { print $stdout "** autosaving "; &savestate; } } # 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)); # temporarily ignore these signals &sigify("IGNORE", qw(USR1 PWR XCPU USR2 SYS UNUSED XFSZ)); 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; }; } sub s { if ($is_background) { push(@stream_buf, [ @_ ]); } else { my $aa = $_[0]; print $aa "$_[1]"; } } sub std { &s($stdout, @_); } sub sto { &s($streamout, @_); } # start the background process # this has to be last or the background process can't see the full API &sigify(sub { $background_is_ready++ }, qw(USR2 SYS UNUSED XFSZ)); 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 until ($background_is_ready); # disengage the signal handler, we don't need it anymore &sigify("IGNORE", qw(USR2 SYS UNUSED XFSZ)); # 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' || /^Texapp>/ || $_ eq 'ls' || $_ eq '?' || m#^help /# || $_ eq 'exit')) { &add_history($_); unless ($_ eq 'exit' || /^Texapp>/ || $_ 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 post \"$_\"?\n"; } print $stdout "*** to post 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/^\%RP\%/$repost/ || s/\%RP\%$/$repost/); # (%ED% and %EDRP% are handled by updatest) # and escaped history s/^\\\%/%/; if ($i) { print $stdout "(expanded to \"$_\")\n" ; $in_reply_to = $expected_post_ref->{'id'} || 0 if (defined $expected_post_ref && ref($expected_post_ref) eq 'HASH'); } else { $expected_post_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($_))); # generically extract < parameters for leadpost/before, but not # for commands where they may be valid $lead_id = 0; $lead_kind = ''; $lead_code = ''; if (m#^/# && !m#^//# && !m#^/me\s+#i && # /re {'id'}; $lead_kind = 'pm'; $lead_code = $code; print $stdout "-- before (pm): $lead_id\n" if ($verbose); } else { print $stdout "*** no PM with that ID (yet?): $code\n"; return 0; } } else { my $leadpost = &get_post($code); if (defined($leadpost) && ref($leadpost) eq 'HASH') { $lead_id = $leadpost->{'id'}; $lead_kind = 'post'; $lead_code = $code; print $stdout "-- before (post): $lead_id\n" if ($verbose); } else { print $stdout "*** no post with that ID (yet?): $code\n"; return 0; } } } elsif (s#\s+\<([pP]?)([0-9]+)(\s|$)#\3#i) { # don't use get_post on IDs; wasteful and slow. just # use the raw code. my $id = 0+$2; my $lk = ($1 eq 'p' || $1 eq 'P') ? 'pm' : 'post'; my $co = "$1$2"; if ($id) { $lead_id = $id; $lead_code = $co; $lead_kind = $lk; } else { print $stdout "*** nonsense ID passed\n"; return 0; } } } #TODO # countmaybe should work like this too #### # # add commands here # #### # manual alsopost if (length($alsopost) && s#^/(alsopost|also|ap)\s+## && length) { if (!$manualalsopost) { &std("*** you already automatically alsopost\n"); &std("*** to change that, /set manualalsopost\n"); return 0; } $manualalsopost = 0; $rv = &updatest($_, 1); $manualalsopost = 1; return 0; } # dumper if (m#^/du(mp)?(f?) ([zZ]?[a-zA-Z]?[0-9]+)$#) { my $mode = lc($2); my $code = lc($3); unless ($code =~ /^[pP][zZ]?[a-zA-Z]?[0-9]+$/ # this is a PM. && $code !~ /^p[0-9]$/) { # this is legal. $oldsuperverbose = $superverbose; $oldverbose = $verbose; $superverbose = $verbose = 1 if ($mode eq 'f'); my $post = &get_post($code); $superverbose = $oldsuperverbose; $verbose = $oldverbose; my $k; my $sn; my $id; my @superfields = ( [ "user", "username" ], # must always be first [ "repost_of", "id" ], [ "repost_of", "thread_id" ], [ "_texapp_tag", "type" ], [ "_texapp_tag", "payload" ], [ "source", "name" ], ); my $superfield; if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } foreach $superfield (@superfields) { my $sfn = join('->', @{ $superfield }); my $sfk = "{'" . join("'}->{'", @{ $superfield }) . "'}"; my $sfv; eval "\$sfv = &descape(\$post->$sfk);"; print $streamout substr("$sfn ", 0, 25). " $sfv\n"; $sn = $sfv if (!length($sn) && length($sfv)); } foreach $k (sort keys %{ $post }) { next if (ref($post->{$k})); print $streamout substr("$k ", 0, 25) . " " . &descape($post->{$k}) . "\n"; } # include a URL to the post per T@augmentedfourth $urlshort = "${http_proto}://alpha.app.net/$sn/post/$post->{'id'}"; print $stdout "-- %URL% is now $urlshort (/short to shorten)\n"; return 0; } # if Pxxxx, fall through to the below. } # PM dumper if (m#^/du(mp)?(f?) ([pP][zZ]?[a-zA-Z]?[0-9]+)$#) { my $mode = lc($2); my $code = lc($3); $oldsuperverbose = $superverbose; $oldverbose = $verbose; $superverbose = $verbose = 1 if ($mode eq 'f'); my $pm = &get_pm($code); $superverbose = $oldsuperverbose; $verbose = $oldverbose; my $k; my $sn; my $id; my @superfields = ( [ "user", "username" ], # must always be first [ "source", "name" ], ); my $superfield; if (!defined($pm) || ref($pm) ne 'HASH') { print $stdout "-- no such PM (yet?): $code\n"; return 0; } my $context = undef; # only fetch the context if we know we generated this, # because otherwise we start doing ugly dereferencing. $oldsuperverbose = $superverbose; $oldverbose = $verbose; $superverbose = $verbose = 1 if ($mode eq 'f'); $context = &get_pm_context($code) unless (!defined($pm->{'_texapp_menu_select'})); $superverbose = $oldsuperverbose; $verbose = $oldverbose; foreach $superfield (@superfields) { my $sfn = join('->', @{ $superfield }); my $sfk = "{'" . join("'}->{'", @{ $superfield }) . "'}"; my $sfv; eval "\$sfv = &descape(\$pm->$sfk);"; print $streamout substr("$sfn ", 0, 25). " $sfv\n"; $sn = $sfv if (!length($sn) && length($sfv)); } foreach $k (sort keys %{ $pm }) { next if (ref($pm->{$k})); print $streamout substr("$k ", 0, 25) . " " . &descape($pm->{$k}) . "\n"; } # if we didn't generate this, there is no context to iterate. return 0 if (!defined($context)); print $streamout "\n_texapp_context\n---------------\n"; # this is a synthetic object we generate, so we don't need to # be quite so paranoid. foreach $k (sort keys %{ $context }) { $m = $context->{$k}; print $streamout substr("$k ", 0, 25) . " "; if (ref($m) eq 'ARRAY') { print $streamout join(" ", @{ $m }), "\n"; } else { print $streamout "$m\n"; } } return 0; } # evaluator if (m#^/ev(al)?(f?) (.+)$#) { my $exp = $3; my $mode = lc($2); $oldsuperverbose = $superverbose; $oldverbose = $verbose; $superverbose = $verbose = 1 if ($mode eq 'f'); $k = eval $exp; $superverbose = $oldsuperverbose; $verbose = $oldverbose; print $stdout "==> "; print $streamout "$k $@\n"; return 0; } # save state if ($_ eq '/save') { &savestate; return 0; } # toggle background if ($_ eq '/hold') { if ($synch) { &std("-- huh? you're already in -synch mode\n"); } else { &hold; } return 0; } # flush tab completer. if a parameter is given, flush back to # totally empty, otherwise loaded default. if (s#^/flushtab\s*##) { if (!$termrl) { &std("-- readline is not enabled\n"); return 0; } %readline_completion = (!length) ? %original_readline : (); &std("-- flushed user name TAB completion to ". ((!length) ? "originally specified" : "totally blank"). "\n"); &std("-- to print current contents: /p tabcomp\n"); return 0; } # swap timelines if ($_ eq '/global') { if (&getvariable('url') eq $globalurl) { print $stdout "-- already viewing global feed\n"; return 0; } print $stdout "-- switching to global timeline\n"; &setvariable('url', $globalurl); print $stdout "-- flushing cache\n"; $_ = "/again"; # and fall through } if ($_ eq '/personal') { if (&getvariable('url') eq $homeurl) { print $stdout "-- already viewing personal feed\n"; return 0; } print $stdout "-- switching to personal timeline\n"; &setvariable('url', $homeurl); print $stdout "-- flushing cache\n"; $_ = "/again"; # and fall through } # version check if (m#^/v(ersion)?check$# || m#^/u(pdate)?check$#) { print $stdout &updatecheck(1, 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) { print $stdout "*** current TAB-comp entries: "; $did_print = 0; foreach(keys %readline_completion) { $did_print = 1; print $stdout "$_ "; } print $stdout "(none)" if (!$did_print); print $stdout "\n"; } else { print $stdout "*** readline isn't on\n"; } } elsif ($key eq 'otabcomp') { 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 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 = "text=$kw" if ($kw !~ /^q=/); my $r = &grabjadn("$queryurl?$kw", 0, 0, $countmaybe, { "type" => "search", "payload" => $kw }, 1, $lead_id); if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })) { &dt_tdisplay($r, 'search'); } else { print $stdout "-- sorry, no results were found.\n"; } 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; } # trends # NOT SUPPORTED if(0) { if (s#^/tre(nds)?\s*##) { my $t; my $wwoeid = (length) ? $_ : $woeid; $wwoeid ||= "1"; my $r = &grabjadn("${wtrendurl}${wwoeid}.json", 0, 0, 0, undef, 1); my $fr = ($wwoeid && $wwoeid ne '1') ? " FOR WOEID $wwoeid" : ' GLOBALLY'; if (defined($r) && ref($r) eq 'HASH') { $t = $r->{'trends'}; } elsif (defined($r) && ref ($r) eq 'ARRAY') { $t = $r->[0]->{'trends'}; } if (defined($t) && (ref($t) eq 'HASH' || ref($t) eq 'ARRAY')) { my $i; my $j; print $stdout "${EM}<<< TRENDING TOPICS${fr} >>>${OFF}\n"; # this is moderate paranoia if (ref($r) eq 'HASH') { # this is the old behaviour. it will be removed. foreach $i (sort { $b cmp $a } keys %{ $t }) { foreach $j (@{ $t->{$i} }) { my $k = &descape($j->{'query'}); 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"; } last; # emulate old trends/current behaviour } } else { 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 = &grabjadn("$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 = &grabjadn( "${statusliurl}?owner_username=${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 } # reply-to based threading if (m#^/re(ply)?th(read)?\s+(\+\d+\s+)?([zZ]?[a-zA-Z]?[0-9]+)$#) { print $stdout "-- < parameter meaningless for /replythread\n" if ($lead_id); my $countmaybe = $3; my $code = lc($4); my $post = &get_original_post($code); my $array_ref = [ ]; my $id = $post->{'id'}; if (!defined($post) || !length($id)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } $countmaybe = (0+$countmaybe) || 10; # follow reply links back until we get to countmaybe while ($countmaybe-- && length($id)) { push(@{ $array_ref }, $post = &get_original_post($id)); $id = $post->{'reply_to'}; } &dt_tdisplay($array_ref, 'thread', 0, $id); return 0; } # thread-id based threading # /th {'id'}) { print $stdout "-- no such post (yet?): $code\n"; return 0; } my $id; my $insert; if ($post->{'repost_of'}->{'id'}) { # stick this into the thread as if it were threaded, # but fetch the reposted post instead. $id = $post->{'repost_of'}->{'id'}; $insert = $post; } else { $id = $post->{'id'}; $insert = undef; } my $json_ref = &grabjadn(&urlp( ($thurl . (($moded =~ /m/) ? "?include_muted=1" : '')) ,,$id),0,0,$countmaybe, { "type" => "thread", "payload" => $id }, 1, $lead_id); if ($json_ref && ref($json_ref) eq 'ARRAY') { unshift(@{ $json_ref }, $insert) if ($insert); } &dt_tdisplay($json_ref, 'thread', 0, $id); if ($moded =~ /af/) { # /thaf or /thmaf $_ = "/thf $code"; # and fall through } else { return 0; } } } if (m#^/th(read)?unb(lock)?\s*all$#) { $_ = "/unset filterthreads"; # and fall through } if (m#^/th(read)?(un)?b(lock)?\s+([zZ]?[a-zA-Z]?[0-9]+)$#) { my $mode = lc($2); my $code = lc($4); my $post = &get_original_post($code); if (!defined($post) || !$post->{'id'}) { print $stdout "-- no such post (yet?): $code\n"; return 0; } my $id = $post->{'thread_id'} || $post->{'id'}; $_ = ($mode eq 'un') ? "/del" : "/add"; $_ .= " filterthreads $id"; # and fall through } if (m#^/th(read)?f(ollow)?\s+([zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($3); my $post = &get_original_post($code); if (!defined($post) || !$post->{'id'}) { print $stdout "-- no such post (yet?): $code\n"; return 0; } &add_thread($post->{'thread_id'} || $post->{'id'}, 1); return 0; } if (m#^/th(read)?unf(ollow)?\s*all$#) { $_ = "/unset threads"; # and fall through } if (m#^/th(read)?unf(ollow)?\s+([zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($3); my $post = &get_original_post($code); if (!defined($post) || !$post->{'id'}) { print $stdout "-- no such post (yet?): $code\n"; return 0; } $_ = "/del threads ".($post->{'thread_id'} || $post->{'id'}); # and fall through } # PM threading (alias /th on a PM to /pma) if (m#^/th(read)?\s+(\+\d+\s+)?([pP][zZ]?[a-zA-Z]?[0-9]+)$#) { $_ = "/pma $2$3"; # and fall through } # 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//); } $old = '' if ($old eq $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 POST!! posts right ;AAAAAAAAAAAAAAAAAAAAAAAO; ================== away (or tells JUST TYPE TO TALK! you if there is nothing new) MOST TTYtter COMMANDS DO WORK! ============ by thumping ============================== REMEMBER the background /re menucode: reply ============ process. example: /re a5 excellent MANY COMMANDS AND /url menucode: open URLs ALL POSTS ARE /again /th menucode: thread ASYNCHRONOUS! displays most recent /rp menucode: repost They might not posts, both old and /whois: query a user respond new. /mute: mute a user immediately! AND MANY MORE! /replies ================== shows replies and mentions. USE + FOR A COUNT: /re +30 => last 30 replies /quit resumes your boring life. ========================== EOF &linein("PRESS RETURN/ENTER>"); print $stdout <<"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/texapp/ Texapp $Texapp_VERSION is (c)2014 cameron kaiser + contributors. all rights reserved. this software is offered AS IS, with no guarantees. it is not endorsed by App.net or their executive staff or operators. send your suggestions to me at ckaiser\@floodgap.com or https://alpha.app.net/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 4 5 6 7 8 9 0 1 2 3 4 5....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....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....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 ($lead_kind eq 'pm') { print $stdout "-- illogical: 999) { print $stdout "-- greedy bastard, try +fewer.\n"; return 0; } print $stdout "-- background request sent\n" unless ($synch); print C substr("R${countmaybe},${lead_id}------------------", 0, 19)."\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); if ($lead_kind eq 'pm') { print $stdout "-- illogical: {'username'})) { my $sturl = undef; my $purl = &descape($my_json_ref->{'avatar_image'}->{'url'}); if ($avatar && length($purl)) { 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'}->{'text'})) ]}\"\n") if (length(&strim($my_json_ref->{'description'}->{'text'}))); print $streamout "\n"; unless ($whoami eq $uname) { print $streamout &wwrap( "${EM}Do you follow${OFF} this user? ... ${EM}$my_json_ref->{'you_follow'}${OFF}\n"); print $streamout &wwrap( "${EM}Does this user follow${OFF} you? ... ${EM}$my_json_ref->{'follows_you'}${OFF}\n"); print $streamout "\n"; } } return 0; } # two-argument doesfollow if (m#^/(df|doesfollow)\s+\@?([^\s]+)$#) { if ($anonymous) { print $stdout "-- who follows anonymous anyway?\n"; return 0; } my $uname = $2; $_ = "/doesfollow $2 $whoami"; print $stdout "*** assuming you meant: $_\n"; # fetch the user object and ask it for follows_you print $stdout "-- synchronous /doesfollow command for $uname\n" if ($verbose); my $uid = &get_user($uname); if (!length($uid)) { print $stdout "-- could not find user $uname\n"; return 0; } $readline_completion{'@'.$uname}++ if ($termrl); my $my_json_ref = &grabjadn(&urlp($wurl, $uid), 0, 0, 0, undef, 1); if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' && length($my_json_ref->{'username'})) { print $stdout "--- does $uname follow you? => "; print $streamout $my_json_ref->{'follows_you'}, "\n"; } else { print $stdout "-- failure getting info for $uname\n"; } return 0; } # three-argument doesfollow (slower) 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; } print $stdout "-- synchronous /doesfollow command for $user_a $user_b\n" if ($verbose); # get the uid for both users so that we can use the non-paged # endpoint, or this gets too complicated. my $ua = &get_user($user_a); if (!length($ua)) { print $stdout "-- could not find user $user_a\n"; return 0; } my $ub = &get_user($user_b); if (!length($ub)) { print $stdout "-- could not find user $user_b\n"; return 0; } $readline_completion{'@'.$user_a}++ if ($termrl); $readline_completion{'@'.$user_b}++ if ($termrl); my $g = &grabjadn(&urlp($fridurl, $ua), 0, 0, 0, undef, 1); if ($g && ref($g) eq 'ARRAY') { &std("--- does $user_a follow ${user_b}? => "); &sto((&in($ub, @{ $g })) ? "true\n" : "false\n"); } return 0; } # this handles lists too. (or it will when ADN supports that) if(s#^/(frs|friends|following|fos|followers|muted|blocked)(\s+\+\d+)?\s*##) { my $countmaybe = $2; my $mode = $1; my $arg = lc($_); my $lname = ''; my $user = ''; my $what = ''; my $uid; $arg =~ s/^@//; $who = $arg; $mode = "friends" if ($mode eq 'following'); ($who, $lname) = split(m#/#, $arg, 2) if (m#/#); #TODO # FIXME if (length($lname)) { print $stdout "-- lists not yet supported\n"; return 0; } if (!length($lname)) { if (($mode eq 'muted' || $mode eq 'blocked') && length($who)) { print $stdout "-- you can only see your own $mode list\n"; return 0; } $uid = &get_user((length($who)) ? $who : $whoami); if (!$uid) { print $stdout "-- could not find user $who\n"; return 0; } $what = ($mode eq 'frs' || $mode eq 'friends') ? "friends" : ($mode eq 'muted') ? "muted users" : ($mode eq 'blocked') ? "blocked users" : "followers"; $mode = ($mode eq 'frs' || $mode eq 'friends') ? $friendsurl : ($mode eq 'muted') ? $mutedurl : ($mode eq 'blocked') ? $blockedurl : $followersurl; $who = "user $whoami"; } else { $who ||= $whoami; $what = ($mode eq 'frs' || $mode eq 'friends') ? "friends/members" : "followers/subscribers"; $mode = ($mode eq 'frs' || $mode eq 'friends') ? $getliurl : $getfliurl; $user = "&owner_username=${who}&slug=${lname}"; $who = "list $who/$lname"; } $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $countmaybe ||= 20; # loop through using the cursor until desired number. my $cursor = 0; # initial value my $printed = 0; my $nofetch = 0; my $json_ref = undef; my @usarray = undef; shift(@usarray); # force underflow FABIO: while($countmaybe--) { if(!scalar(@usarray)) { print $stdout "-- paging users -- cursor: $cursor nofetch: $nofetch left: $countmaybe\n" if ($verbose); last FABIO if ($nofetch); my $jcursor = ($cursor) ? "?before_id=${cursor}" : ''; # use grabjson here, not grabjadn. $json_ref = &grabjson(&urlp("${mode}${jcursor}", $uid), 0, 0, 0, undef, 1); @usarray = @{ $json_ref->{'data'} }; last FABIO if (!scalar(@usarray)); $cursor = $json_ref->{'meta'}->{'min_id'} || 0; $nofetch = ($cursor) ? 0 : 1; } &$userhandle(shift(@usarray)); $printed++; } print $stdout "-- sorry, no $what found for $who.\n" if (!$printed); print $stdout "-- (more, use +xx for a longer list)\n" if ($json_ref->{'meta'}->{'more'} eq 'true'); return 0; } # pull out entities. this works for PMs and posts. this also needs to # check for oembed annotations because those may also be links. if (m#^/ent?(ities)? ([pP]?[zZ]?[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 post since we're going to fetch it anyway. $hash = { "id" => $code }; $thing = "post"; $genurl = $idurl; } elsif ($code =~ /^P[0-9]+$/ || $code =~ /^[pP][a-zA-Z]/) { # we can't use that optimization here because we need # the CID for PMs. $hash = &get_pm($code); $thing = "PM"; $genurl = $msbycidurl; } else { $hash = &get_original_post($code); $thing = "post"; $genurl = $idurl; } if (!defined($hash) || ref($hash) ne 'HASH') { print $stdout "-- no such $thing (yet?): $code\n"; return 0; } my $id = $hash->{'id'}; my $cid = $hash->{'channel_id'}; # this may be null $hash = &grabjadn(&urlp($genurl,$cid,$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; } my $didprint = 0; my %urls; # iterate over entities foreach $w (qw(links)) { 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->{'text'})); my $u1 = &descape($v->{'text'}); my $u2 = &descape($v->{'url'}); print $streamout "$u1 => $u2\n"; $urlshort = $u2; $urls{&urlnoproto($u2)}++; $didprint++; } } # iterate over oembed annotations my $haz_annos = $hash->{'annotations'}; if (scalar(@{ $haz_annos })) { my $a; foreach $a (@{ $haz_annos }) { next if ($a->{'type'} ne 'net.app.core.oembed'); my $u1 = &descape( $a->{'value'}->{'embeddable_url'}); $u1 ||= &descape($a->{'value'}->{'url'}); &std("-- oembed URL found: $u1\n") if ($verbose); next if (!length($u1) || $urls{&urlnoproto($u1)}); print $streamout "[oembed] => $u1\n"; $urlshort = $u1; $didprint++; } } if ($didprint) { print $stdout &wwrap( "-- %URL% is now $urlshort (/url opens)\n"); } else { print $stdout "-- no entity or embedded 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) ([pP]?[zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($2); my $post; my $genurl = undef; $urlshort = undef; if ($code =~ /^P[0-9]+$/ || $code =~ /^[pP][zZ]?[a-zA-Z][0-9]$/) { $post = &get_pm($code); if (!defined($post) || ref($post) ne 'HASH') { print $stdout "-- no such PM (yet?): $code\n"; return 0; } $genurl = $msbycidurl; } else { $post = &get_post($code); if (!defined($post) || ref($post) ne 'HASH') { print $stdout "-- no such post (yet?): $code\n"; return 0; } $genurl = $idurl; } # if there are entities in the post, then let's see if we # can open those too. this is a tiny version of /entities. if($post->{'_texapp_has_entity_links'}) { my $id = $post->{'id'}; my $cid = $post->{'channel_id'}; # may be null my $hash; # only fetch if we have to. if we already fetched # because we were given a direct id instead of a # menu code, then we already have the entities. if ($code !~ /^[0-9]+$/ && $code !~ /^P[0-9]+$/) { $hash = &grabjadn(&urlp($genurl,$cid,$id), 0, 0, 0, undef, 1); } else { # MAKE MONEY FAST WITH OUR QUICK CACHE PLAN $hash = $post; } if (defined($hash) && ref($hash) eq 'HASH') { my $w; my $v; my $didprint = 0; my %urls; # entities or oembed can be link sources. # don't duplicate. foreach $w (qw(links)) { 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'})); my $u1 = &descape($v->{'url'}); next if ($urls{ &urlnoproto($u1)}++); &openurl($u1); $didprint++; } } my $haz_annos = $hash->{'annotations'}; if (scalar(@{ $haz_annos })) { my $a; foreach $a (@{ $haz_annos }) { next if ($a->{'type'} ne 'net.app.core.oembed'); my $u1 = &descape( $a->{'value'}->{'embeddable_url'}); $u1 ||= &descape($a->{'value'}->{'url'}); &std("-- oembed URL found: $u1\n") if ($verbose); next if (!length($u1) || $urls{&urlnoproto($u1)}++); &openurl($u1); $didprint++; } } return 0 if ($didprint); } } # that failed, so fall back on the old method. my $text = &descape($post->{'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; } if (s/^\/(stars|favourites|favorites|faves|favs|fl)(\s+\+\d+)?\s*//) { my $my_json_ref; my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; print $stdout "-- < parameter meaningless for /stars\n" if ($lead_id); if (length) { my $uid = &get_user($_); if (!length($uid)) { print $stdout "-- could not find user $_\n"; return 0; } $my_json_ref = &grabjadn(&urlp($favsurl, $uid), 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 = &grabjadn(&urlp($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(1); return 0; } # if we have a /save, it must come before this (see regex) if ( m#^/(un)?[fs](rt|rp|repost|tar|a|av|ave|avorite|avourite)? ([zZ]?[a-zA-Z]?[0-9]+)$#) { my $mode = $1; my $secondmode = $2; my $code = lc($3); $secondmode = ($secondmode eq 'repost' || $secondmode eq 'rp') ? 'rt' : $secondmode; if ($mode eq 'un' && $secondmode eq 'rt') { print $stdout "-- hmm. seems contradictory. no dice.\n"; return 0; } my $post = &get_original_post($code); if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } &cordfav($post->{'id'}, 1, $mode, (($mode eq 'un') ? $favdelurl : $favurl), &descape($post->{'text'}), (($mode eq 'un') ? 'removed' : 'created')); if ($secondmode eq 'rt') { $_ = "/rt $code"; # and fall through } else { return 0; } } # Repost API and manual RTs (/erp, /orp, etc.) if (s#^/([oe]?)r(epost|t|p) ([zZ]?[a-zA-Z]?[0-9]+)\s*##) { my $mode = $1; my $code = lc($3); my $post = &get_original_post($code); if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } # use a native repost unless we can't (or user used /ort /ert) unless ($nonewrps || length || length($mode)) { # we don't always get rs->text, so we simulate it. my $text = &descape($post->{'text'}); $text =~ s/^(>>|RP) \@[^\s]+:\s+// if ($post->{'repost_of'}->{'id'}); print $stdout "-- status reposted\n" unless(&updatest($text, 1, 0, undef, $post->{'repost_of'}->{'id'} || $post->{'id'})); return 0; } # we can't or user requested /ert /ort $repost = ">> @" . &descape($post->{'user'}->{'username'}) . ": " . &descape($post->{'text'}); $in_reply_to = $post->{'id'}; $expected_post_ref = $post; if ($mode eq 'e') { &add_history($repost); print $stdout &wwrap( "-- ok, %RP% and %% are now \"$repost\"\n"); return 0; } $_ = (length) ? "$repost $_" : $repost; print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto BOTTOMSUP; # fugly! FUGLY! } # /events (subsumes /rtom /stom) from Interactions API if (s#^/ev(ent)?s\s*##) { my $countmaybe; (s#^\+##) && ($countmaybe = ($_ + 0)); print $stdout "-- < parameter meaningless for /events\n" if ($lead_id); my ($ref, $metaref) = &grabjadn($intsofmeurl, 0, 0, $countmaybe, { 'type' => 'timeline', 'payload' => 'events' }, 1); my $lref = []; my $didprint = 0; if (ref($ref) eq 'ARRAY') { my $s_ref; foreach $s_ref (reverse @{ $ref }) { #TODO # standardevent? $didprint++; # STEVE DALLAS SUPPORTS ACTION JACKSON 1988 my $action_jackson = &descape( $s_ref->{'action'}); my $string = "${EM}${action_jackson}${OFF} from "; my $u_ref; foreach $u_ref (@{ $s_ref->{'users'} }) { $string .= $EM .'@' . &descape($u_ref->{'username'}) .$OFF. ' ' ; } if ($action_jackson eq 'follow') { &sto(&wwrap(">>>> $string\n")); next; } # this is a post object, so load it into the # foreground so we can manipulate it. my $post_ref = $s_ref->{'objects'}->[0]; my $key = &assign_key($post_ref); $string .='on "'; $string .= &descape($post_ref->{'text'}); &sto(&wwrap("${EM}${key}>${OFF} $string\"\n")); } } &std("** no events yet (or could not be retrieved)\n") unless ($didprint); return 0; } # /rtsof (/rpsof) if (m#^/r[pt]s?of\s+([zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($1); my $post = &get_original_post($code); my $id; if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } if ($lead_kind eq 'pm') { print $stdout "-- illogical: {'repost_of'}->{'id'} || $post->{'id'}; if (!$id) { print $stdout "-- hmmm, that post is major bogus.\n"; return 0; } my $users_ref = &grabjadn(&urlp($rpsofidurl,, $id), 0, 0, 0, undef, 1, $lead_id); return if (!defined($users_ref) || ref($users_ref) ne 'ARRAY'); my $k = scalar(@{ $users_ref }); if (!$k) { print $stdout "-- sorry, a careful review of ADN reveals this post sucks (no reposts).\n"; return 0; } my $j; foreach $j (@{ $users_ref }) { &$userhandle($j); } return 0; } # /starred if (m#^/sta?r?r?ed\s+([zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($1); my $post = &get_original_post($code); my $id; print $stdout "-- < parameter meaningless for /starred\n" if ($lead_id); if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } $id = $post->{'repost_of'}->{'id'} || $post->{'id'}; if (!$id) { print $stdout "-- hmmm, that post is major bogus.\n"; return 0; } my $users_ref = &grabjadn(&urlp($favsofidurl,, $id), 0, 0, 0, undef, 1); return if (!defined($users_ref) || ref($users_ref) ne 'ARRAY'); my $k = scalar(@{ $users_ref }); if (!$k) { print $stdout "-- sorry, a careful review of ADN reveals this post sucks (no stars).\n"; return 0; } my $j; foreach $j (@{ $users_ref }) { &$userhandle($j); } return 0; } # enable and disable NewRTs from users # we allow this even if newRTs are off from -nonewrps if(0) { 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 = $2; unless ($code =~ /^p[0-9][0-9]+$/ || $code =~/^P/) { # is a PM $code = lc($code); my $post = &get_post($code); if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } if (lc(&descape($post->{'user'}->{'username'})) ne lc($whoami)) { print $stdout "-- not allowed to delete somebody's else's posts\n"; return 0; } print $stdout &wwrap( "-- verify you want to delete: \"@{[ &descape($post->{'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, post is NOT deleted.\n"; return 0; } $lastpostid = -1 if ($post->{'id'} == $lastpostid); &deletest($post->{'id'}, 1); return 0; } # Pxxx falls through to ... } # PM delete version if (m#^/del(ete)? ([pP][zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($2); my $pm = &get_pm($code); if (!defined($pm)) { print $stdout "-- no such PM (yet?): $code\n"; return 0; } if (lc(&descape($pm->{'user'}->{'username'})) ne $whoami) { print $stdout "-- you can't delete that, it's not your PM!\n"; return 0; } print $stdout &wwrap( "-- verify you want to delete: " . "\"@{[ &descape($pm->{'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, PM is NOT deleted.\n"; return 0; } &deletepm($pm->{'id'}, $pm->{'channel_id'}, 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: \"$lastposted\""); print $stdout "\n"; $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, post is NOT deleted.\n"; return 0; } &deletest($lastpostid, 1); $lastpostid = -1; return 0; } # /rg is a /reply with no @ information (thus no /v-ariant) "global" if (s#^/re?p?l?y?g(f)? ([zZ]?[a-zA-Z]?[0-9]+) ## && length) { my $dof = ($1 eq 'f') ? 1 : 0; my $code = lc($2); my $post = &get_original_post($code); if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } &add_thread($post->{'thread_id'}) if ($dof); $in_reply_to = $post->{'id'}; $expected_post_ref = $post; goto BOTTOMSUP; # fugly! FUGLY! } # /vreply and PM and regular /reply if (s#^/(v)?re(ply)?(f)? ([pP]?[zZ]?[a-zA-Z][0-9]) ## && length) { my $mode = $1; my $dof = ($3 eq 'f') ? 1 : 0; my $code = lc($4); unless (($code =~ /^P/) || # this is a PM ($code =~ /^p/ && length($code) > 2)) { my $post = &get_original_post($code); if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } my $target = &descape($post->{'user'}->{'username'}); $_ = '@' . $target . " $_"; unless ($mode eq 'v') { $in_reply_to = $post->{'id'}; $expected_post_ref = $post; } else { $_ = ".$_"; } $readline_completion{'@'.lc($target)}++ if ($termrl); &add_thread($post->{'thread_id'}) if ($dof); print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto BOTTOMSUP; # fugly! FUGLY! } else { # this is a PM. unlike TTYtter, which fell through to # /dm, this actually gets the channel context and does # the post itself. my $context = &get_pm_context($code); if (!defined($context)) { print $stdout "-- no such PM (yet?): $code\n"; return 0; } if ($mode eq 'v') { print $stdout "-- can't /vreply to PMs\n"; return 0; } # tag with the menu code so that splitting works. my $new_context = { 'menu_code', $code, 'context', $context }; $rv = &common_split_post($_, undef, $new_context); &pmthump if ($rv && $pmpause); return $rv; } } # replyall (based on @FunnelFiasco's extension) and replyhighlight # (uses all logic, but puts direct referent in first position and # remainder at rear) if (s#^/(v)?r(eply)?(to)?(al?l?|hi?l?i?t?e?)(f)? ([pP]?[zZ]?[a-zA-Z]?[0-9]+) ## &&length){ my $mode = $1; my $appendtype = (substr($4, 0, 1) eq 'a') ? 'a' : 'h'; my $dof = ($5 eq 'f') ? 1 : 0; my $code = lc($6); # add reply-all logic for PMs, since this is technically valid if (($code =~ /^P/) || ($code =~ /^p/ && length($code) > 2)) { my $context = &get_pm_context($code); if (!defined($context)) { print $stdout "-- no such PM (yet?): $code\n"; return 0; } if ($mode eq 'v') { print $stdout "-- can't /vreply to PMs\n"; return 0; } print $stdout "-- note: /ra /rh irrelevant on PMs\n"; # tag with the menu code so that splitting works. my $new_context = { 'menu_code', $code, 'context', $context }; $rv = &common_split_post($_, undef, $new_context); &pmthump if ($rv && $pmpause); return $rv; } # if the post is to be edited, treat as /ra $appendtype = 'a' if (/%ED(RP)?%$/); # common code from /vreply # we use get_post here, though, so we can include reposters # in the reply-all. my $post = &get_post($code); if (!defined($post)) { print $stdout "-- no such post (yet?): $code\n"; return 0; } my $target = &descape($post->{'user'}->{'username'}); my $original = $target; if ($post->{'repost_of'}->{'id'}) { $post = &get_original_post($code); $target = &descape($post->{'user'}->{'username'}); } my $text = $_; $_ = '@' . $target; unless ($mode eq 'v') { $in_reply_to = $post->{'id'}; $expected_post_ref = $post; } else { $_ = ".$_"; } # don't repeat the target or myself; track other mentions # that aren't in dontautoreply my %did_mentions = map { $_ => 1 } (lc($target), keys %dontautoreply_); my $reply_post = &descape($post->{'text'}) . ' @' . $original; #while($reply_post =~ s/\@(\w+)//) { # use the same regex as standardpost so that the behaviour # is consistent. while($reply_post =~ s/(^|[^a-zA-Z0-9_]|\\n)\@([a-zA-Z0-9_\/]+)/\1/) { my $name = $2; my $mame = lc($name); # preserve camel case next if ($mame eq $whoami || $did_mentions{$mame}++); if ($appendtype eq 'a') { $_ .= " \@$name"; } else { $text .= " \@$name"; } } $_ .= " $text"; # add everyone in did_mentions to readline_completion who is # not in %dontautoreply_ grep { $readline_completion{'@'.$_}++ if (!$dontautoreply_{$_} && !$dontautoreply_{'@'.$_}); } (keys %did_mentions) if ($termrl); &add_thread($post->{'thread_id'}) if ($dof); # and fall through to post print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto BOTTOMSUP; # fugly! FUGLY! } if (m#^/re(plies)?(\s+\+\d+)?$#) { my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if ($lead_kind eq 'pm') { print $stdout "-- illogical: {'channel_id'})) { print $stdout "-- no such PM (yet?): $code\n"; return 0; } # get the channel and turn it into a context. my $cid = $pm_ref->{'channel_id'}; my $json_ref = &grabjadn(&urlp($chanbyidurl,,$cid), 0, 0, 0); if (!$json_ref || ref($json_ref) ne 'HASH' || !defined($json_ref->{'id'})) { print $stdout "-- failed to get channel for $code\n"; return 0; } $context = &pmchanneltocontext($json_ref); if (!$context) { print $stdout "-- failed to get channel for $code\n"; return 0; } } else { $context = &get_pm_context($code); if (!defined($context->{'id'})) { print $stdout "-- invalid channel (deleted?)\n"; return 0; } } my $cid = $context->{'id'}; my $json_ref = &grabjadn(&urlp($chanmsbyidurl,,$cid), 0, 0, $countmaybe, undef, 1, $lead_id); return if (ref($json_ref) ne 'ARRAY'); foreach $k (sort { $a->{'id'} <=> $b->{'id'} } @{ $json_ref }) { &assign_pm_key($k, $context); &pmoutstack($k, $context); } return 0; } # PM multiple users if (s#^/pmm\s+(.+)\s+--\s+## && length) { my @targets = grep { length($_) } split(/\s+/, $1); if (!scalar(@targets)) { print $stdout "-- couldn't find valid recipients\n"; return 0; } $rv = &common_split_post($_, undef, \@targets); &pmthump if ($rv); return $rv; } # PM just one user if (s#^/pm \@?([^\s]+)\s+## && length) { $rv = &common_split_post($_, undef, $1); &pmthump if ($rv); return $rv; } # /pmclose # we don't support PM IDs here. give me a reason why. if (m#^/pmclose\s+([pP][zZ]?[a-zA-Z][0-9])$#) { my $code = lc($1); my $context = &get_pm_context($code); if (!$context || ref($context) ne 'HASH' || !defined($context->{'id'})) { print $stdout "-- can't find channel for PM $code\n"; return 0; } my $pm = &get_pm($code); print $stdout &wwrap( "-- verify you want to close this channel: \"@{[ &descape($pm->{'text'}) ]}\""); print $stdout "\n"; $answer = lc(&linein( "-- sure you want to close channel? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, channel is STILL ACTIVE.\n"; return 0; } &uorschannel($context->{'id'}, 1, 'un'); # XXXX return 0; } # follow and leave users if (m#^/(follow|leave|unfollow) \@?([^\s/]+)$#) { my $m = $1; my $u = lc($2); my $uid = &get_user($u); if (!length($uid)) { print $stdout "-- could not find user $uname\n"; return 0; } my $n = ($m eq 'follow') ? '' : 'un'; &foruuser($u, 1, $n, $uid, (($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_username=$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( "-- BLOCK $u? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, $u is NOT blocked.\n"; return 0; } } my $uid = &get_user($u); if (!length($uid)) { print $stdout "-- could not find user $uname\n"; return 0; } &boruuser($u, 1, $m, $uid, (($m eq 'block') ? $blockurl : $blockdelurl), (($m eq 'block') ? 'started' : 'stopped')); return 0; } # mute and unmute users if (m#^/(mute|unmute) \@?([^\s/]+)$#) { my $m = $1; my $u = lc($2); if ($m eq 'mute') { $answer = lc(&linein( "-- mute $u? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, $u is NOT muted.\n"; return 0; } } my $uid = &get_user($u); if (!length($uid)) { print $stdout "-- could not find user $uname\n"; return 0; } &boruuser($u, 1, $m, $uid, (($m eq 'mute') ? $muteurl : $mutedelurl), (($m eq 'mute') ? 'started' : 'stopped'), "muting"); 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 ADN 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_username=${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_username=${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_username=${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_username=${whoami}". "&username=".&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_username=${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 = &grabjadn( "${statusliurl}?owner_username=${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; #TODO # check this code # 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 .= "username=${uname}"; $furl .= "&slug=${lname}" if (length($lname)); LABIO: while($countmaybe--) { if(!scalar(@usarray)) { last LABIO if ($nofetch); $json_ref = &grabjadn( "${furl}&count=${countper}&cursor=${cursor}", 0, 0, 0, undef, 1); @usarray = @{ $json_ref->{ ((length($lname)) ? 'users' : 'lists') } }; last LABIO if (!scalar(@usarray)); $cursor = $json_ref->{'next_cursor_str'} || $json_ref->{'next_cursor'} || -1; $nofetch = ($cursor < 1) ? 1 : 0; } my $list_ref = shift(@usarray); if (length($lname)) { &$userhandle($list_ref); } else { # listhandle? my $list_name = "\@$list_ref->{'user'}->{'username'}/@{[ &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"); } print $stdout "-- (more, use +xx for a longer list)\n" if ($json_ref->{'meta'}->{'more'} eq 'true'); 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 post, type /%%\n"; return 0; } s#^/##; # leave the second slash on } BOTTOMSUP: # fugly! FUGLY! $rv = &common_split_post($_, $in_reply_to, undef); &sthump if ($rv); return $rv; } # this is the common code used by standard updates and by the /pm command. sub common_split_post { my $k = shift; my $in_reply_to = shift; my $pm_user = shift; my $pm_lead = ''; my $pm_context = $pm_user; my $maxlength = $linelength; # if pm_user is a hashref, it's probably an annotated context from # the /reply command. try to unwrap it. if (ref($pm_user) eq 'HASH') { if (length($pm_user->{'menu_code'})) { # it's annotated with a menu code. use that and then # extract the context to feed to &updatest. $pm_lead = "/re $pm_user->{'menu_code'} "; $pm_context = $pm_user->{'context'}; } else { # it's a naked context. if a single user, use /pm; if a # multiuser channel, use /pmm. my @unames = &users_not_me(@{ $pm_user->{'users'} }); if (!scalar(@unames)) { # uh ... just guess it was us talking to us? $pm_lead = "/pm $whoami "; } elsif (scalar(@unames) == 1) { $pm_lead = "/pm $unames[0] "; } else { $pm_lead = "/pmm " . join(' ', @unames) . " -- "; } } } elsif(ref($pm_user) eq 'ARRAY') { # it's a list of names from /pmm $pm_lead = "/pmm " . join(' ', @{ $pm_user }) . " -- "; } elsif(length($pm_user)) { # it's not a context or arrayref, just a user name. $pm_lead = "/pm $pm_user "; } $maxlength = (length($pm_lead)) ? $pmlength : $linelength; my $ol = "$pm_lead$k"; my (@poststack) = &csplit($k, ($autosplit eq 'char' || $autosplit eq 'cut') ? 1 : 0, $maxlength); my $m = shift(@poststack); if (scalar(@poststack)) { $l = "$pm_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 $maxlength; autosplitting to \"$l\"\n"); } # there was an error; stop autosplit, restore original command if (&updatest($m, 1, $in_reply_to, $pm_context)) { $history[0] = $ol; return 0; } if (scalar(@poststack)) { $k = shift(@poststack); $l = "$pm_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) > $maxlength); print $stdout "*** to send this next portion, use %%.\n"; } return 1; } # helper functions for the command line processor. sub add_thread { # assistant to add a thread id in a user-friendly way (usually from # /ref /rgf /raf and like commands; /thf and /thunf use /add and /del). my $tid = shift; my $interactive = shift; if ($tid =~ /[^0-9]/) { print $stdout "** bogus thread ID\n" if ($interactive); return; } if ($threads_match{$tid}) { if ($interactive) { &std("** you are already following thread ID #$tid\n"); &std("** (/p threads to list what threads you follow)\n"); } return; } print $stdout "-- following this thread as requested (#$tid)\n"; my $nthreads = (length($threads)) ? "$threads,$tid" : $tid; &setvariable('threads', $nthreads, 0); } 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; &pmthump unless (!$pmpause); } 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; } sub output_signals { $suspend_output = -1; &sigify(sub { $suspend_output ^= 1 if ($suspend_output != -1); }, qw(USR1 PWR XCPU)); &sigify( sub { $suspend_output = -1; }, qw(USR2 SYS UNUSED XFSZ)); } sub suppress_signals { &sigify("IGNORE", qw(USR1 PWR XCPU USR2 SYS UNUSED XFSZ)); $suspend_output = -1; } #### this is the background part of the process #### MONITOR: $0 = "Texapp (background init)"; %store_hash = (); $is_background = 1; $first_synch = $synchronous_mode = 0; $rout = ''; $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 post before these are # operational. &suppress_signals; # default state &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 = 0; $hold = 0; $suspend_output = -1; $stream_failure = 0; $pm_first_time = ($pmpause) ? 1 : 0; $stuck_stdin = 0; $vcheck_timer = time()+$vcheckinterval; # 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(;;) { $0 = "Texapp (background running)"; &$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 ($pmpause && ($effpause || $synch)) { if ($pm_first_time) { &pmrefresh(0); $pmcount = $pmpause; } elsif (!$interactive) { if (!--$pmcount) { &pmrefresh($interactive); # using pm_first_time $pmcount = $pmpause; } } } DONT_REFRESH: # nrvs is tricky with synchronicity if (!$synch || ($synch && $synchronous_mode && !$pm_first_time)) { $k = length($notify_rate) + length($vs) + length($credlog) + length($feedwhere) + length($bad_rc); if ($k) { &std($notify_rate); &std($vs); &std($credlog); &std($feedwhere); &std($bad_rc); $wrapseq = 1; } $notify_rate = ""; $vs = ""; $credlog = ""; $feedwhere = ""; $bad_rc = ""; } print P "0" if ($synchronous_mode && $interactive); # wrap the flush in signal handlers. THIS IS THE ONLY PART THAT # NEEDS IT. do not allow signal handlers to execute once we have # emitted data and are waiting for a command, or we can crash in # later versions of Perl. finally, only even bother if we actually # have stuff to print, and if the background isn't being held. if (scalar(@stream_buf) && !$hold) { &output_signals; &sflush; # this needs to know &suppress_signals; } else { # make sure stream_buf does not overflow. @stream_buf = @stream_buf[-$maxhold..-1] if (scalar(@stream_buf) > $maxhold) } # 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; if ($effpause == undef) { # -script and anonymous have no effpause. print $stdout "-- select() loops forever\n" if ($verbose); $0 = "Texapp (select forever; $stuck_stdin re-reads)"; $nfound = select($rout = $rin, undef, undef, undef); } else { $restarttime = (time() + $effpause) if ($hold) ; $actualtime = $restarttime - time(); print $stdout "-- select pending ($actualtime sec left)\n" if ($superverbose); $0 = "Texapp (select pending; $actualtime sec timeout; $stuck_stdin re-reads)"; $nfound = 0; if ($actualtime > 0) { $nfound = select($rout = $rin, undef, undef, $actualtime); } # this loops at the bottom. } 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); $0 = "Texapp (servicing streaming events)"; # 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 Texapp. 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); # XXX have this emit to the stack 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. # signals should have been suppressed by this point. $0 = "Texapp (receiving IPC)"; 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) { $stuck_stdin++; # like with streaming, if we constantly get null # packets on STDIN, but it always appears to be # "ready," then the foreground probably died and we # should kill ourselves off to avoid pulling a tight # polling loop. if ($stuck_stdin > 100) { print $stdout "parent is dead; so will we\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. $0 = "Texapp (received IPC)"; print $stdout "-- command received ", scalar localtime, " $rout" if ($verbose); if ($rout =~ /^hold/) { $hold ^= 1; # toggle hold flag goto RESTART_SELECT; } elsif ($rout =~ /^rsga/) { $suspend_output = -1; # reset our status goto RESTART_SELECT; } elsif ($rout =~ /^pipet (..)/) { my $key = &get_post($1); my $ms = $key->{'_texapp_menu_select'} || 'XX'; my $ds = $key->{'created_at'} || 'argh, no created_at'; $ds =~ s/\s/_/g; my $src = $key->{'source'}->{'name'} || 'unknown'; $src =~ s/\|//g; # shouldn't be any anyway. $key = substr(( "$ms ".($key->{'id'})." ". ($key->{'reply_to'})." ". ($key->{'repost_of'}->{'id'})." ". ($key->{'repost_of'}->{'thread_id'})." ". ($key->{'_texapp_has_entity_links'})." ". ($key->{'_texapp_latitude'})." ". ($key->{'_texapp_longitude'})." ". $key->{'_texapp_tag'}->{'type'}. " ". # NO SPACES! unpack("${pack_magic}H*", $key->{'_texapp_tag'}->{'payload'}). " ". $key->{'_texapp_classes'}. " ". # NO SPACES! ($key->{'num_replies'} || "0"). " " . ($key->{'num_stars'} || "0") . " " . ($key->{'thread_id'} || "0") . " " . ($key->{'repost_of'}->{'num_reposts'} || $key->{'num_reposts'} || "0") . " " . $key->{'user'}->{'username'}." $ds $src|". unpack("${pack_magic}H*", $key->{'text'}). $space_pad), 0, 8192); print P $key; goto RESTART_SELECT; } elsif ($rout =~ /^piped (..)/) { # THIS IS THE CONTEXT, NOT THE PM!!! my $key = $pm_context_hash{$1}; $key = substr(( $key->{'id'}." ". $key->{'owner'}. " ". join('|',@{ $key->{'users'} }). $space_pad), 0, 8192); print P $key; goto RESTART_SELECT; } elsif ($rout =~ /^pipep (..)/) { # THIS IS THE PM, NOT THE CONTEXT!!! my $key = $pm_store_hash{$1}; my $ms = $key->{'_texapp_menu_select'} || "XX"; my $source = $key->{'source'}->{'name'} || "unknown"; $source =~ s/\s/\|/g; # for consistency $key = substr(( $ms." ". $key->{'id'}." ". $key->{'channel_id'}." ". ($key->{'_texapp_has_entity_links'}) . " ". ($key->{'_texapp_latitude'})." ". ($key->{'_texapp_longitude'})." ". lc($key->{'user'}->{'username'})." ". $key->{'created_at'}." ". $source." ". unpack("${pack_magic}H*", $key->{'text'}). $space_pad), 0, 8192); print P $key; goto RESTART_SELECT; } elsif ($rout =~ /^ki ([^\s]+) /) { my $key = $1; my $module = ''; my $buf = ''; while(length($module) < 8192) { sysread(STDIN, $buf, 8192); $module .= $buf; } $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, 8192); goto RESTART_SELECT; } elsif ($rout =~ /^kn ([^\s]+) /) { my $key = $1; my $module = ''; my $buf = ''; while(length($module) < 8192) { sysread(STDIN, $buf, 8192); $module .= $buf; } $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 = ''; my $buf = ''; while(length($module) < 8192) { sysread(STDIN, $buf, 8192); $module .= $buf; } $module =~ s/\s+$//; $module = pack("H*", $module); $buf = ''; while(length($value) < 8192) { sysread(STDIN, $buf, 8192); $value .= $buf; } $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, 8192); } else { $value = $buf = ''; while (length($value) < 8192) { sysread(STDIN, $buf, 8192); $value .= $buf; } $value =~ s/\s+$//; $interactive = ($comm eq '+') ? 0 : 1; &send_removereadline if ($termrl && ($interactive || $verbose)); $wrapseq = 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'); &threads_compile($value, 0) if ($key eq 'threads'); &filter_compile if ($key eq 'filter'); &filterclients_compile if ($key eq 'filterclients'); ¬ify_compile if ($key eq 'notifies'); &list_compile if ($key eq 'lists'); &filterflags_compile if ($key eq 'filterflags'); $filterrps_sub = &filterlist_compile( $filterrps_sub, $value) if ($key eq 'filterrps'); $filterusers_sub = &filterlist_compile( $filterusers_sub,$value) if ($key eq 'filterusers'); $filteratonly_sub = &filterlist_compile( $filteratonly_sub, $value) if ($key eq 'filteratonly'); $filterthreads_sub = &filterlist_compile( $filterthreads_sub, $value) if ($key eq 'filterthreads'); &filterats_compile if ($key eq 'filterats'); } &send_repaint if ($termrl && ($interactive || $verbose)); } goto RESTART_SELECT; } else { $interactive = 1 unless ($rout =~ /no/); if ($rout =~ /^R(\d+),(\d+)/) { $fetchwanted = 0+$1; $lead_id = 0+$2; $fetch_id = $last_id = 0 if (!$lead_id); } if ($rout =~ /^pm/) { &pmrefresh($interactive); # &send_repaint if ($termrl); $pmcount = $pmpause; goto DONT_REFRESH; } } } else { if ($nfound == -1 || $hold) { # we need to restart the call. we might be waiting # longer, but this is unavoidable. goto RESTART_SELECT; } print $stdout "-- routine refresh (effpause = $effpause, vchecktimer = $vcheck_timer, $pmcount to next pm) ", scalar localtime, "\n" if ($verbose); } # Periodic update check (unless disabled) if ($vcheck && $vcheckinterval > 1 && time() > $vcheck_timer) { print $stdout "-- Checking for updated version...\n" if ($verbose); print $stdout &updatecheck(1, 0); $vcheck_timer = time()+$vcheckinterval; } } #### internal implementation functions for the ADN 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')); return ($effpause = undef) if ($pause ne 'auto' && $pause < 1); return ($effpause = (0+$pause)) if ($pause ne 'auto'); # not executed right now if (!$rate_limit_next && !$anonymous && ($pause > 0 || $pause eq 'auto')) { # ADN 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 = &grabjadn($rlurl, 0, 0, 0, undef, 1); if (defined $rate_limit_ref && ref($rate_limit_ref) eq 'HASH') { # of mentions_timeline, home_timeline and search/posts, # 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/posts'}->{'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/posts'}->{'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); print $stdout "-- rate limit rate failure: using 180 second fallback\n" if (!$effpause); # 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 = "Texapp (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; print STDOUT "\n\ncurl PID = $curlpid\n\n"; $superverbose = 1; &grabjadn($streamsuburl."?connection_id=$connection_id"); $superverbose = 0; for(;;) { sysread(NURSE, $c, 1); print STDOUT $c; } } # start the subscription &grabjadn($streamsuburl); HELLONURSE: while(1) { # restart nurse process if it/curl died goto HELLOAGAINNURSE if(!$streampid); # read a line of text (hopefully numbers) chomp($buf = ); # 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 = "Texapp (waiting $wait_time sec to connect to stream)"; sleep $wait_time; $curlpid = 0; #TODO # fix $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, #TODO # needs replarg [ $streamurl, "&connection_id=$connection_id" ], undef, undef, '-s', '-A', "Texapp_Streaming/$Texapp_VERSION", '-N', '-H', 'Expect:'); ($curlpid = open(K, "|$comm")) || die("failed curl: $!\n"); printf STDOUT ("%08x", $curlpid); # "DIE QUICKLY" $0 = "Texapp (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 posts if ($w->{'payload'}->{'text'} && !$notimeline) { # normalize the post first. #TODO # needs to be tagged at this level my $payload = &normalizejson($w->{'payload'}); my $sid = $payload->{'id'}; $payload->{'_texapp_tag'}->{'type'} = 'timeline'; $payload->{'_texapp_tag'}->{'payload'} = 'stream'; $payload->{'_texapp_classes'} = &$posttype($payload, $sn, $text); # filter replies from streaming socket if the # user requested it. use $posttype to determine # this so the user can interpose custom logic. if ($nostreamreplies) { my $sn = &descape( $payload->{'user'}->{'username'}); my $text = &descape($payload->{'text'}); next if (&$posttype($payload, $sn, $text) =~ /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 PMs elsif (($tmp = $w->{'payload'}->{'direct_message'}) && $pmpause) { #TODO # this needs to pass a context and channel to pmrefresh somehow &pmrefresh(0, [ $tmp ]); # don't roll last_pm yet. } # must be an event. see if standardevent can make sense of it. elsif (!$notimeline) { $w = $w->{'payload'}; my $sou_sn = &descape($w->{'source'}->{'username'}); if (!length($sou_sn) || !$filterusers_sub || !&$filterusers_sub($sou_sn)) { &evoutstack($w); $wrapseq = 1; } } } } # the output stack controllers. these slot in between &$*handle and the actual # handler so that extensions need less boilerplate code in Texapp. sub outstack { my $post_ref = shift; my $class = shift; my $rv = &$handle($post_ref, $class); # don't send notifies if filtered. &sendnotifies($post_ref, $class) unless (!$rv); return $rv; } sub pmoutstack { my $pm_ref = shift; my $pm_context = shift; my $sns = lc($pm_ref->{'user'}->{'username'}); my $rv = &$pmhandle($pm_ref, $pm_context); # don't send notifies if filtered. &sendpmnotifies($pm_ref, $pm_context) if ($rv && $sns ne $whoami && $is_background); # don't do this in the foreground! return $rv; } sub evoutstack { # future expansion my $event_ref = shift; return &$eventhandle($event_ref); } # 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; my $prior_last_id = $last_id; my $prior_fetch_id = $fetch_id; $last_id = $fetch_id = 0 if ($lead_id); # this mixes all the post streams (timeline, hashtags, threads, replies # and lists) into a single unified data river. # backload can be zero, but this will still work since &grabjadn # 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 = &grabjadn( ($allats) ? "${url}?include_directed_posts=1" : $url, ($dostream) ? $last_id : $fetch_id, 0, (($last_id) ? 250 : $fetchwanted || $backload), { "type" => "timeline", "payload" => "api" }, 1, $lead_id); # 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'}}) || $filter_next{$l->{'id'}} || $k{$l->{'id'}}) { push(@{ $my_json_ref }, $l); $k{$l->{'id'}}++; } } } else { $my_json_ref = $base_json_ref; } } # add stream for replies, if requested if ($mentions) { # same thing my $r = &grabjadn(&urlp($rurl), ($dostream && !$nostreamreplies) ? $last_id : $fetch_id, 0, (($last_id) ? 250 : $fetchwanted || $backload), { "type" => "reply", "payload" => "" }, 1, $lead_id); push(@streams, $r) if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })); } # next handle threads we are subscribed to if (scalar(@subscribed_threads)) { my $w; foreach $w (@subscribed_threads) { my $r = &grabjadn(&urlp($thurl,,$w), ($dostream) ? $last_id : $fetch_id, 0, (($last_id) ? 250 : $fetchwanted || $backload), { "type" => "subthread", "payload" => $w }, 1, $lead_id); 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, $backtrack); } else { $l = (($fetchwanted) ? $fetchwanted : &max(250, $searchhits)); } unless (!$l) { foreach $k (@trackstrings) { $r = &grabjadn("$queryurl?${k}", $fetch_id, 0, $l, { "type" => "search", "payload" => $k }, 1, $lead_id); push(@streams, $r) if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })); } } } if(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 = &grabjadn( "${statusliurl}?owner_username=".$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, $lead_id); 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 posts 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'}; # 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 posts 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++) { if($my_json_ref->[$i]->{'id'} == $id) { # it's a duplicate. next SMIX0; } if($my_json_ref->[$i]->{'id'} < $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); if ($dont_refresh_first_time) { $last_id = &max($my_json_ref->[0]->{'id'}, $last_id); } else { ($last_id, $crap, $crap, $crap) = &tdisplay($my_json_ref, undef, $relative_last_id); } unless ($lead_id) { my $new_fi = (scalar(@{ $my_json_ref })) ? $my_json_ref->[(scalar(@{ $my_json_ref })-1)]->{'id'} : ''; # 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; } else { &sto("== // " . ("=" x 73) . "\n"); $fetch_id = $prior_fetch_id; $last_id = $prior_last_id; $lead_id = 0; # done with that. } print $stdout "-- last_id $last_id, fetch_id $fetch_id, rollback $relative_last_id\n". "-- (@{[ scalar(keys %id_cache) ]} cached)\n" if ($verbose); &$conclude(0); $wrapseq = 1; } # convenience function for filters (see below) sub killtw { my $j = shift; $filtered++; $filter_next{$j->{'id'}}++ if ($is_background); } # asynchronous output flush # this must only be run by the background sub sflush { return unless ($is_background); return if ($suspend_output > 0); return if (!scalar(@stream_buf)); my @buf = @stream_buf; @stream_buf = (); &send_removereadline if ($termrl); map { $aa = $_->[0]; print $aa "$_->[1]" } @buf; $wrapseq = 1; &send_repaint if ($termrl); } # handle (i.e., display) an array of posts 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 $flag_id = shift; my $printed = 0; my $disp_max = &min($print_max, scalar(@{ $my_json_ref })); my $save_counter = -1; my $i; my $j; my $k; 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 # is this needed anymore? $save_counter = $post_counter; $post_counter = $mini_split; for(0..9) { undef $store_hash{"zz$_"}; } }# else { # $post_counter = $back_split; # %store_hash = (); #} } $k = $my_json_ref->[($disp_max)-1]; for($i = $disp_max; $i > 0; $i--) { my $g = ($i-1); $j = $my_json_ref->[$g]; my $id = $j->{'id'}; my $sn = $j->{'user'}->{'username'}; next if (!length($sn)); $sn = lc(&descape($sn)); # if this is NOT the background, add sns and uids as # we discover them to the user_cache. unless ($is_background) { $user_cache{$sn} = $j->{'user'}->{'id'}; $user_id_cache{$user_cache{$sn}} = $sn; } # # implement filter stages: # do so in such a way that we can toss posts 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 post (&killtw($j), next) if ($filterusers_sub && &$filterusers_sub($sn)); # and if the post has a reposted status, do for # that. (&killtw($j), next) if ($j->{'repost_of'} && $filterusers_sub && &$filterusers_sub(lc(&descape($j-> {'repost_of'}-> {'user'}->{'username'})))); # first-a, filterthreads. this is also very fast, but # we need to look at several possible IDs. my $thread = &descape($j->{'thread_id'}); (&killtw($j), next) if ($thread && $filterthreads_sub && &$filterthreads_sub($thread)); if ($j->{'repost_of'} && $filterthreads_sub) { (&killtw($j), next) if (length($j->{'repost_of'}->{'id'})&& &$filterthreads_sub($j->{'repost_of'}->{'id'})); (&killtw($j), next) if (length($j->{'repost_of'}->{'thread_id'})&& &$filterthreads_sub( $j->{'repost_of'}->{'thread_id'})); } # second, filterrps. this is almost as fast. (&killtw($j), next) if ($filterrps_sub && length($j->{'repost_of'}->{'id'})&& &$filterrps_sub($sn)); # second-a. get the source, see if this is a blocked # source (-noifttt). my $source = &descape($j->{'source'}->{'name'}); (&killtw($j), next) if ($noifttt && $source eq 'IFTTT'); # 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, notco. this is pretty quick. (&killtw($j), next) if ($notco && # fast test $tex =~ m#https?://t.co/#); # slow test (&killtw($j), next) if ($notco && $tex =~ m#^RT \@#); # fifth, filterats. this is somewhat expensive. (&killtw($j), next) if ($filterats_c && &$filterats_c($tex)); # sixth, filterclients. this is very expensive. (&killtw($j), next) if ($filterc_c && &$filterc_c($source)); # finally, classic -filter. this is the most expensive. (&killtw($j), next) if ($filter_c && &$filter_c($tex)); } # damn it, user may actually want this post. # assign menu codes and place into caches my $key = &assign_key($j); $wrapseq++; # TODO # handle flag_id here $printed += scalar(&outstack($j, ($class || (($id <= $relative_last_id) ? 'again' : undef)))); } } $post_counter = $save_counter if ($save_counter > -1); &$exception(6,"*** warning: more posts than menu codes; truncated\n") if (scalar(@{ $my_json_ref }) > $print_max); if (($interactive || $verbose) && !$printed) { &std("-- sorry, nothing to display.\n"); $wrapseq = 1; } return (&max($my_json_ref->[0]->{'id'}, $last_id), $j, $k, $printed); } sub assign_key { my $post_ref = shift; my $id = $post_ref->{'id'}; my $key = (($is_background) ? '' : 'z' ). substr($alphabet, $post_counter/10, 1) . $post_counter % 10; $post_counter = ($post_counter == 259) ? $mini_split : ($post_counter == ($mini_split - 1)) ? 0 : ($post_counter+1); $post_ref->{'_texapp_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'}}; $id_cache{$id} = $key; } $store_hash{$key} = $post_ref; return $key; } sub assign_pm_key { my $pm_ref = shift; my $pm_context = shift; # given a PM and its context (derived from &pmchanneltocontext), # assign a key and cache the context just as we did with assign_key. my $key = (($is_background) ? '' : 'z'). substr($alphabet, $pm_counter/10, 1) . $pm_counter % 10; $pm_counter = ($pm_counter == 259) ? $mini_split : ($pm_counter == ($mini_split - 1)) ? 0 : ($pm_counter+1); $pm_ref->{'_texapp_menu_select'} = 'p'.$key; $key = lc($key); $pm_store_hash{$key} = $pm_ref; # recover context cache memory. we do this in both foreground and # background since many functions are moved into the foreground in # Texapp. delete $pm_context_cache{$pm_context_hash{$key}->{'id'}}; $pm_context_cache{$pm_context->{'id'}} = $key; $pm_context_hash{$key} = $pm_context; return $key; } sub dt_tdisplay { my $my_json_ref = shift; my $class = shift; my $flag_id = shift; if (defined($my_json_ref) && ref($my_json_ref) eq 'ARRAY' && scalar(@{ $my_json_ref })) { my ($crap, $art, $fr, $crap) = &tdisplay($my_json_ref, $class, $flag_id); 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'}); my $menu1 = $fr->{'_texapp_menu_select'}; my $menu2 = $art->{'_texapp_menu_select'}; if (!length($menu1) || !length($menu2)) { &std(&wwrap( "-- update covers $ts1 thru $ts2\n")); } else { &std(&wwrap( "-- update covers $ts1 thru $ts2 (${menu1}-${menu2})\n")); } &std(&wwrap( "-- warning: no posts passed filters (/set nofilter? /unset noifttt?)\n")) if (!$crap); } &$conclude(!$is_background); return $crap; # printed, may be zero } # array was empty or bogus, indicate that return -1; } sub pmscan { my $top = shift; my $topfetch = ($top > 0) ? $top : ($top == 0) ? 200 : 1; my $k; my $max; my @outarray; if ($anonymous) { print $stdout "-- sorry, you can't read PMs if you're anonymous.\n" if ($interactive); return; } # get all the channels. do not fetch deleted posts here. my $ref = &grabjadn( "${chanurl}?channel_types=net.app.core.pm&include_deleted=0&include_recent_message=1&count=$topfetch"); return if (ref($ref) ne 'ARRAY'); $pm_first_time = 0; # assume the fetch was successful return if (!scalar(@{ $ref })); # sort them so that the most recent are at the top, but then descending # order of the ones we select. @outarray = ($top) ? sort { $b->{'recent_message'}->{'id'} <=> $a->{'recent_message'}->{'id'} } @{ $ref } : sort { $a->{'id'} <=> $b->{'id'} } @{ $ref } ; if ($top == -1) { # find and return the highest ID of PMs available (so that # the foreground can find out). # XXX more efficient to just ask the background?? @outarray = sort { $b->{'recent_message'}->{'id'} <=> $a->{'recent_message'}->{'id'} } @{ $ref }; return $outarray[0]->{'recent_message'}->{'id'}; } &std(($top) ? "-- most recent $top channels with activity (/pmscan for all channels)\n" : "-- all channels (/pmagain on a PM to view thread)\n"); @outarray = @outarray[0..($top-1)] if ($top); @outarray =# ($top) ? sort { $a->{'recent_message'}->{'id'} <=> $b->{'recent_message'}->{'id'} } @outarray #: #sort { $a->{'id'} <=> $b->{'id'} } @outarray ; foreach $k (@outarray) { my $j = $k->{'recent_message'}; my $l = &pmchanneltocontext($k); if (!$l) { &std("** transient error getting channel\n"); next; } &assign_pm_key($j, $l); &pmoutstack($j, $l); $max = &max($max, $j->{'id'}); } $last_pm = &max($max, $last_pm); $last_pm_req = $last_pm; $pmchecked = 1; return; } # thump for PMs # this can be called by the foreground, too. sub pmrefresh { my $interactive = shift; my $relative_last_pm = shift; # for streaming API to inject PMs it receives # XXXX: we need to have this figure out how to pass it a context my $my_json_ref = shift; my %context_cache; my $m; my $max; my $x_last_pm = $relative_last_pm || $last_pm; if ($anonymous) { print $stdout "-- sorry, you can't read PMs if you're anonymous.\n" if ($interactive); $wrapseq = 1; 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_pm # do a brief /pmscan for first time start up return &pmscan(2) if (!$x_last_pm); unless ($my_json_ref) { my @messages = (); my $c; # quickly check if we have *any* messages (count=1). my $ref = &grabjadn( "${chanurl}?channel_types=net.app.core.pm&include_recent_message=1&count=1"); return if (ref($ref) ne 'ARRAY' || !scalar(@{ $ref })); if ($ref->[0]->{'recent_message'}->{'id'} > $x_last_pm) { # the most recent message is newer. check for older; # get all channels with their most recent messages. my $ref = &grabjadn( "${chanurl}?channel_types=net.app.core.pm&include_recent_message=1&count=200"); return if (ref($ref) ne 'ARRAY' || !scalar(@{ $ref })); # go through the channels. if the most recent message in each # is greater than last_pm, fetch all messages and add all # messages to the arrayref that are more recent than last_pm # (use since_id and a count of 200 for maximum goodness). foreach $c (@{ $ref }) { my $cid = $c->{'id'}; my $cmid = $c->{'recent_message'}->{'id'}; print $stdout "-- background pmscan: channel = $cid mrm_id = $cmid\n" if ($verbose); next unless ($cmid > $x_last_pm); my $ms_ref = &grabjadn( &urlp($chanmsbyidurl,,$cid), $x_last_pm, 0, 200); next if (ref($ms_ref) ne 'ARRAY' || !scalar(@{ $ms_ref })); # hmmm .... my $ct = &pmchanneltocontext($c); if (!$ct) { print $stdout "-- transient failure converting to context; skipping channel\n" if ($verbose); next; } $context_cache{$cid} = $ct; print $stdout "-- fetched @{[ scalar(@{ $ms_ref }) ]} new messages for channel $cid\n" if ($verbose); push(@messages, @{ $ms_ref }); } } else { print $stdout "-- quick check: nothing newer than $x_last_pm\n" if ($verbose); } if (!scalar(@messages)) { if ($interactive) { &std("-- sorry, no new PMs found.\n"); $wrapseq = 1; } $pmchecked = 1; return $x_last_pm; } else { $my_json_ref = \@messages; } } else { # populate the context cache from the provided hashref # XXXX! } return if (!defined($my_json_ref) || ref($my_json_ref) ne 'ARRAY'); # now, display PMs foreach $m (sort { $a->{'id'} <=> $b->{'id'} } @{ $my_json_ref }) { my $context = $context_cache{$m->{'channel_id'}}; print $stdout "** problem: could not find a context for PMID $m->{'id'}; skipping\n" if (!defined($context)); &assign_pm_key($m, $context); &pmoutstack($m, $context); $max = $m->{'id'}; $wrapseq++; } $x_last_pm = &max($last_pm, $max); unless ($relative_last_pm) { $last_pm = $x_last_pm; print $stdout "-- pm bookmark is $last_pm.\n" if ($verbose); } &$pmconclude; $pmchecked = 1; return $x_last_pm; } # post an update # this is a general API function that handles status updates and sending PMs. sub updatest { my $string = shift; my $interactive = shift; my $in_reply_to = shift; my $pm_object = shift; my $rp_id = shift; # even if this is set, string should also be set. my $urle = ''; my $i; my $subpid; my $istring; my $user_name_pm; my $json_user_pm; my $cid; my @method = @wend; my $maxlength = $linelength; my $needs_editor = 0; # pm_object can either be a string (the username) or a context ref. # if it's a string, that becomes user_name_pm, and the channel ID # becomes "pm" (developers.app.net/docs/resources/message/lifecycle/). # if it's a context, then the user_name_pm list is taken from there # and the channel ID as well. if(ref($pm_object) eq 'HASH') { # it's a context $user_name_pm = join(' ', &users_not_me(@{ $pm_object->{'users'} })); $json_user_pm = join('\", \"@', &users_not_me(@{ $pm_object->{'users'} })); $cid = $pm_object->{'id'}; $maxlength = $pmlength; } elsif(ref($pm_object) eq 'ARRAY') { # it's a list of names $user_name_pm = join(' ', @{ $pm_object }); $json_user_pm = join('\", \"@', &users_not_me(@{ $pm_object })); $cid = 'pm'; $maxlength = $pmlength; } else { # it's a user name $user_name_pm = $json_user_pm = $pm_object; $cid = 'pm'; $maxlength = $pmlength if (length($user_name_pm)); } my $verb = (length($user_name_pm)) ? "PM $user_name_pm" : ($rp_id) ? 'RE-post' : 'post'; # trigger the editor if $string ends in %ED(RP)% if ($string =~ s/%ED(R?P?)%$//) { my $is_rp = $1; my $fn = "/tmp/texapp-".$$.time().".txt"; my $editor = $ENV{'EDITOR'} || "/usr/bin/vi"; my $ostring; my $ibuf = $string; my $can_fail = 1; $needs_editor = 1; if (! -x $editor) { &std( "-- editor $editor seems invalid; set full path to EDITOR\n"); return 96; } &std( "-- warning: user likes emacs and probably has poor hygiene\n") if ($editor =~ /emacs/); if(!open(K, ">$fn")) { &std("-- unable to create $fn: $!\n"); return 96; } $ibuf .= (length($ibuf)) ? " $repost" : "$repost" if ($is_rp eq 'RP'); $ibuf .= "\n" if (length($ibuf) && $ibuf !~ /\n$/s); print K $ibuf if (length($ibuf)); $ostring = $ibuf; close(K); while ($can_fail) { # hold the background during editing &hold; system($editor, $fn); &hold; if(!open(K, "$fn")) { &std("-- unable to read back $fn: $!\n"); return 96; } $string = ''; while() { $string .= $_; } close(K); $can_fail = 0; # the editor has to enforce line length if (length($string) > $maxlength) { &std( "-- too long: @{[ length($string) ]} characters, max $maxlength\n"); $string = ''; $can_fail = 1; } if ($can_fail) { my $answer = lc(&linein( "-- edit again? (only y or Y is affirmative):")); $can_fail = 0 unless ($answer eq 'y'); } } unlink($fn) || &std("-- warning: couldn't remove $fn: $!\n"); if ($ostring eq $string) { &std("-- no change detected, not posting\n"); return 97; } $string =~ s/\s+$//; chomp($string); $string =~ s/\s+$//; if (!length($string)) { &std("-- editor returned nothing, not posting\n"); return 97; } } # "the pastebrake" if (!$slowpost && !$verify && !$script && !$needs_editor) { 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 posts\n". "-- hit CTRL-C NOW! to kill Texapp if you accidentally pasted in this window\n"; sleep 3; $postbreak_count = 0; } } else { $postbreak_count = 0; } $postbreak_time = time(); } my $payload = 'text'; $string = &$prepost($string) unless ($user_name_pm || $rp_id); unless ($rp_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"; } } } my $i = ''; $i .= "reply_to=${in_reply_to}&" if ($in_reply_to > 0); my $geo_anno = ''; if (!$rp_id && defined $lat && defined $long && $location) { print $stdout "-- using lat/long: ($lat, $long)\n"; $geo_anno = ", \\\"annotations\\\":[{ \\\"type\\\": \\\"net.app.core.geolocation\\\", \\\"value\\\": { \\\"latitude\\\": $lat, \\\"longitude\\\": $long }}]"; } elsif ((defined $lat || defined $long) && $location && !$rp_id) { print $stdout "-- warning: incomplete location ($lat, $long) ignored\n"; } $i .= "${payload}=${urle}" unless ($rp_id); $i .= "id=$rp_id" if ($rp_id); # YES, you *can* verify and slowpost. I thought about this and I # think I want to allow it. if ($verify && !length($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; } } if ($user_name_pm) { @method = @wjnd; my $ustring = &encodejson($string); if ($cid eq 'pm') { # this is already in the right format. chomp($i = <<"EOF"); { \\\"text\\\" : \\\"$ustring\\\", \\\"destinations\\\" : [\\\"\@${json_user_pm}\\\"]${geo_anno}} EOF } else { chomp($i = <<"EOF"); { \\\"text\\\" : \\\"$ustring\\\" ${geo_anno}} EOF } } elsif (length($geo_anno)) { @method = @wjnd; my $ustring = &encodejson($string); chomp($i = <<"EOF"); { \\\"text\\\" : \\\"$ustring\\\" ${geo_anno}} EOF } $slowpost += 0; if ($slowpost && !$script && !length($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_pm)) ? &urlp($chanmsbyidurl,,$cid) : ($rp_id) ? &urlp($rpurl, $whoamid, $rp_id) : $update, $i, 0, @method); 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 =~ /^\[?\]?/i || $return =~ /^<\??xml\s+/) { print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: ADN Fail Whale${OFF} EOF return 98; } $lastpostid = &parsejson($return)->{'data'}->{'id'}; unless ($user_name_pm || $rp_id) { $lastposted = $string; &$postpost($string); } if (length($alsopost) && !$manualalsopost) { unless ($in_reply_to > 0) { if(open(W, "|$alsopost")) { print W "$string\n"; close(W); } else { print $stdout "-- failed to alsopost: $!\n"; } } else { print $stdout "-- alsopost suppressed for threaded reply\n"; } } return 0; } # this dispatch routine replaces the common logic of deletest, deletepm, # follow, leave and the favourites system. # this is a modified, abridged version of &updatest. sub central_cd_dispatch { my ($payload, $interactive, $update, @method) = (@_); my $return = &backticks($baseagent, '/dev/null', undef, $update, $payload, 0, @method); 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 # Texapp, but are officially still "private interfaces." # save internal state to .texapprc sub savestate { if ($is_background) { print $stdout "*** can't save state from background\n"; return; } # call all extensions with collectsave &$collectsave; # set RC version $rc_version ||= $current_rc_version; # copy to backup, but only if it already exists if (-e "$rcf") { if(!open(B, ">${rcf}~") || !open(BB, "${rcf}\n")) { print $stdout "*** can't save backup copy to ${rcf}~\n"; print $stdout "*** aborting safely: $!\n"; return; } while() { print B $_; } close(B); close(BB); } if (!open(B, ">$rcf")) { print $stdout "*** can't save new copy to ${rcf}\n"; print $stdout "*** aborting safely: $!\n"; return; } # enumerate all variables and -extpref_* variables foreach $key (sort keys %valid) { # not just can_set print B "${key}=$$key\n" if (length($$key) && $key ne 'bearertoken' && # safety $key ne 'readline'); # some users may set this } foreach $key (keys %main::) { print B "${key}=${$key}\n" if (length($key) && $key =~ /^extpref_/); } # readline is handled specially. we set readline to '' if it == 1 if (scalar(@j = keys(%readline_completion))) { print B "readline=" . join(' ', @j) . "\n"; } elsif ($termrl) { # readline_completion empty, but there's readline print B "readline=1\n"; } close(B); print $stdout "-- settings saved to $rcf\n"; } # delete a status sub deletest { my $id = shift; my $interactive = shift; my $update = &urlp($delurl, $whoamid, $id); my ($en, $em) = ¢ral_cd_dispatch("", $interactive, $update, @wdnd); print $stdout "-- post id #${id} has been removed\n" if ($interactive && !$en); print $stdout "*** (was the post already deleted?)\n" if ($interactive && $en); return 0; } # delete a PM (needs id *and* channel id) sub deletepm { my $id = shift; my $cid = shift; my $interactive = shift; my $update = &urlp($msbycidurl, $cid, $id); my ($en, $em) = ¢ral_cd_dispatch("", $interactive, $update, @wdnd); print $stdout "-- PM id #${id} has been removed\n" if ($interactive && !$en); print $stdout "*** (was the PM already deleted?)\n" if ($interactive && $en); return 0; } # subscribe or unsubscribe to a channel ID (only the latter is implemented) sub uorschannel { my $cid = shift; my $interactive = shift; my $mode = shift; # XXXX ignored my $update = &urlp($chansubbyidurl,,$cid); #TODO # implement subscriptions my @method = @wdnd; my ($en, $em) = ¢ral_cd_dispatch("", $interactive, $update, @method); if ($interactive) { if (!$en) { print $stdout "-- PM channel closed for channel ID #$cid\n"; print $stdout "-- it will not appear in /pmscan\n"; print $stdout "-- it may be automatically reopened by activity\n"; } else { print $stdout "*** already closed?\n"; } } return 0; } # create or destroy a favourite sub cordfav { my $id = shift; my $interactive = shift; my $mode = shift; # un or '' my $basefav = shift; my $text = shift; my $verb = shift; my $update = &urlp($basefav, $whoamid, $id); my @method = ($mode eq 'un') ? @wdnd : @wend; my ($en, $em) = ¢ral_cd_dispatch("", $interactive, $update, @method); print $stdout "-- favourite $verb for post 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 $mode = shift; my $uid = shift; my $basef = shift; my $verb = shift; my $update = &urlp($basef, $uid); # actually uid my @method = ($mode eq 'un') ? @wdnd : @wend; my ($en, $em) = ¢ral_cd_dispatch("", $interactive, $update, @method); print $stdout "-- ok, you have $verb following user $uname.\n" if ($interactive && !$en); return 0; } # block or unblock a user (also used for muting) sub boruuser { my $uname = shift; my $interactive = shift; my $mode = shift; my $uid = shift; my $basef = shift; my $verb = shift; my $variant = shift || "blocking"; my $update = &urlp($basef, $uid); # actually uid my @method = ($mode =~ /^un/) ? @wdnd : @wend; my ($en, $em) = ¢ral_cd_dispatch("", $interactive, $update, @method); print $stdout "-- ok, you have $verb $variant user $uname.\n" if ($interactive && !$en); return 0; } # enable or disable reposts 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( "reposts=${tval}&username=${uname}", $interactive, $frupdurl); print $stdout "-- ok, you have ${verb} reposts for user $uname.\n" if ($interactive && !$en); return 0; } #### Texapp 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 post based on user options sub standardpost { my $ref = shift; my $nocolour = shift; my $indent = shift; my $sn = &descape($ref->{'user'}->{'username'}); my $post = &descape($ref->{'text'}); my $colour; my $g; my $h; # wordwrap really ruins our day here, thanks a lot, T@augmentedfourth # have to insinuate the ansi sequences after the string is wordwrapped # figure out the desired colour based on the classes provided. some # colours take priority over others. otherwise, pick the first # colour that's actually a colour. unless ($nocolour) { $colour = $ref->{'_texapp_classes'}; # test for major classes: me, reply if ($colour =~ /me/) { $colour = $CCme; } elsif ($colour =~ /reply/) { $colour = $CCreply; } elsif ($colour =~ /follow/) { $colour = $CCfollow; } else { my $w; my $thecolour = $CCdefault; # default major class # try to find the first colour that is NOT "OFF." FIRSTCOLOUR: foreach $w (split(/\//, $colour)) { if (${"CC$w"} ne $OFF && length(${"CC$w"})) { $thecolour = ${"CC$w"}; last; } } $colour = $thecolour; } $g = $colour; $colour = $OFF . $colour; } else { $g = $colour = ''; } # prepend screen name "badges" $sn = "\@$sn" if ($ref->{'reply_to'} > 0); $sn = "+$sn" if (length($ref->{'_texapp_latitude'}) && length($ref->{'_texapp_longitude'})); $sn = "&$sn" if ($ref->{'_texapp_has_entity_links'}); $sn = "#$sn" if ($ref->{'_texapp_has_hashtags'}); # future work $sn = "%$sn" if (length($ref->{'repost_of'}->{'id'})); $sn = "*$sn" if ($ref->{'source'}->{'name'} =~ /Texapp/ && $texappistas); $sn = "~$sn" if ($ref->{'thread_id'} > 0 && $threads_match{$ref->{'thread_id'}}); # prepend list information, if this post originated from a list $sn = "($ref->{'_texapp_tag'}->{'payload'})$sn" if (length($ref->{'_texapp_tag'}->{'payload'}) && $ref->{'_texapp_tag'}->{'type'} eq 'list'); if (length($post)) { if ($post =~ s#^/me ##) { $post = "[<$sn> $post]"; } else { $post = "<$sn> $post"; } } else { $post = "{<$sn> deleted this post}"; } # append star count $h = $ref->{'repost_of'}->{'num_stars'} || $ref->{'num_stars'}; $h += 0; $post = "(*${h}) $post" if ($h); # append reply count (maybe later) # append repost count $h = $ref->{'repost_of'}->{'num_reposts'} || $ref->{'num_reposts'}; $h += 0; $post = "(x${h}) $post" if ($h && !$nonewrps); # T@br3nda's modified timestamp patch if ($timestamp) { my ($time, $ts) = &$wraptime($ref->{'created_at'}); $post = "[$ts] $post"; } # pull it all together $post = &wwrap($post, ($wrapseq <= 1) ? ((&$prompt(1))[1]+$indent) : $indent) if ($wrap); # remember to account for prompt length on #1 $post =~ s/^([^<]*)<([^>]+)>/${g}\1<${EM}\2${colour}>/ unless ($nocolour); $post =~ s/\n*$//; $post .= ($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 $post =~ s/(^|[^a-zA-Z0-9])($h)([^a-zA-Z0-9]|$)/\1${EM}\2${colour}\3/ig unless ($nocolour); } } # T@smb's underline/bold patch goes on last (modified for lists) unless ($nocolour) { # only do this after the < > portion. my $k = index($post, ">"); my $botsub = substr($post, $k); my $topsub = substr($post, 0, $k); $botsub =~ s/(^|[^a-zA-Z0-9_]|\\n)\@([a-zA-Z0-9_\/]+)/\1\@${UNDER}\2${colour}/g; $post = $topsub . $botsub; } return $post; } # do the same, but for the interactive menu (called by defaulthandle) sub standardpostinteractive { my $post_ref = shift; my $class = shift; my $dclass = ($verbose) ? "{$class,$post_ref->{'id'}} " : ''; my $sn = &descape($post_ref->{'user'}->{'username'}); my $post = &descape($post_ref->{'text'}); my $menu_select = $post_ref->{'_texapp_menu_select'}; $menu_select = (length($menu_select) && !$script) ? (($menu_select =~ /^z/) ? "${EM}${menu_select}>${OFF} " : "${menu_select}> ") : ''; my $spost = &standardpost($post_ref, 0, length($menu_select . $dclass)); return ($menu_select . $dclass . $spost); } # this is done by pmscan and pmrefresh so that the caches are ready to go sub pmchanneltocontext { my $context = shift; my %new_context; my %uids; my @unames; my @unames2; #TODO # if the channel has a mutable ACL, we're going to have problems # when we cache this since the user permission lists could change, # so warn the user. net.app.core.pm channels should ALWAYS be # immutable, per @berg, and that's all we support. &sto("** warning: channel found with mutable ACL\n". "** this might affect your ability to read or write messages\n") if ($context->{'readers'}->{'immutable'} eq 'false' || $context->{'writers'}->{'immutable'} eq 'false'); # take the union of reader and writer UIDs from the context channel map { $uids{$_}++ } (@{ $context->{'readers'}->{'user_ids'} }); map { $uids{$_}++ } (@{ $context->{'writers'}->{'user_ids'} }); $uids{$context->{'owner'}->{'id'}}++; $uids{$whoamid}++ if ($context->{'readers'}->{'you'} eq 'true' || $context->{'writers'}->{'you'} eq 'true'); # assign owner and usernames $new_context{'owner'} = $context->{'owner'}->{'username'}; @unames = map { &get_user_by_id($_) } (keys %uids); # it is possible for errors to make @unames fail. if it has null # names, return an undef return undef if(scalar(grep { !length($_) } @unames)); $new_context{'users'} = \@unames; $new_context{'id'} = $context->{'id'}; return \%new_context; } sub users_not_me { # take a list of usernames, remove mine from it return grep { lc($_) ne $whoami } (@_); } # format a PM based on standard user options sub standardpm { my $ref = shift; my $context = shift; my $nocolour = shift; my $indent = shift; my %uids; my ($time, $ts) = &$wraptime($ref->{'created_at'}); my $text = &descape($ref->{'text'}); my $wasdel = (length($text)) ? "" : " was deleted"; my $sns = &descape($ref->{'user'}->{'username'}); # remove the sender from the list of users since they always get it $sns .= "->" . join(' ', grep { lc($sns) ne $_ } @{ $context->{'users'} }); $sns = "+$sns" if (length($ref->{'_texapp_latitude'}) && length($ref->{'_texapp_longitude'})); $sns = "&$sns" if ($ref->{'_texapp_has_entity_links'}); $sns = "*$sns" if ($ref->{'source'}->{'name'} =~ /Texapp/ && $texappistas); my $g = &wwrap("[PM${wasdel}]". "[$sns/$ts] $text", ($wrapseq <= 1) ? ((&$prompt(1))[1]+$indent) : $indent); # $g =~ s/^\[PM ([^\/]+)\//${CCpm}[PM ${EM}\1${OFF}${CCpm}\// # unless ($nocolour); $g = "${CCpm}$g" unless ($nocolour); $g =~ s/\n*$//; $g .= ($nocolour) ? "\n" : "$OFF\n"; $g =~ s/(^|[^a-zA-Z0-9_])\@(\w+)/\1\@${UNDER}\2${OFF}${CCpm}/g unless ($nocolour); return $g; } sub standardpminteractive { my $pm_ref = shift; my $context = shift; my $menu_select = $pm_ref->{'_texapp_menu_select'}; my $spm = &standardpm($pm_ref, $context, 0, length($menu_select)+1); $spm =~ s/\[PM/\[PM $menu_select/; # no g, no i return $spm; } # do precalculations on a PM channel to get a distilled context # 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'}); # T@episod has promised me he will document all of the events. # still waiting ... if (length($verb)) { # delete is different. my $tar_sn = '@'.&descape($ref->{'target'}->{'username'}); my $sou_sn = '@'.&descape($ref->{'source'}->{'username'}); if ($verb eq 'favorite' || $verb eq 'unfavorite') { my $txt = &descape($ref->{'target_object'}->{'text'}); $g .= "$sou_sn just ${verb}d ${tar_sn}'s post: \"$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)"; #TODO # these need to be fleshed out } elsif ($verb eq 'list_member_added') { $g .= "$sou_sn added $tar_sn to a list"; } elsif ($verb eq 'list_member_removed') { $g .= "$sou_sn removed $tar_sn from a list"; } elsif ($verb eq 'list_user_subscribed') { $g .= "$sou_sn is now following a list from $tar_sn"; } elsif ($verb eq 'list_user_unsubscribed') { $g .= "$sou_sn is no longer following a list from $tar_sn"; } elsif ($verb eq 'list_create') { $g .= "$sou_sn created a new list"; } elsif ($verb eq 'list_destroyed') { $g .= "$sou_sn destroyed a list"; } elsif ($verb eq 'list_updated') { $g .= "$sou_sn updated a list"; } 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)"; } } 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 post it is, since that # would be embarrassing, so just say a delete occurred. $g .= "post ID# ".$ref->{'delete'}->{'status'}->{'id'}. " deleted by server"; } 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 &grabjadn to get a hashref # corresponding to parsed JSON from an arbitrary resource. # see that function later on. #### DEFAULT Texapp 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 multipmconclude { &multi_module_dispatch(\&defaultpmconclude, \@m_pmconclude, 0, @_); } sub multipmhandle { &multi_module_dispatch(\&defaultpmhandle, \@m_pmhandle, sub { my $rv = shift; # skip default calls. return 0 if ($this_call_default); # if not a default call, and the PM was refused for # processing by this extension, then the PM 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/pmhandle, 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 multicollectsave { &multi_module_dispatch(\&defaultcollectsave, \@m_collectsave, 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 post was refused for # processing by this extension, then the post 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 multiposttype { &multi_module_dispatch(\&defaultposttype, \@m_posttype, 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 defaultcollectsave { (&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 $post_ref = shift; my $class = shift; &sto(&standardpostinteractive($post_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'}->{'text'})); 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; # add to the user cache in foreground as these are discovered unless ($is_background) { my $k = lc(&descape($my_json_ref->{'username'})); $user_cache{$k} = $my_json_ref->{'user'}->{'id'}; $user_id_cache{$user_cache{$k}} = $k; } my $species = ucfirst($my_json_ref->{'type'}); $species = (length($species) && $species ne 'Human') ? " ($species)" : ""; my $muted = ($my_json_ref->{'you_blocked'} eq 'true') ? "${EM}(Blocked)${OFF} " : ($my_json_ref->{'you_muted'} eq 'true') ? "${EM}(Muted)${OFF} " : ''; print $fh <<"EOF"; ${CCprompt}@{[ &descape($my_json_ref->{'name'}) ]}${OFF} (@{[ &descape($my_json_ref->{'username'}) ]}) (f:$my_json_ref->{'counts'}->{'following'}/$my_json_ref->{'counts'}->{'followers'}) (p:$my_json_ref->{'counts'}->{'posts'})${species} ${muted} EOF return; } sub sendnotifies { # this is a default subroutine of a sort, right? my $post_ref = shift; my $class = shift; my $sn = &descape($post_ref->{'user'}->{'username'}); my $post = &descape($post_ref->{'text'}); # interactive? first time? unless (length($class) || !$last_id || !length($post)) { my $subclass; $class = $post_ref->{'_texapp_classes'}; NOTIFYNOTIFY: foreach $subclass (split(/\//, $class)) { if ($notify_list{$subclass}) { # only send one notify (the first one) # but include the entire list of classes ¬ifytype_dispatch($class, &standardpost($post_ref, 1), $post_ref) ; last NOTIFYNOTIFY; } } } } sub defaultposttype { (&flag_default_call, return) if ($multi_module_context); my $ref = shift; my $sn = shift; my $post = shift; my $subclasses = ''; my $h; # fast path: me never has subclasses unless ($anonymous) { if (lc($sn) eq $whoami) { # if it's me speaking, colour the line yellow return 'me'; # this never has subclasses } } $subclasses = ($ref->{'user'}->{'you_follow'} eq 'true' || $ref->{'user'}->{'is_follower'} eq 'true') ? '/follow' : '/alien'; # add on other subclasses # identify if there are search terms here (causes less problems # than trying to fix the payload in &refresh) if(scalar(@tracktags)) { POSTTYPETTRACKTAG: foreach $h (@tracktags) { if ($post =~ /(^|[^a-zA-Z0-9])($h)([^a-zA-Z0-9]|$)/i) { $subclasses .= '/search'; last POSTTYPETTRACKTAG; } } } $subclasses .= '/subthread' if ($ref->{'_texapp_tag'}->{'type'} eq 'subthread'); $subclasses .= '/list' if ($ref->{'_texapp_tag'}->{'type'} eq 'list'); # now replies: second highest precedence unless ($anonymous) { if ($post =~ /\@$whoami(\b|$)/i) { # if I'm in the post, colour red return "reply$subclasses"; } } # not me or reply # if we have subclasses, promote them return (length($subclasses)) ? substr($subclasses, 1) : # we don't, return default. in practice, this won't appear. "default"; } sub defaultconclude { (&flag_default_call, return) if ($multi_module_context); my $dont_collapse = shift; if ($filter_attribs{'count'}) { if ($dont_collapse && $filtered) { &std("-- (filtered $filtered posts)\n"); $lastfiltered = 0; } else { $lastfiltered += $filtered; if ($lastfiltered > 1) { &std("-- (filtered $lastfiltered posts)\n"); $lastfiltered = 0; } } } $filtered = 0; } sub defaultpmhandle { (&flag_default_call, return) if ($multi_module_context); my $pm_ref = shift; my $pm_context = shift; my $sns = &descape($dm_ref->{'sender'}->{'username'}); &sto(&standardpminteractive($pm_ref, $pm_context)); return 1; } sub sendpmnotifies { my $pm_ref = shift; my $pm_context = shift; ¬ifytype_dispatch('PM', &standardpm($pm_ref, $pm_context, 1), [ $pm_ref, $pm_context ]) if ($notify_list{'pm'} && $last_pm); } 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'}); &sto(&standardevent($event_ref)); return 1; } sub defaultpmconclude { (&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 =~ /^[pP]\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', '/pmagain', '/wagain', '/whois', '/thump', '/pm', '/pmscan', '/refresh', '/repostsof', '/set', '/help', '/pmclose', '/reply', '/url', '/thread', '/repost', '/replyall', '/replies', '/ruler', '/exit', '/me', '/vcheck', '/orepost', '/erepost', '/frepost', '/liston', '/listoff', '/starsof', '/replyg', '/replyh', '/lists', '/withlist', '/add', '/padd', '/push', '/pop', '/followers', '/friends', '/lfollow', '/lleave', '/listfollowers', '/listfriends', '/unset', '/verbose', '/short', '/follow', '/unfollow', '/doesfollow', '/search', '/tron', '/troff', '/flushtab', '/delete', '/deletelast', '/dump', '/global', '/personal', '/save', '/mute', '/unmute', '/muted', '/track', '/trends', '/block', '/unblock', '/blocked', '/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 /pm, /wa, /wagain, # /a, /again, etc. if (($line =~ m#^(/pm|/wa|/wagain|/a|/again|/doesfollow|/df) #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 Texapp 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 'Texapp' 'Texapp: $class'"); binmode(GROWL, ":utf8") unless ($seven); print GROWL $text; close(GROWL); exit; } # alloy/terminal-notifier for OS X 10.8+, mostly based on Growl sub notifier_osxnc { 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 terminal-notifier in /Applications", "/Applications/terminal-notifier.app/Contents/MacOS/terminal-notifier", "terminal-notifier must be installed to use OS X notifications. check your\n" . "documentation for how to do this.\n") unless ($notify_tool_path); if (!defined($class)) { return 1 if ($script || $notifyquiet); $class = 'OS X Notification Center support activated'; $text = 'PowerPC forever!'; } } # 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 notifier 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 notifier fork: $!\n"; exit; } # this is the subchild, which is abandoned at a fire sta^W^W^Winit. # make it be quiet when we remove old posts. my $r = ($class eq 'PM') ? "" : "-remove Texapp -group Texapp"; open(OSXNC, "|$notify_tool_path -title 'Texapp' -subtitle '$class' -activate com.apple.Terminal $r >/dev/null 2>&1"); binmode(OSXNC, ":utf8") unless ($seven); print OSXNC $text; close(OSXNC); exit; } # libnotify for {Linux,whatevs} # this is EXPERIMENTAL, and requires this patch to notify-send: # http://www.floodgap.com/software/texapp/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 Texapp.'; } } # figure out the time to display based on length of post my $t = 2000+100*length($text); # about 100-120wpm read speed open(NOTIFYSEND, "|$notify_tool_path -t $t -f - 'Texapp: $class'"); binmode(NOTIFYSEND, ":utf8") unless ($seven); $text =~ s/\&/\&/g; print NOTIFYSEND $text; close(NOTIFYSEND); return 1; } #### implement user cache #### # fetch id for a user from the cache or the server sub get_user { my $user = lc(shift); return $whoamid if ($user eq $whoami); return $user_cache{$user} if ($user_cache{$user}); my $json_ref = &grabjadn("${uidurl}\@${user}", 0, 0, 0, undef, 1); #TODO # try to cache failure, but not transient failure return undef if (!$json_ref || ref($json_ref) ne 'HASH' || !defined($json_ref->{'id'})); $user_id_cache{$json_ref->{'id'}} = $user; return ($user_cache{$user} = $json_ref->{'id'}); } sub get_user_by_id { my $uid = lc(shift); return $whoami if ($user eq $whoamid); return $user_id_cache{$uid} if ($user_id_cache{$uid}); my $json_ref = &grabjadn("${uidurl}${uid}", 0, 0, 0, undef, 1); #TODO # try to cache failure, but not transient failure return undef if (!$json_ref || ref($json_ref) ne 'HASH' || !defined($json_ref->{'username'})); $user_cache{$json_ref->{'username'}} = $uid; return ($user_id_cache{$uid} = $json_ref->{'username'}); } #### IPC routines for communicating between the foreground + background #### # this is the central routine that takes a rolling post code, figures # out where that post is, and returns something approximating a post # structure (or the actual post structure itself if it can). $last_fetched_code = ''; $last_fetched_ref = undef; sub get_post { my $code = lc(shift); #TODO # this needs a better way to be invalidated by the background. #return $last_fetched_ref if ($last_fetched_code eq $code); # if the code is all numbers, treat it like an id, and try # to get it from the server. we have similar code in get_pm. #TODO # implement querying the id_cache here. we need IPC for it, though. return &grabjadn(&urlp($idurl,,$code), 0, 0, 0, undef, 1) if ($code =~ /^[0-9]+$/); 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) < 8192) { sysread(W, $l, 8192); $k .= $l; } return undef if ($k !~ /[^\s]/); $k =~ s/\s+$//; # remove trailing spaces print $stdout "-- background store fetch: $k\n" if ($verbose); ($w->{'_texapp_menu_select'}, $w->{'id'}, $w->{'reply_to'}, $w->{'repost_of'}->{'id'}, $w->{'repost_of'}->{'thread_id'}, $w->{'_texapp_has_entity_links'}, $w->{'_texapp_latitude'}, $w->{'_texapp_longitude'}, $w->{'_texapp_tag'}->{'type'}, $w->{'_texapp_tag'}->{'payload'}, $w->{'_texapp_classes'}, $w->{'num_replies'}, $w->{'num_stars'}, $w->{'thread_id'}, $w->{'num_reposts'}, $w->{'user'}->{'username'}, $w->{'created_at'}, ##### HEY YOU! UPDATE THE NUMBER BELOW IF YOU ADD IPC FIELDS! ##### $l) = split(/\s/, $k, 18); ($w->{'source'}->{'name'}, $k) = split(/\|/, $l, 2); $w->{'text'} = pack("H*", $k); $w->{'_texapp_tag'}->{'payload'} = pack("H*", $w->{'_texapp_tag'}->{'payload'}); return undef if (!length($w->{'text'})); # unpossible $w->{'created_at'} =~ s/_/ /g; print $stdout "-- successfully retrieved from background\n" if ($verbose); $last_fetched_code = $code; $last_fetched_ref = $w; return $w; } # this is a variation. it follows the post back, even through reposts, to # get the original ID. it calls get_post, and if it gets back a repost_of, # it calls get_post on that, until it gets something that is not a repost. sub get_original_post { my $ref = &get_post; # with the same args while(defined($ref) && length($ref->{'repost_of'}->{'id'})) { $ref = &get_post($ref->{'repost_of'}->{'id'}); } return $ref; } # this gets the *context* of a PM (i.e., the distilled internal representation # of a channel). the context could be in the foreground or the background. sub get_pm_context { my $code = lc(shift); my $k = ''; my $l = ''; my $m = ''; my $w = { }; my @u; return undef if (length($code) < 3 || $code !~ s/^p//); if ($code =~ /^z/) { return undef if ($is_background); return $pm_context_hash{$code}; } return $pm_context_hash{$code} if ($is_background); print $stdout "-- querying background: $code\n" if ($verbose); kill $SIGUSR2, $child if ($child); print C "piped $code ----------\n"; while(length($k) < 8192) { sysread(W, $l, 8192); $k .= $l; } return undef if ($k !~ /[^\s]/); $k =~ s/\s+$//; # remove trailing spaces print $stdout "-- background store fetch: $k\n" if ($verbose); ($w->{'id'}, $w->{'owner'}, $m, $k) = split(/\s+/, $k, 4); @u = split(/\|/, $m); $w->{'users'} = \@u; return $w; } # this is the analogous function for a rolling PM code. note that this # is not much good without a channel context. sub get_pm { my $code = lc(shift); my $k = ''; my $l = ''; my $w = { }; return undef if ($code !~ s/^p//); # this is the aforementioned "similar code" (see get_post). if ($code =~ /^[0-9]+$/) { # this end point gives us an array, even though we ask # just for one. my $ref = &grabjadn("${msbyidurl}?ids=$code", 0, 0, 0, undef, 1); return undef if (ref($ref) ne 'ARRAY'); return $ref->[0]; } return undef if (length($code) < 2); if ($code =~ /^z/) { return undef if ($is_background); return $pm_store_hash{$code}; } return $pm_store_hash{$code} if ($is_background); print $stdout "-- querying background: $code\n" if ($verbose); kill $SIGUSR2, $child if ($child); # prime pipe print C "pipep $code ----------\n"; # internally two alphanum, recall while(length($k) < 8192) { sysread(W, $l, 8192); $k .= $l; } return undef if ($k !~ /[^\s]/); $k =~ s/\s+$//; # remove trailing spaces print $stdout "-- background store fetch: $k\n" if ($verbose); ($w->{'_texapp_menu_select'}, $w->{'id'}, $w->{'channel_id'}, $w->{'_texapp_has_entity_links'}, $w->{'_texapp_latitude'}, $w->{'_texapp_longitude'}, $w->{'user'}->{'username'}, $w->{'created_at'}, $w->{'source'}->{'name'}, $l) = split(/\s/, $k, 10); $w->{'text'} = pack("H*", $l); return undef if (!length($w->{'text'})); # not possible $w->{'source'}->{'name'} =~ 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, 8192); while(length($k) < 8192) { sysread(W, $l, 8192); $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, 8192); return if (!length($value)); print C substr(unpack("${pack_magic}H*", $value).$space_pad, 0, 8192); } sub hold { print C "hold---------------\n" unless ($synch); &sync_semaphore; } sub thump { print C "update-------------\n"; &sync_semaphore; } sub sthump { print C "updateno-----------\n"; &sync_semaphore; } sub pmthump { print C "pmthump------------\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'); &threads_compile($value, 0) if ($key eq 'threads'); &filter_compile if ($key eq 'filter'); ¬ify_compile if ($key eq 'notifies'); &list_compile if ($key eq 'lists'); &dontautoreply_compile if ($key eq 'dontautoreply'); &filterflags_compile if ($key eq 'filterflags'); &filterclients_compile if ($key eq 'filterclients'); $filterrps_sub = &filterlist_compile( $filterrps_sub, $value) if ($key eq 'filterrps'); $filterusers_sub = &filterlist_compile( $filterusers_sub,$value) if ($key eq 'filterusers'); $filteratonly_sub = &filterlist_compile( $filteratonly_sub, $value) if ($key eq 'filteratonly'); $filterthreads_sub = &filterlist_compile( $filterthreads_sub, $value) if ($key eq 'filterthreads'); &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) ? '=' : '+'; return if (!$child); print $stdout "*** (transmitting to background)\n" if ($interactive || $verbose); kill $SIGUSR2, $child; print C (substr("${commchar}$key ", 0, 19) . "\n"); print C (substr(($value . $space_pad), 0, 8192)); 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 = ''; my $buf = ''; kill $SIGUSR2, $child if ($child); print C (substr("?$key ", 0, 19) . "\n"); while (length($value) < 8192) { sysread(W, $buf, 8192); $value .= $buf; } $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; if (lc($url) eq 'http://app.net' || lc($url) eq 'http://app.net/') { unless ($openappnettoo) { print $stdout "-- (incidental app.net link, suppressed, -openappnettoo to disable)\n"; return; } } $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 urlnoproto { my $url = shift; $url =~ s/^[^:]+://; return $url; } 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 ##### # compile and verify $threads sub threads_compile { my $value = shift; my $auto = shift; my $w; my $errors = 0; %threads_match = (); foreach $w (split(/[\s,]+/, $value)) { if ($w =~ /[^0-9]/) { &std("** ignoring bogus thread id #$w\n") unless ($auto); $errors++; next; } if ($threads_match{$w}++) { &std("** ignoring duplicate thread id #$w\n") unless ($auto); $errors++; next; } } (@subscribed_threads) = keys(%threads_match); return $errors; } # 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 = "text=$value" if ($value !~ /=/); 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 T@kellyterryjones' code) sub tracktags_compile { @trackstrings = (); return if (!scalar(@tracktags)); my $k; my $l = ''; # limit track tags to a certain number of pieces TAGBAG: foreach $k (@tracktags) { push(@trackstrings, "text=".&url_oauth_sub($k)) if (length($k)); } return; if(0) { # when ADN supports logical operators, use this code for # the loop if (length($l)+length($k) > 150) { # balance of size/querytime push(@trackstrings, "text=".&url_oauth_sub($l)) unless (!length($l)); $l = ''; } $l = (length($l)) ? "${l} OR ${k}" : "${k}"; } push(@trackstrings, "text=".&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; } # -dontautoreply compiler sub dontautoreply_compile { my $s = $dontautoreply; undef %dontautoreply_; $s =~ s/^\s*['"]?\s*//; $s =~ s/\s*['"]?\s*$//; return if (!length($s)); %dontautoreply_ = map { $_ => 1 } split(/\s*,\s*/, $s); } # -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); } # this is a generic compiler for filter expressions consisting of a simple # list without regexes, so they are fast and the same code suffices. emit # code to compile that's just one if-expression after another. sub filterlist_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 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; } sub filterclients_compile { undef $filterc_c; if (length($filterclients)) { my $tfilter = $filterclients; $tfilter =~ s/^['"]//; $tfilter =~ s/['"]$//; my $b = <<"EOF"; \$filterc_c = sub { local \$_ = shift; return ($tfilter); }; EOF #print $b; eval $b; if (!defined($filterc_c)) { &std("** syntax error in your filterclients: $@\n"); return 0; } } return 1; } #### common system subroutines follow #### sub updatecheck { my $update_url = shift; my $no_mirrors = shift; my $vcheck_url = ( "http://www.floodgap.com/software/texapp/00current.txt", "http://floodgapmirror.cobryce.com/software/texapp/00current.txt", )[rand(($no_mirrors) ? 0 : 2)]; my $vrlcheck_url = ( "http://www.floodgap.com/software/ttytter/01readlin.txt", "http://floodgapmirror.cobryce.com/software/ttytter/01readlin.txt", )[rand(($no_mirrors) ? 0 : 2)]; 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 Texapp 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 'texapp') { $vs .= "-- warning: unable to verify Texapp version\n"; } else { if ($my_version_string eq $bversion) { $vs .= "** REMINDER: you are using a beta version (${my_version_string}b${Texapp_RC_NUMBER})\n"; $vs .= "** NEW Texapp RELEASE CANDIDATE AVAILABLE: build $rcnum **\n" . "** get it: $bdownload\n$s2" if ($Texapp_RC_NUMBER < $rcnum); $vs .= "** (this is the most current beta)\n" if ($Texapp_RC_NUMBER == $rcnum); $vs .= "$s1$s3"; if ($Texapp_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 && $Texapp_RC_NUMBER) { $vs .= "** FINAL Texapp 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+$Texapp_VERSION < $maj || (0+$Texapp_VERSION == $maj && $Texapp_PATCH_VERSION < $min)) { $vs .= "** NEWER Texapp 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+$Texapp_VERSION > $maj || (0+$Texapp_VERSION == $maj && $Texapp_PATCH_VERSION > $min)) { if ($no_mirrors) { $vs .= "** unable to identify your version of Texapp\n$s1"; } else { $vs .= "** unable to identify your version of Texapp; trying again without mirrors\n$s1" . &updatecheck($update_url, 1); } } else { $vs .= "-- your version of Texapp is up to date ($inversion)\n$s1"; } } # if we got this far, then there is no Texapp 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 { print $stdout "-- end_me: @_\n" if ($verbose); exit; } # which falls through to, via END, ... sub killkid { print $stdout "\n\ncleaning up.\n" unless ($status || $script); # do not save state here. this can be called by END if there is a # critical shutdown. the console is responsible for calling savestate # after it successfully exits. unless ($savequit || $script || $status) { print $stdout "no autosave (set savequit=1 to enable).\n"; 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; } # for streaming assistance if ($child) { kill $SIGHUP, $child; # warn it about shutdown 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 pm reply warn search list default follow alien)) { ${"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); } sub urlp { my $url = shift; my $user = shift || $whoamid; my $id = shift || $user || 0; $url =~ s/\%U/$user/g; $url =~ s/\%I/$id/g; return $url; } # 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 =~ /^\[?\]?/i || $data =~ /^<\??xml\s+/) { print $stdout $data if ($superverbose); if (&is_fail_whale($data)) { &$exception(2, "*** warning: ADN Fail Whale\n"); } else { &$exception(2, "*** warning: ADN error message received\n" . (($data =~ /ADN:\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 $get_annotations = shift; my $before_id = 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. push (@xargs, "since_id=${last_id}") if ($last_id); # request annotations unless told not to push (@xargs, "include_annotations=1") if ($get_annotations); # cap the IDs to prior to before_id if specified push (@xargs, "before_id=$before_id") if ($before_id); 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: ADN Fail Whale\n"); } else { &$exception(2, "*** warning: ADN error message received\n" . (($data =~ /<title>ADN:\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; } $my_json_ref = &parsejson($data); if(0) { # normalize the data into a standard form. # single posts 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'}))) { $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; } # like grabjson, but unwraps the JSON response envelope sub grabjadn { my $url = shift; my $last_id = shift; my $is_anon = shift; my $count = shift; my $tag = shift; my $get_annotations = shift; my $before_id = shift; #my $my_json_ref = &grabjson; # passes all args my $my_json_ref = &grabjson($url, $last_id, $is_anon, $count, $tag, $get_annotations, $before_id); return ($my_json_ref) if ($undef); # normalize posts and PMs if ($my_json_ref->{'data'}) { if (ref($my_json_ref->{'data'}) eq 'HASH' && $my_json_ref->{'data'}->{'source'} && length($my_json_ref->{'data'}->{'id'}) && ($my_json_ref->{'data'}->{'you_reposted'} || $my_json_ref->{'data'}->{'channel_id'})) { $my_json_ref->{'data'} = &normalizejson($my_json_ref->{'data'}); } if (ref($my_json_ref->{'data'}) eq 'ARRAY') { my $i; foreach $i (@{ $my_json_ref->{'data'} }) { $i = &normalizejson($i, 0, $tag); } } # attempt to put 'meta' in 'data', if 'data' is a hashref # otherwise, the consumer will have to call grabjson directly. $my_json_ref->{'data'}->{'meta'} = $my_json_ref->{'meta'} if ($my_json_ref->{'meta'} && ref($my_json_ref->{'data'} eq 'HASH')); return (wantarray) ? ($my_json_ref->{'data'}, $my_json_ref->{'meta'}) : $my_json_ref->{'data'}; } return (wantarray) ? (undef, $my_json_ref) : ($my_json_ref); # it will have a meta tag that is an error } # takes a post structure and normalizes it according to settings. # what this currently does is the following gyrations: # - if there is no id, see if we can convert id into one. if # there is loss of precision, warn the user. same for # reply_to. (this is currently disabled) # - if the calling function has specified a tag, tag the posts, since # we're iterating through them anyway. the tag should be a hashref payload. # - if the post is a repost, unwrap it so that the full post text is # revealed (unless -nonewrps). # - figure out all post classes using &$posttype, if this appears to be posts. sub normalizejson { my $i = shift; my $kludge_search_api_adjust = shift; my $tag = shift; my $rt; # tag the post if (defined($tag)) { # copy the tag, assuming that _tag and _payload are scalar. # this avoids a lot of problems with reference aliasing! # force new strings to be made as well. $i->{'_texapp_tag'}->{'type'} = "$tag->{'type'}"; $i->{'_texapp_tag'}->{'payload'} = "$tag->{'payload'}"; } # set entities flag for performance/marking my $haz_entilinks = $i->{'entities'}->{'links'}; $i->{'_texapp_has_entity_links'} = 1 if (ref($haz_entilinks) eq 'ARRAY' && scalar(@{ $haz_entilinks })); # scan annotations my $haz_annos = $i->{'annotations'}; if (scalar(@{ $haz_annos })) { my $a_ref; foreach $a_ref (@{ $haz_annos }) { if ($a_ref->{'type'} eq 'net.app.core.geolocation') { $i->{'_texapp_latitude'} = $a_ref->{'value'}->{'latitude'}; $i->{'_texapp_longitude'} = $a_ref->{'value'}->{'longitude'}; } elsif ($a_ref->{'type'} eq 'net.app.core.oembed') { # treat oembed URLs as entity links $i->{'_texapp_has_entity_links'} = 1; } } } # do things that only apply to posts. if ($i->{'thread_id'}) { # precompute classes since we have a full JSON object. $i->{'_texapp_classes'} = &$posttype($i, &descape($i->{'user'}->{'username'}), &descape($i->{'text'})); } if(0) { # id -> id if needed if (!length($i->{'id'})) { my $k = "" + (0 + $i->{'id'}); if ($k !~ /[eE][+-]/) { $i->{'id'} = $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'} = $k; } } # irtsid -> irtsid (if there is one) if (!length($i->{'reply_to'}) && $i->{'reply_to'}) { my $k = "" + (0+$i->{'reply_to'}); if ($k !~ /[eE][+-]/) { $i->{'reply_to'} = $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->{'reply_to'} = $k; } } # normalize geo. if this has a source and it has a # favorited, then it is probably a post 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 -nonewrps, oh well if (!$nonewrps && ($rt = $i->{'repost_of'})) { # This should not be needed for ADN. #$i->{'repost_of'} = &destroy_all_tco($rt); #$i->{'text'} = #"RT \@$rt->{'user'}->{'username'}" . ': ' . $rt->{'text'}; } } return $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; # eight, because eval eats the escapes $data =~ s/$ddqqmask/"/g; print $stdout "$data\n" if ($superverbose); # trust, but verify. I'm sure ADN 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>ADN.+Over.+capacity.*#i || $data =~ m#[\r\l\n\s]*DB_DataObject Error: Connect failed#s); } sub is_json_error { # is this actually a JSON error message? if so, extract it my $data = shift; if ($data =~ /meta/ && $data =~ /code/ && $data =~ /error/) { my $dref = &parsejson($data); return $data if (!$dref || ref($dref) ne 'HASH'); $dref = $dref->{'meta'}; return undef if ($dref->{'code'} eq '200'); # weird return $dref->{'error_message'} || $dref->{'error_slug'} || $dref->{'code'} || $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() { $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; # protect double backslashes my $bbqqmask = "BBQQ"; $seed = 0; $seed++ while ($data =~ /$bbqqmask$seed/); $bbqqmask .= $seed; $x =~ s/\\\\/$bbqqmask/g; # handle backslashed entities and newlines if ($newline) { $x =~ s/\\r//sg; $x =~ s/\\t/ /g; if ($x =~ /\\n/) { # add a leading newline for ASCII art and such things my $nlc = 0; ++$nlc while $x =~ s/\\n/\n/s; $x = "\n$x" if ($nlc > 2); } } $x =~ s#$bbqqmask#\\#sg; # 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); # ADN 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; } 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, ADN 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; } # take a string and return up to $linelength CHARS plus the rest. sub csplit { return &cosplit(@_, sub { return length(shift); }); } # take a string and return up to $linelength BYTES plus the rest. sub usplit { return &cosplit(@_, sub { return &ulength(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 $maxlength = shift || $linelength; 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 <= $maxlength); # 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 Ps for PMs) $r .= $1 while ($k =~ s/^(\@[^\s]+\s)\s*// || $k =~ s/^(P\s+[^\s]+\s)\s*//); # we have r/a, so while $k = "$r$k"; my $i = $maxlength; $i-- while(($z = &$lengthsub($q = substr($k, 0, $i))) > $maxlength); $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) < $maxlength) { $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; } # simple json encoder sub encodejson { my $x = shift; # Unicode-encode the literal \s, it's easier to handle. # do this like parsejson does using a unique sequence. my $bbqqmask = "BBQQ"; my $seed = 0; $seed++ while ($x =~ /$bbqqmask$seed/); $bbqqmask .= $seed; 1 while ($x =~ s/\\/$bbqqmask/); $x =~ s/$bbqqmask/'\\\u005c'/eg; # \n and \" $x =~ s/\n/\\\\n/sg; #$x =~ s/"/\\\\"/g; # \u escape everything else, even stuff that might not need to be. $x = &uforcemulti($x); $x =~ s/([^-0-9a-zA-Z._~\\ ])/'\\\u'.sprintf("%04x", ord($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" . " - ADN farted\n" . "fix these possible problems, or try again later.\n"); exit; }