pax_global_header00006660000000000000000000000064133554177470014532gustar00rootroot0000000000000052 comment=74b49466e37e9ead9f87616b7e82ed19f3f689c1 oysttyer-2.10.0/000077500000000000000000000000001335541774700135145ustar00rootroot00000000000000oysttyer-2.10.0/.travis.yml000066400000000000000000000001601335541774700156220ustar00rootroot00000000000000language: "perl" perl: - "5.22" - "5.20" - "5.18" - "5.16" - "5.14" install: true script: "perl -c oysttyer.pl" oysttyer-2.10.0/CHANGELOG.markdown000066400000000000000000001554151335541774700165620ustar00rootroot00000000000000#CHANGELOG ##Changes in Version 2.10 - Default to using extended tweet display ([#143](https://github.com/oysttyer/oysttyer/issues/143)) - Support new tweet size ([#131](https://github.com/oysttyer/oysttyer/issues/131)) - Print a separator between refreshes with the `separator` option ([#141](https://github.com/oysttyer/oysttyer/issues/141)) ## Version 2.9.1 ### Issues resolved - `synch` caused the program to hang ([#123](https://github.com/oysttyer/oysttyer/issues/123)) - The `/web` command did not work for tweets with a code beginning with "d". ([#122](https://github.com/oysttyer/oysttyer/issues/122)) ##Changes in Version 2.9: - Set the value of %URL% to the result of `/short` ([#112](https://github.com/oysttyer/oysttyer/issues112)) - Add support for Perl 5.30+ by replacing `sysread()` with `read()` ([#115](https://github.com/oysttyer/oysttyer/issues/115)) - Prevent crashes with `/list +N` ([#114](https://github.com/oysttyer/oysttyer/issues/114)) - Do not display notifcations when you like a tweet that was retweeted into your timeline ([#98](https://github.com/oysttyer/oysttyer/issues/98)) - Correctly counts the length of t.co links ([#116](https://github.com/oysttyer/oysttyer/issues/116)) - Add support for selecting `highest` or `lowest` resolution for videos ([#77](https://github.com/oysttyer/oysttyer/issues/77)) - Creates a lock file when running in daemon mode ([#106](https://github.com/oysttyer/oysttyer/pull/106)) - Open a tweet in a web browser with the `/web` command ([#101](https://github.com/oysttyer/oysttyer/issues/101)) ### Known issues - `synch` causes the program to hang ([#123](https://github.com/oysttyer/oysttyer/issues/123)) ##Changes in Version 2.8.1: - Fixes a bug introduced in 2.8.0 that caused multi-image tweets to only display the first image. ([#95](https://github.com/oysttyer/oysttyer/issues/95)) - Fixes a bug introduced in 2.8.0 that caused videos to display with an inconsistent type. Videos will now be displayed in mp4 if that format is available and fall back to m3u8. ([# 93](https://github.com/oysttyer/oysttyer/issues/93)) ##Changes in Version 2.8.0: - Add -extended option to support extended tweets (thanks, myshkin!) - Add -origimages option to request original-sized images (thanks, Wyatts) - Re-add mp4 URL replacement since that is still used for GIFs. ##Changes in Version 2.7.2: - Nothing, just constant goddamn interruptions mean I make silly mistakes with versioning. ##Changes in version 2.7.1: - Fixes /short. Needed updating to reflect latest is.gd API. ##Changes in version 2.7.0: - Adds /edm and /edmreply commands to use $EDITOR for replying to DMs - Summary of other DM enhancements already added in point releases: - Add the ability to share tweets via direct message with the `/qdm` command (Work towards of 2.7 milestone) - Expand long DMs suring start-up - Nicely truncate long DMs when using /dump - Fix a bug where whoami comparison was not lowercased for sent dms ##Changes in Version 2.6.4: - Add --http1.1 flag to curl to suit versions after 7.47.0. Earliest supported curl is now 7.33.0 ##Changes in version 2.6.3: - Nothing over 2.6.2. I just can't tag things properly ##Changes in version 2.6.2: - Correct year on startup screen - Adds very rudimentary CI syntax checks - Expand long DMs suring start-up - Nicely truncate long DMs when using /dump - Revert shebang to original - Fix a bug where whoami comparison was not lowercased for sent dms - Update userstream endpoint ##Changes in version 2.6.1: - Add the ability to share tweets via direct message with the `/qdm` command (Work towards of 2.7 milestone) - Use the Twitter account in the prompt instead of `oysttyer` when `showusername` is true. - Add ':large' to Twitter image URLs when `largeimages` is true. - Add a space between tweets when `doublespace` is true. - Fixed an issue where retweeted tweets displayed the wrong timestamp. - Fixed an issue where tco were not destroyed in threads - Display link to video file instead of link to video thumbnail in tweets - Display video files in `/entities` - Bring `/entities` back into Twitter TOS compliance and make it only open tco links (I.e. make it behave worse. Sorry) - Add tab expansion for like and retweet (missed from 2.5.1) ##Changes in version 2.6.0: - Finishes up newline support - Correctly counts characters for strings with newlines that are being sent. I.e. `\n` counts as one character. - Summary of newline behaviour already implemented: - Any `\n` in a tweet will be sent as a newline - To send a literal `\` followed by a `n` you have to escape and type `\\n`. - The `-newline` command line argument/option can now be optionally set to `-newline=replace` as well as on/off (`1` or `0`) - If newline is set to replace then you can specify what oysttyer uses for display of newlines using `-replacement_newline` and `-replacement_carriagereturn` or use the default replacement characters - Note: If using `-newline=replace` there is currently no way for oysttyer to differentiate between actual newlines and literal `\`s followed by literal `n`s and both will get replaced. ##Changes in version 2.5.2: - Add /mute /unmute functionality ##Changes in version 2.5.1: - favorites changed to likes (Twitter made everyone do it!) - Quick, perhaps temporary, fix to allow users to specify their own oauthkey and oauthsecret in their .oysttyerrc to work around the current muzzling issues - fix /vre to not break threading - Allow custom newline replacement characters ##Changes in version 2.5.0: - Rename to oysttyer - Change API key, etc - No new features or function changes since 2.4.2, just renaming ##Changes in version 2.4.2: - Start implementing improved newline behaviour, towards 2.6.0 milestone. - Can now send newlines with literal "\" followed by literal "n". - Allow sending longer DMs (2.7.0 milestone) - Remove own username when replying to self. ##Changes in version 2.4.1: - Fix "display" of multiple images in tweets so extensions can pick them up. Specifically so deshortify can underline them. ##Changes in version 2.4.0: - Version checking url changed to this repo on Github so I don't have to spam Twitter everytime I've updated ##Changes in version 2.3.1: - Update built-in help to reflect that /rt can be used to create quote tweets ##Changes in version 2.3.0: - "Displays" multiple images if a tweet includes them; the urls of the additional images are appended to the tweet text - /entities command now lists out both entities and extended\_entities. - /url and /open open links from extended\_entities as well as entities. Duplicated links aren't opened. - Note: Due to perceived compliance with Twitter's Terms of Service the t.co links are opened for multiple images which unfortunately means that just one link gets opened no matter how many images are attached. Whether or not this is strictly required will be investigated and if we can open the links directly to the image files TTYtter will be updated to suit. ##Changes in version 2.2.4: - No changes, I just forget to change version in ttytter.pl. Constantly distracted. ##Changes in version 2.2.3: - Fix empty geo coordinates for quoted tweets - Badge quoted tweets themselves as well as the parent ##Changes in version 2.2.2: - Destroy tco in quoted tweets that are nested in new RTs. Missed this under 2.2.1 ##Changes in version 2.2.1: - Destroy tco in quoted tweets. Missed this under 2.2.0 ##Changes in version 2.2.0: This unofficial version is my first attempt at maintaining TTYtter and introduces quoted tweet support. - Create quoted tweets. Simply append text to the /retweet command. You are allowed 116 chars and TTYtter should check and warn if you go over. - Displays quoted tweets automatically. Parent tweets are identified with a quote mark (") whereas standard retweets keep the percentage symbol (%). The quoted tweet will be displayed immediately below the parent tweet as a fully functioning tweet (i.e. it gets a menu code). Straight retweets of quoted tweets also display the quoted tweets. However, like the Twitter website, no further recursion of quoted tweets are made, i.e. a quoted, quoted tweet isn't displayed. For that use the /thread command. - filterrts extended to also apply to quoted tweets, etc. - /thread command extended to support quoted tweets and recurse through for the same amount as it does for replies, etc. - version checking of TTYtter disabled since this is all unofficial. ##Changes in version 2.1.0: This version of TTYtter requires Twitter API 1.1. Twitter-alike services not compliant with API 1.1 will not work with this or any future version of TTYtter. If you need API 1.0 support, you must use 2.0.4 for as long as that support is available. - Full compliance with Twitter API 1.1, including TOS limitations and rate limits. - TTYtter now deshortens t.co links transparently for tweets and events, and uses t.co length computations when determining the length of a tweet. This feature can be disabled with -notco. If you are using Term::ReadLine:TTYtter 1.4 or higher, then this will also work in readline mode. - Commands that accept menu codes can now also accept tweet or DM IDs, perfect for all you command-line jockeys. - New /replyall command (thanks @FunnelFiasco). - New /del command. - User filtering (with new -filter\* options). - Better description of the full range of streaming events (thanks @RealIvanSanchez). - /push now works with non-Boolean options, simply pushing them to the stack (it still sets Booleans to true when pushed). - The background will kill itself off correctly if the foreground process IPC connection is severed (i.e., the console died), preventing situations where the background would panic or peg the CPU in an endless loop. - Geolocation now looks at and processes place ID, country code, name and place type, and tweets with a place ID will also be considered to have geolocation information (thanks @RealIvanSanchez). - Using -twarg generates a warning. As previously warned, it will be removed in 3.0. - -anonymous now requires -apibase, as a Twitter API 1.1 requirement. - All bug fixes from 2.0.4. ##Changes in version 2.0.4 (bug fixes and critical improvements only; these fixes are also in 2.1.0): 2.0.x will be the last branch of TTYtter to support Twitter API 1.0. When the 1.0 API is shut down, all previous versions of TTYtter will fail to work and you must upgrade to 2.1.x. - You can now correctly /push booleans that were originally false. - /eval now correctly emits its answer to $streamout so that -runcommand works. - /vcheck on T::RL::T now correctly reports the currently installed version rather than the server's version when the installed version is the same or newer. - Error messages from Twitter are properly processed again, so that commands that really fail won't unexpectedly appear to succeed. - Hangs or spurious errors in -daemon mode are now reduced. - The list\_created event is now properly recognized in streaming mode. - /entities on a retweet now properly refers back to the retweet. ##Changes in version 2.0.3: - Various and sundry Unicode whitespace characters are now canonicalized into regular whitespace, which improves URL recognition and editing. This occurs whether -seven is on or not. (thanks @Ryuutei for the report) - You can now turn the ability of a user to send NewRTs on and off with /rtson and /rtsoff, respectively, as a down payment on full filtering in 2.1. Note that this does not currently filter NewRTs out of the stream; this is a Twitter bug. - The user\_update event is now properly recognized in streaming mode. ##Changes in version 2.0.2: - /trends now accepts WOEID (either set with /set woeid or as an argument). If none is given, global trends are used instead (WOEID 1). The old $trendurl will be removed in 2.1, since this makes it superfluous. Speak now if this affects you. - If you have a location set with /set lat and /set long, the new /woeids command will give you the top 10 locations Twitter supports that match it. You can then feed this to /trends, or set it yourself. - Repairs another race condition where posting before signal handlers were ready could crash TTYtter (thanks @RealIvanSanchez for the report). - The /entities command is now smarter about media URLs. - The exponential backoff is now correctly implemented for reconnecting to the streaming API. If a connection fails, the timeout will automatically extend to a maximum of 60 seconds between attempts. In the meantime, TTYtter will transparently fall back on the REST API. - Extension load failure messages are now more helpful (thanks @vlb for the patch). - Prompts were supposed to be case-insensitive, and now they are (thanks @FunnelFiasco for the patch). - /whois (and /wagain) and /trends now correctly emit to $streamout so that -runcommand works. ##Changes in version 2.0.1: - Expands UTF-8 support to understand UTF-16 surrogate pairs from supra-BMP code points, fixing the Malformed UTF-8 errors generated by Perl for certain characters. - A race condition where TTYtter could accidentally kill the foreground in streaming mode is fixed (thanks @WofFS for the report). - -backload=0 now properly populates $last\_id, even if no tweets are received after the initial "fetch," eliminating an issue with spuriously grabbing old tweets (thanks @Duncan_Rowland for the report). ##Changes in version 2.0.0: - Introduces Streaming API support (opt-in) on systems satisfying prerequisites, using Twitter User Streams. - Reworked event and select() handling for better reliability on a wider array of operating systems. - List methods are now overhauled to remove deprecated endpoints. As a consequence, if your extension relied on the undocumented function &liurltourl, you must update it, as that function is no longer used for the current REST API revision. - The old public\_timeline endpoint is deprecated by Twitter and has been removed. Anonymous users will only see tracked terms, if any. - /tron, /troff and /track are now case-insensitive, matching the Search API (thanks @\_sequoia for the report). - $conclude is now properly called after /again. - Now that Twitter properly supports retweet counts greater than 100, so does TTYtter. - Underlining of user names properly ignores hyphens. - TTYtter will no longer run with Term::ReadLine::TTYtter versions prior to 1.3. - Various cosmetic fixes. - API changes: $eventhandle for receiving non-tweet/DM events from the Streaming API. - -twarg, a very old holdover of the old single-extension API in TTYtter 0.x, is now deprecated; it does not scale in the multi-module environment. It will be removed in 3.0. Migrate your extensions now. - -oldstatus, which was deprecated in 1.1.x, is now removed. If you are relying on the old behaviour, you must use 1.2.5. - xAuth (not XAuth), which was deprecated in 1.2.x, is now removed. If you are relying on the old little-xAuth authentication system, you must use 1.2.5. ##Changes in version 1.2.5: - Fixes for signals on Linux 3.x kernels, which includes newer releases of Debian and Ubuntu. If you are using readline mode, this requires Term::ReadLine::TTYtter 1.3, which is released simultaneously and has the following fixes: - Matching fixes for signals on Linux 3.x kernels. - CTRL-D as the first character on a line is now correctly seen as EOF, matching the non-readline version. - URL-sniffing logic now uses the earlier, more conservative algorithm to eliminate spurious characters (thanks @fukr for the report). ##Changes in version 1.2.4: - The -status=- patch in 1.2.3 broke passing statuses on the command line (that'll teach me to proof patches better). Fixed; thanks @dogsbodyorg for the spot. ##Changes in version 1.2.3: - Signals restructured to allow $SIG or POSIX.pm-based signalling. The latter is preferred for Perl 5.14+; the former is preferred for for 5.8.6+, 5.10 or 5.12, and is the only supported method for unsupported Perls (viz., 5.8.5 and earlier). This should eliminate the need to manually set PERL\_SIGNALS to unsafe for Perl 5.14+, assuming that you have POSIX.pm. You can force TTYtter to use POSIX.pm signals with -signals\_use\_posix, but it's better to let it choose which method it prefers. - Repairs to -retoke, which should once again work with dev.twitter.com. - Tweak for multi-line -status=- (thanks @paulgrav for the patch). - The old, undocumented debugging option -freezebug was obsolete as of 1.2, and now is completely removed. ##Changes in version 1.2.2: - New /entities command extracts t.co links from tweets and DMs so you can see where they point. - Fixed /trends to use new URL (thanks @Donearm for the report). - Fixed /trends not to double-double-quote strings when they are already double-quoted. Because that would double-quote them double, you dig? ##Changes in version 1.2.1: - Changes to Search API optimizer to accommodate other entities. (A more complete solution eliminating the optimizer entirely is planned for 2.0.) - RAS syndrome corrected in keyfile generator (with thanks to the supremely pedantic @FunnelFiasco ;). ##Changes in version 1.2.0: - Perl 5.8.6 is now the minimum tested version (but see this note on 5.005 and 5.6). - xAuth support is now deprecated and will be removed in 2.0. Speak now if this will affect you. - New list support, including building, editing and disposing of lists directly from the client, and mixing lists into your timeline dynamically. You can even turn off your regular timeline and just use a list as your timeline to see only a subset of users. Don't worry, your favourite grouping extensions still work too. - Many commands can now take an optional +count, allowing limited pagination. - NewRTs are now the default for /retweet, and the NewRT interface is now complete with retweet counts in tweets, NewRT marking for tweets and /rtsof. /thread also tracks NewRT linkages (thanks @augmentedfourth for the suggestion), and you can /delete them like any other tweet. Appending to a retweet or /oretweet uses the old RT format, or you can say -nonewrts. - New users now authorize with standard OAuth, eliminating our dependence on the old Twitter key clone system. Users who already have cloned keys don't need to do anything; they will still work. New users should use OAuth. 1.2's -retoke credentials generator also uses OAuth. - A "pastebrake" reduces spurious tweets caused by accidentally pasting into the TTYtter window. - The promised /dmsent command is now implemented. - TTYtter's fetch algorithm has been changed to a "sliding window" system to try harder to get tweets posted out of order, as well as cope with high frequency search keywords. - You can now specify a custom path to your notify tool for both Growl and notify-send using -notify\_tool\_path=.... - You can use %%\* if you misfired an argument. For example, /re e5 right on bro followed by /re f4 %%\* becomes /re f4 right on bro - The /vcheck command will now automatically populate %URL% with the appropriate URL, so now you can just /open it (thanks @dirtyHippy for the idea). - -statusurl lets you shorten and append a URL to a -status (thanks @microlifter for the patch). - .ttytterrc is treated as UTF-8 by default (thanks @kseistrup for the report; wontfixed for 1.1 for compatibility reasons). - -backload=0 shouldn't load anything, and now it doesn't (thanks @jfriedl for the report; wontfixed for 1.1 for compatibility reasons). - -lib and -olib are now completely removed. - API changes: $userhandle for displaying user objects, and new library functions &postjson &getbackgroundkey &sendbackgroundkey. - All bug fixes from 1.1.11 and 1.1.12. ##Changes in version 1.1.12 (bug fixes and critical improvements only; these fixes are also in 1.2.0): - Patches for Perl 5.14 (thanks @rkfb for the report). - Keyfiles can now be regenerated if they are corrupted or need to be updated with -retoke. - /doesfollow should give true or false with -runcommand (thanks @kaleidoscopique for the report). Similarly, /short should also work, emitting the URL (thanks @microlifter for that report). - Properly understands a new Twitter ad-hoc error format, which repairs some operations that would unexpectedly appear to succeed but didn't actually (thanks @augmentedfourth for the report). - -readline autocomplete command list now up-to-date. ##Changes in version 1.1.11 (bug fixes and critical improvements only; these fixes are also in 1.2.0): - Fixed a bug where TTYtter crashes ungracefully if OAuth credentials fail. - Fixed regex in command processor that interpreted all commands starting with /p as /print. - -notimeline is now properly recognized by /set as a boolean. - One last issue related to URL shortening. ##Changes in version 1.1.10: - Code adjustments to avoid double-decoding UTF-8 sequences internally (thanks @cristiangauma for the fix). - Fixed crash in readline autocompletion when metacharacters were present (thanks @stormdragon2976 for the report). - Optimized readline statistics are now case-insensitive so that weighting is more correct. - Corrected flaw with -verify where prompts went to the wrong filehandle. - Keyword terms in /trends are now quoted for search (thanks @WofFS for the report). - /short more securely encodes its input so that certain URLs will not be shortened incorrectly (thanks @alexfalkenberg for the report). - Custodial code cleanup pre-1.2. ##Changes in version 1.1.9: - Signals now should operate correctly on Solaris and other systems using SIGXCPU/XFSZ (thanks @jgeorgi for the report). - StatusNet and Identi.ca support is restored, using a shim that dynamically works up the missing stringified-int fields 1.1.8+ requires. - -linelength lets you set an arbitrary linelength for Twitter-alike APIs not limited to 140 characters (the default is, of course, 140). - -notifyquiet turns off the test notify sent by your chosen notification driver. - -daemon mode is no longer limited by the need to assign menu codes, allowing it to accept ridiculously large data slurps. ##Changes related to Term::ReadLine::TTYtter version 1.2: - T::RL::T now keeps up with changing terminal sizes, which should reduce overpaint (thanks @WofFS for the fully functioning patch). - Pressing DEL at position 0 no longer causes the app to exit. This was, unbelievably, an intentional feature of T::RL::Perl. ##Changes in version 1.1.8: - Emergency fix for signature errors (due to status IDs now overflowing the base ID fields). This may cause TTYtter to be incompatible with some Twitter-alike APIs; I can't do anything about that until they start supporting the \*\_str versions. - Smoother fetching from the Search API. ##Changes in version 1.1.7: - -daemon mode works again. - New-format Twitter error messages are automatically unwrapped. - Changes related to Term::ReadLine::TTYtter (version 1.1 is required for this support): - Perl 5.6 is now required explicitly to use T::RL::T. (You can still use 5.005 without -readline, but see the support note above). - Most UTF-8 characters should now be properly accepted, and more keyboard layouts work properly on more operating systems. - Prompts that are not transmitted to Twitter do not have the character counter, such as Y/N confirmation prompts and so on. - The character counter can be disabled completely with -nocounter (as an option to ttytter) for screen readers. - The prompt now defaults to ANSI off, unless you pass ttytter the -ansi option. This also allows you to turn ANSI on and off and the prompt will follow. (If you use T::RL::T 1.1 with TTYtter 1.1.6, you will notice that the prompt is no longer highlighted because 1.1.6 doesn't know how to synchronize ANSI state.) - /unset now sets non-Boolean options now to undef so that it will "do the right thing." - I swear, /troff no longer strips quotes off quoted terms. If it does, give me your exact track list and the keyword you used. I swear by all that is holy I fixed it this time! - API tweak: &wraptime, which was "optimized" out in 1.1.6, has been restored as a stub in 1.1.7 for compatibility. ##Changes in version 1.1.6: - 1.1.6 is a very large systems update, touching quite a bit of low-level code. In particular, this version requires full POSIX signals to function at all, whereas previous versions only needed them in certain circumstances: your system must support either or both of SIGUSR1/2 or SIGPWR/SYS (i.e., signals 30 and 31), which are used as software interrupt signals between the foreground and background processes, or TTYtter will crash or hang. This has been verified to work on all the supported systems above. - If your TTYtter abruptly quits when you type commands, your system does not support these signals correctly. Send me a report so that I can investigate a workaround. - Support for repaintable readline prompts, when combined with a supporting driver such as Term::ReadLine::TTYtter. T::RL::T is custom-designed for this purpose, including dynamic repainting, history synchronization, background signaling, improvements to UTF-8 support and even a character counter. You can add support to your favourite readline driver with some extra stub functions. If you use T::RL::T as your readline driver (which is now the default for -readline if it is installed), /vcheck and -vcheck check its version too. This driver is a beta. It is still in development. Expect bugs. - Location support with -location, -lat and -long. Your account must be geo-enabled, which cannot be done from TTYtter; you must do it from the Twitter web interface. You can then set a (default) location with -lat/-long, and use -location to toggle if/when to send it. - /block and /unblock for those users you hate, like @dickc. - The foreground now sends squelch signals to the background when a command is running, which should reduce command output stepping on background updates. - -searchhits specifies how many search results to grab from the Search API, both with /search (thanks @jdvalentine) and tracked results. - /set [boolean] can now be used to set a Boolean option to 1, like /set ansi. Similarly, /unset can now set an option to zero (or literal string "0"). These commands are mostly intended for booleans and may not work right with other options. - -status can now be passed a line of text over standard input if you use -status=- (that's dash "status" equals dash), which is useful for scripts that can't trust their input but really want to use -hold (speaking of, a bug with -hold holding for an incorrect duration should now be fixed too). If your script can't cope with this and absolutely needs the old behaviour, -oldstatus is available as a deprecated stopgap to use the old -status behaviour, but may disappear in future versions. - Faster UTF-8 processing. - Growl notifications on Mac OS X are now asynchronous, which significantly improves their processing speed. - Background event loop rewritten to drive select() in a more compatible fashion, which should eliminate random freezes (-freezebug is still in 1.1.6 for purposes of debugging, just in case). - TTYtter now tells you what readline driver it is using, if any. You can set the PERL\_RL environment variable to override this (such as Gnu, Perl, TTYtter or Stub). - All prompts now use -readline when enabled. - Command line options didn't always override what was in the .ttytterrc file. Fixed. - Retweeting a tweet with UTF-8 characters should no longer generate a signature error. - Foreground menu codes are now shown in bold to set them off from background updates. - -simplestart prints an abbreviated startup banner for slower systems or more dire screen readers. - JSON fetches are more compatible with arbitrary OAuth signature algorithms, which should help extension authors and /eval jockeys. - The -readline TAB completion routine now includes all the supported commands (thanks again @jdvalentine). - API changes: new library functions &sendnotifies and &senddmnotifies, which decouple notification from &defaulthandle and &defaultdmhandle respectively. This allows extensions to send their own notifications without relying on the default handlers (thanks @stormdragon2976 for the use case). In TTYtter 2.0, with the next major revision of the internal API, this idea will be explored much further. ##Changes in version 1.1.5: - Backed out select() debugging code due to way too many false positives. It can be re-enabled with -freezebug for testers. - Small custodial changes in progress. ##Changes in version 1.1.4: - You can now ask for additional tweets to backfill your timeline with -backload=[number]. Careful with this option: Twitter can ignore it, and often does, and loading large amounts of data can dramatically slow TTYtter down. This is a down payment on pagination, to come in the very near future. - You can now specify multiple arguments to -notifytype, such as =growl,libnotify. You will probably need an extension for your particular notification scheme. (suggested by @stormdragon2976) - Correctly recognizes the StatusNet "fail whale" (thanks @seppo0010 and @yrvn). - Adjusted user-agent timeouts for iffier links. - Rescue code for buggy user-agents that ignore timeouts. - More HTML entities are deciphered in both regular and -seven modes. - A platform-inless dependent change of the default keyfile umask for better security (thanks @herrold). - Gopher URLs are now forwarded to the Floodgap Gopher proxy, since Firefox 4 is dropping Gopher support, unless -urlopen uses lynx as its user agent, and /short on gopher URLs adds the proxy on to get an HTTP URL. (Hey, this is a text client. I have to support gopherspace.) ##Changes in version 1.1.3: - The JSON parser incorrectly rejects some null strings, which can interfere with logging into OAuth. Fixed. (thanks @alfredhallmert) - Metacharacters in URLs are now (should be) correctly rejected when fed to the TAB-shortener in -readline. (thanks @johndalton) - Replies now take priority always over search results with -mentions. - Exception messages are now timestamped also if -timestamp is on. (suggested by @colindean) - /cls command to clear the screen. (suggested by @schapendonk) - Spurious failure with perl -c in 5.005 worked around. - Corrections to messages and the introductory blurb. ##Changes in version 1.1.2: - -status with UTF-8 characters now works correctly again from the command line (as long as your locale is set correctly, of course). (thanks @jlm314) - $shutdown now correctly fires even if a child process was not launched. ##Changes in version 1.1.1: - Corrected (fingers crossed) OAuth signature bugs and UTF-8 problems. Tested on Ubuntu 10.04, Mac OS X 10.6/10.5/10.4 (PPC and x86), AIX and NetBSD 5 with 5.005 through 5.10.1, so if it doesn't work for you, I'll just find a quiet corner and shoot myself. Yes, it's actually shorter than 1.1.0 due to some efficiencies that were possible. (thanks @j4mie, @dariuus, @seppo0010 and many others for data points) - When looking for tools, TTYtter will now check your path first before its built-in locations. (thanks @seppo0010) - Better handling for impoverished environments where $HOME may not be defined. - New mention in Guinness Book of World Records for quickest replacement of a version of TTYtter. It's in the back somewhere, near record number of hours watching Monty Python while singing from the Hungarian Bongosok. ##Changes in version 1.1.0 (this version is an updated form of the public beta, released as is due to the switchover; expect minor bugs, which will be rectified in 1.1.1): - Official support for OAuth, which is now the default method of authentication. OAuth requires cURL -- Lynx will not work. Basic Auth is still supported for users of StatusNet and Identi.ca, and still works with Lynx, but you must ask for it with -authtype=basic. After 16 August 2010, only TTYtter 1.1.0 and later will be able to access Twitter due to the Basic Auth shutdown. No earlier version of TTYtter will work! Read the main page for how to get your credentials converted to OAuth. You only have to do this once per account. - Foreground menu codes now roll continuously and wrap around instead of resetting with every foreground command (except for /thread, which still uses zz0 to zz9). This is the completion of the menu code change first introduced in 1.0.0. - Support for automatically fetching replies with -mentions, even from users you do not follow. - /deletelast deletes the most recent tweet you made, if you don't like using proper safety nets like -verify or -slowpost. - /doesfollow command (part of 1.0.4, but originated with the aborted 1.1.0 public beta), telling you if a user follows another or if a user follows you. - For users requiring -seven, certain single character entities will now be translated from UTF-8 to the nearest ISO-8859-1 equivalent (part of 1.0.4, but originated with the 1.1.0 public beta). This table will expand in the future. - Various API changes: -lib and -olib are now removed; new library functions; $getpassword and $shutdown (suggested by @colindean). - All bug fixes from 1.0.3 and 1.0.4. ##Changes in version 1.0.4 (these fixes are also in 1.1.0): - Search API URLs corrected to Twitter-specified URLs. - NewRTs now appear in user timelines and mentions, thanks to new improvements in the Twitter API. - Ported /doesfollow and the improved UTF-8 entity translation for -seven from the forthcoming revised 1.1 beta. ##Changes in version 1.0.3 (bug fixes and critical improvements only; these fixes are also in 1.1.0): - Search API URLs now transitioned to the api.twitter.com endpoint, as the old ones will be eventually shut down. - When terminating TTYtter correctly exits with the right error status now (thanks @jlm314). - Reply username matching is now a bit less greedy. - Spaces are trimmed off URLs in /whois. ##Changes in version 1.0.2: - Missed one of the bleeding colour bugs into the -readline prompt that was supposed to be fixed in 1.0.1. Fixed for sure this time. (thanks @tjh) - Updated API URLs. - Search API support streams more reliably and is compatible with future changes to the Search API search method. ##Changes in version 1.0.1: - Fixed JSON parser to avoid bailout with certain large GeoAPI coordinates. (thanks @pssdbt) - TTYtter now counts in UTF-8 characters, not bytes, now that I have confirmation of full support in the Twitter API. 140 character tweets and DMs are now fully supported, and also work with -autosplit. - Multi-module loader properly insulates non-fatal errors from the extension. This should improve compatibility. (thanks @colindean) - Error messages won't foul prompt colour in -readline mode anymore (thanks @wireghoul). - -synch mode updates are only triggered now for successful posting, not on overlength tweets, etc. ##Changes in version 1.0.0: - Source code reorganized and in some cases completely rewritten. - Multi-module system for the TTYtter API allows you to install and run multiple extensions simultaneously (if compatible), adding the new -exts option. - Speaking of, massive changes to the TTYtter API. Extension authors should re-read the API documentation for compatibility notes. While many extensions will work with no or minimal changes, some may need to be updated. - The old -lib and -olib options are now deprecated, and will be removed in the 1.1 releases. - Synchronicity mode synchronizes updates with your keyboard activity (-synch), but has a price to pay. Mostly intended for input methods that are unhappy with background updates. - -runcommand option for simple command-line queries. - -hold is no longer infinite when used with -script. - Tweet code temporary menus now occupy a three character menu code that always starts with z (so now /thread generates zz0 through zz9). This is to accommodate future menus that may be more than 20 entries. - Initial support for the Retweet API and newRTs. NewRTs now appear in your timeline by default, are properly unwrapped so they are not truncated, and are canonicized to appear just like RTs used to. Retweets-of-me are displayed using the new /rtsofme command (/rtom). Note that because the API doesn't give you information about who retweeted you, neither does this command. Twitter acknowledges this deficiency and it will be supported in a later TTYtter when they fix it. If you want to disable NewRTs (such as for StatusNet, etc.), use -nonewrts. RTs made with /rt and friends are still the manual variety. - /follow and /leave now handle following and leaving users (no more FOLLOW and LEAVE even though they are still supported). - /dm who what replaces D who what (although the latter will still work), giving you your 140 characters all back, and is properly supported by -autosplit, -slowpost and -verify. /replying to a DM now internally uses /dm. - /dump now supports the Geolocation API and Retweet API, giving you location information for tweets that encode it, plus the retweet metadata. More information is also in the tweet cache for later. - A new versioning system recognizes when you are using a beta and checks the internal build number. - Special logic to detect the Fail Whale for more bulletproof posting and more useful error messages. - /again and /whois get confused by numeric Twitter user IDs (and treat them as user numbers). Patched to fix this so that numeric IDs are seen as true IDs. Although this also affects 0.9, it requires making an incompatible change, so it will not be fixed in that version. - If -rc gives an absolute path, use that. (thanks @FunnelFiasco) - All bug fixes from 0.9.10, 0.9.11 and 0.9.12. ##Changes in version 0.9.12 (bug fixes and critical improvements only; these fixes are also in 1.0.0): - If you /troff on a keyword set that has quoted phrases, the quotes get lost off all of them. Fixed. - Restoring from /set tquery 0 also fouls up quoted search terms. Fixed. - Setting $tquery in an extension's initialization does not override $track. Fixed. (thanks @colindean) ##Changes in version 0.9.11 (bug fixes and critical improvements only; these fixes are also in 1.0.0): - Warn the user if a notification framework was selected but no notifies were requested. This might be useful for an extension to dynamically control, so it is not a fatal error. - Another try at properly handling GeoAPI information (thanks @chfrank\_cgn). - Author breaks 50,000 tweets. A loud sobbing noise can be heard from Twitter corporate headquarters throughout most of the Bay Area. ##Changes in version 0.9.10 (bug fixes and critical improvements only; these fixes are also in 1.0.0): - If the foreground process exits abnormally, it should still clean up the background process. - -script and -verbose should work together better (a more effective fix is in the 1.0.0 beta). - The -slowpost prompt lagged the signal switch ever so slightly, meaning you could hit ^C and kill the process even when it told you it was okay. The prompt is now delayed until after the signal handler change. - -notifytype=0 should work fully now. - -script and -status now correctly ignore -slowpost and -verify. - /vreply format tweaked slightly. ##Changes in version 0.9.9 (bug fixes and critical improvements only): - Tweets with geolocation information no longer cause the JSON parser to panic. - If -autosplit=word fails, fall back on =char instead of completely destroying the tweet. - /vre no longer threads the reply, as API changes have caused threaded tweets to be only visible to the one replied to. - The planned conversion of 140 bytes to 140 characters as the tweet length could not be implemented in this version as the Twitter API does not correctly accept them yet. ##Changes in version 0.9.8 (bug fixes and critical improvements only): - Identica fixes: base URL returned to friends\_timeline; fixed the "null list" warnings Identica users were getting; updated JSON parser to understand the new Identica fields. - You can now say -notifytype=0 on the command line to disable a notifytype in your .ttytterrc. - -hold can potentially loop forever even if you don't want it to. -hold=1 or -hold by itself keeps the old behaviour, but specifying an argument greater than 1 causes the script to stop after that many unsuccessful tries. In 1.0.0, this will be changed again. - Auto-ratelimiting changed to use 50% instead of 60%. This slightly diminishes responsiveness, but seems to help people who were getting beaten up by other client usage. You can still use -pause with an argument, of course. - /[ef]rt no longer thread retweets to the source tweet. Per Twitter, this won't work right any more and actually prevents retweets from being seen (by causing them to be treated as replies). - /whois and /wagain now recognize the new default images Twitter is using for accounts without avatars. - -curl now works correctly again (stupid typo regression). - Error codes fixed for command line tools. ##Changes in version 0.9.7: - 0.9 is now the stable branch and bug fixes only will occur on this branch until a stable 1.0.x becomes available, after which it will be deprecated. New development will now occur on unstable 1.0 and there will be compatibility changes. More on that when 1.0.0 is released. - New notification framework with built-in support for Growl (via growlnotify) and experimental built-in support for libnotify (via modifications to notify-send; see Galago Project trac ticket #147) using -notifytype and -notifies. Expandable via the API. - Revised API method for dynamic classification of tweets using the $tweettype method. (The old $choosecolour method is now deprecated and trying to call its handler will generate a fatal error. It will be completely removed in 1.0.0.) - Favourites support with /favourites, /(un)fave and /frt. - Tweets can be dumped and their status URLs grabbed with /dump (suggested by @augmentedfourth). - /short and /url take %URL% as default, and /whois//wagain and /dump populate it, allowing you to grab URLs from status IDs or user profiles and open them or repost them (based on a suggestion from @vkoser). As a nice side effect, /url can now open arbitrary URLs as arguments. - "Verified Account" support for /whois and /wagain. - -slowpost mode for people needing something gentler than -verify (like me). - Training-wheels mode intercepts common newbie tweets like quit and help (disabled by -slowpost and -verify; I assume that if you set those then you know what you're doing). - -filter is now dynamic and can be recompiled on the fly with /set filter. - /vreply forces publicly visible replies (with the de facto r @ttytter A public reply. notation). - /eretweet populates %% as well to allow editing with the conventional substitution sequences (thanks @jasonwryan). - To facilitate this behaviour, %-sequences are now generally interpreted at the end of a line as well, not just at the beginning. - New reserved namespaces for API modules using the $store global reference in anticipation of multi-module support in 1.0.0. - HTTPS URLs now accepted by /short and the TAB completer in -readline. - -olib option for one-line libraries on the command line. - UTF-8 characters can now be scanned for by /url, although your underlying browser may not like them (for example, Mac OS X /usr/bin/open thinks they are filenames). - Default replies URL now set to mentions.json but remains the same command line option for backwards compatibility. - Substitutions using %-x sequences would accept arguments that were too high and simply cut off until it couldn't anymore. This is now correctly flagged as an error. - Another crash bug removed. - Internal code consolidation. - Better error messages for deletions, failed substitutions, etc. ##Changes in version 0.9.6: - Direct message selection, analogous to tweet selection, which also supports /delete, /url and /reply for a nice almost-orthogonal interface. - /retweet and /eretweet, previously undocumented in 0.9.5 due to inadequate testing, are now officially supported and properly thread in-reply-to fields. - Large internal change to subprocess management for easier future expansion, along with more changes to $authenticate. This internal reworking will continue up until the OAuth-based TTYtter, so people hacking on the core should beware. - $choosecolour is now unstable. API programmers who are using this method should contact me, as I am planning to change the interface as part of the future notification framework. - /track should not throw pagination errors on common or popular search terms. I disagree with the way Twitter has implemented this warning, but this version includes a workaround (thanks @johndalton). - /ruler once again lines up properly with the prompt (thanks @vkoser, @jazzychad and others of the Brotherhood of the Ruler). - Search results now are properly coloured in anonymous mode. - GNU screen printed bold characters as inverse text. ANSI sequence tweaked for wider compatibility (thanks @arsatiki). - Unicode code point 0x2028 needed to be seen as a newline, and subject to -newline (or not). Fixed. - -noratelimit does not work when it is changed dynamically, so it is simply made a startup-option only. - -filter didn't handle quote-wrapped arguments (thanks @augmentedfourth). Fixed. - -wrap sometimes overindented following lines (thanks again @augmentedfourth). Fixed. - Not all legal characters for URLs were accepted by /url. Fixed. - /search did not call $conclude, so -filter counts got out of sync. Fixed. - Author breaks 40,000 tweets. Twitter calls him on the phone to please stop and use Plurk or something. ##Changes in version 0.9.5: - Selection of individual tweets and threading with /thread, /reply, /delete and /url, along with @ markers on tweets that are part of a thread. - -noratelimit and -notrack to disable rate limit checks and tracking keywords, respectively, on systems that don't support them (most notably Laconi.ca/Identi.ca). - API addition with $choosecolour. - UTF-8 characters are now allowed in tracking keywords. - Faster and more reliable JSON fetch and parsing method. - Expanded /help text. - Bogus colour warnings when using -noansi are fixed. ##Changes in version 0.9.4: - Twitter Search API integration, based on initial work by @kellyterryjones, @vielmetti and @br3nda (/search, -queryurl), with hashtag integration and keyword management (/tron, /troff, /track, /#, -notimeline, -track) and trends (/trends, -trendurl), suggested by a whole bunch of people including the most esteemed @adamcurry. - Customizable colours (-colour{prompt,dm,me,reply,warn}), another common request. - Base API URL can now be specified for Twitter clone APIs (-apibase). - Official API support for libraries driving commands, or wishing to make JSON fetches from services. - Whitelisted accounts bombed with autoratelimiting. Fixed to constant value. - @ highlighting in direct messages tended to bleed. Fixed. - -status probably shouldn't print version check warnings. Fixed. - Not every overlong prompt was getting wordwrapped. Fixed. ##Changes in version 0.9.3: - Automatically check that you're using the most current version, either with -vcheck at startup, or /vcheck within the client. - New $authenticate API method makes it possible to store your credentials anywhere you darn well please, including nowhere. Now prompts for password when you don't specify. Based on code by @jcscoobyrs. - Autosplit using the -autosplit option, suggested by @dogsbodyorg and @timtom. - Correctly counts bytes in tweets, since Twitter counts in bytes, not characters (thanks @cyrixhero). - Wordwrap for arbitrary screen sizes, based on a suggestion by @augmentedfourth. - Verify individual tweets as you post them with -verify, along with simple Perl-expression-based filtering with -filter, based on suggestions by @cwage. - Posting tweets did not show verbose information in -superverbose mode. Fixed. - /setting superverbose should also set verbose. Fixed. ##Changes in version 0.9.2: - Status changed to 'stable' fork; previously embryonic features now either fully enabled or made default. - -rc=... option allows selection from multiple .ttytterrc files, based on a suggestion by @br3nda. Corresponding -norc option allowed to, conversely, completely disable any rc file present. - API additions ($addaction/&defaultaddaction). - Time ranges printed for /again user (when -timestamp is not enabled). - /print ntabcomp to display newly added entries during this session, based on a suggestion by @augmentedfourth. - TAB completion is now case-insensitive. - Expanded control character filter from 0.8.6. - All bug fixes and backouts from 0.8.6. ##Changes in version 0.8.6: - Status changed to 'deprecated' fork. - Control character filter added (backported from 0.9.x) and expanded to pre-interpret most common mistaken entries. - Bug fixed with @ names framed with certain punctuation not getting highlighted. - Backed out kludges for bowdlerized /whois and less efficient workaround JSON fetch. ##Changes in version 0.9.1: - Large rewrite of the UTF-8 handling code, with hopefully better support on as wide a range of Perls as possible. - /print tabcomp to display your optimized completer string in advance, based on a suggestion by @augmentedfourth. - -newline to parse \n and \r, also suggested by @augmentedfourth. - CTRL-C now correctly triggers the END subroutine, reported by @augmentedfourth. Yeah, he's been busy. ;-) ##Changes in version 0.9.0: - Split into 'unstable' fork. - Major retooling of program logic to eliminate redundant portions and streamline complex sections. - Auto-ratelimit support with -pause=auto (EMBRYONIC). However, works well enough to be the default right now. If you don't want to use this, or don't trust it, you probably should be using 0.8.5. - Support for Term::ReadLine::\* with -readline (EMBRYONIC), including cursor key history and TAB completion (with auto-learn), and API support with $autocompletion/&defaultautocompletion to define your own TAB completion routine. - URL shortening (-shorturl and /short). - Runtime changes to certain options now supported with /set and /print. - Support for unusual client environments, using -leader and -noprompt, based on an idea submitted by @chfrank\_cgn. - Easier SSL operations using -ssl instead of requiring changes to .ttytterrc. - /again on a username reports the time of last update if you aren't using -timestamp. - Friendship queries fixed. - All bug fixes from 0.8.5. - Author breaks 25,000 tweets. He is, truly, a nerd. ##Changes in version 0.8.5: - Split into 'stable' fork. - Bug fixed with UTF-8 handling, even on systems and Perls that don't understand UTF-8. - Bug fixed with users with no DMs. ##Changes in version 0.8.4: - Several temporary workarounds for glitches in the Twitter API, namely a kludge for eating invalid JSON generated by tweet deletes, disabling some fields in /whois that were pulled, and turning off friendship checks as they currently generate 500 errors. The tweaked JSON fetch is also marked as kludge. These temporary fixes will be backed out when they are fixed on Twitter's end. ##Changes in version 0.8.3: - Tweaked fetch routine pending eventual format of null responses (i.e., much less spurious timeout or no data messages). ##Changes in version 0.8.2: - Twitterer names, and @ names, are now boldface and underline respectively based on patches submitted by @smb. - Expanded /whois with code for looking up friendships, and processing avatar images (-avatar, -frurl). - API additions ($precommand, $prepost, $postpost). - Certain HTTP status codes could cause the JSON parser to freak out. Fixed. - -noansi didn't take precedence over -ansi like it was supposed to. Fixed. ##Changes in version 0.8.1: - $lasttwit, and origination classes for $handle, both API enhancements suggested by @emilsit. - -lynx and -curl can be told to run a specific binary, useful for PATH-deficient environments or version testing. - -status correctly warns for tweets over 140 characters. - Speaking of which, normal tweet activity also has better warning text for oversize tweets too. - Additional debugging information for failed test logins available. ##Changes in version 0.8.0: - Robust scripting support for simple command-line queries (/end and -script). - -pause=0 is now valid. - Popping words off the end of the line (%%--, etc.) works. - API additions (&standardtweet, &standarddm, DUPSTDOUT). - Null array references could escape from certain asynchronous commands and cause uncaught exceptions. Fixed. - &prinput allegedly took arguments, but ignored them and just used $\_ like it used to. Kludged around. ##Changes in version 0.7.1: - Null array references could leak from the JSON parser, which would throw an uncaught Perl error. Fixed. - /ruler (suggested by @jspath55). ##Changes in version 0.7.0: - Changes suggested and coded/adapted from code by @br3nda: - ANSI colour and highlighting (and -ansi/-noansi). - Timestamp support, including templates on supported installations (-timestamp). - Replies support (/replies and -rurl). - /again expanded to allow querying user timelines (and -uurl). - API expanded with $prompt, &defaultprompt and -twarg. - Anonymous mode (-anonymous). - User query (/whois and /wagain, and -wurl). - JSON parser upgrades to accomodate user queries. - Error message reporting fixed. - Proper detection of presence/absence of modules (particularly fixing problems with -seven) and streamlined BEGIN block. - No need to pause with -silent. - Several side effects have now been incorporated as virtues. - Author breaks 10,000 tweets. What a dweeb he must be. ##Changes in version 0.6.1: - Improved stability in JSON validator when using Lynx as the user-agent. ##Changes in version 0.6.0: - Direct message support added to both interactive client and API, with -dmurl and -dmpause. - -silent mode and exit statuses. - Abstraction of console input processing to facilitate future expansion in both API and internal code. - Recognizes new-format Twitter error messages. (Correspondingly, some API exception codes are now deprecated; see documentation.) - Command abbreviations. - Expanded command history support and -maxhist. - Reworked error messages. - Various custodial fixes and upgrades to JSON interpreter. ##Changes in version 0.5.1: - Patched for various entities in the new Twitter JSON release. This version will correctly handle both ampersand-escaped and standard entities and quotes. ##Changes in version 0.5: - Support for rate-limited API, in two ways: first, increasing default timeout to 120 seconds, and two, properly recognizing when rate-limiting has kicked in. - Stability improvement in JSON validator. - Additional API exception codes for the above features. - select() loop tightened up to make timeline hits as minimal as possible. ##Changes in version 0.4: - UTF-8 now works right (most of the time). Added -seven option for backwards compatibility. - First support for the TTYtter API and the -lib option. - Detached mode using -daemon, allowing bot building. - Tweaks to defaults. - Work-around for out-of-order tweets "stuttering" or getting stuck. This is technically a Twitter bug, but this version can now ignore the anomaly. ##Changes in version 0.3: - Even bigger morer robuster JSON validator. - Posting from the command line using -status. - Can now configure update source using -update, allowing complete abstraction of TTYtter assuming the other side supports the Twitter API over JSON. - -hold timeout tweaked. - Messages tweaked for accuracy and semi-user-friendliness. ##Changes in version 0.2: - Improved detection of Twitter HTML status messages and better tolerance of partially-transmitted data (which could sometimes cause ttytter's JSON validator to freak out). - Added "re-tweet" facility for ... retweeting. - Added -hold option. - Another hal-fassed attempt at better UTF-8 handling. - Exit statuses of curl/Lynx sessions are properly reported. - Proper command line precedence over default options. oysttyer-2.10.0/CONTRIBUTING.markdown000066400000000000000000000031371335541774700171730ustar00rootroot00000000000000# Oysttyer ## Contribute If you are a member of Oysttyer you already have commit access. It is expected you will have been running your changes locally before pushing to here, but apart from that, go for it! ### You already have code or an idea for code you want to contribute - Fork the project - Make your additions/fixes/improvements - Run you code locally and make sure your changes work and you've not broken anything - Send a pull request ### You don't already have code, nor any ideas for code, but still want to contribute code somehow: - Have a look through issues labelled "easier" or "harder" depending on how ambitious you are feeling. I am trying to ensure all relevant issues have one of those labels. - Then run through the steps as per above - Feel free to link to your fork in the issue before submitting a pull request if you want a review - Or just open the pull request. A pull request doesn't have to start with the finished code ### You have ideas/bugs: - Just open an issue with ideas for features or bugs you have found. For bugs please provide the version (commit or tag) you are using. ## Useful tools for developers See the oysttyer-dev repo. For now there is just one extension that can provide a full json dump of a tweet. It is very useful for inspecting the structure of a tweet per the API. Any further ideas or extensions, etc to help with developing are welcome there. ## Testing There are no tests! :( I'm not necessarily the world's biggest fan of unit tests, but some tests would certainly be nice. So one great contribution would be ideas or a start on adding some kind of tests. oysttyer-2.10.0/LICENSE000066400000000000000000000350341335541774700145260ustar00rootroot00000000000000 Floodgap Free Software License The author of your software has chosen to distribute it under the Floodgap Free Software License. Although this software is without cost, it is not released under Copyleft or GPL, and there are differences which you should read. Your use of this software package constitutes your binding acceptance without restriction. This software is without cost The Floodgap Free Software License (FFSL) has one overriding mandate: that software using it, or derivative works based on software that uses it, must be free. By free we mean simply "free as in beer" -- you may put your work into open or closed source packages as you see fit, whether or not you choose to release your changes or updates publicly, but you must not ask any fee for it. (There are certain exceptions for for-profit use which we will discuss below.) Definitions and terms Author The declared copyright owner of this software package. Binary A pre-compiled or pre-interpreted bytecode or machine language representation of a software package not designed for further modification and tied to a particular platform or architecture. Derivative work Any distribution (q.v.) that contains any modification to or deviation from the official reference distribution (q.v.); or any software package significantly based on or integrally including the source code for its features, including but not limited to supersets; subsets of a significant proportion; in-place patched changes to source or binary files; linking in as a library; binary-only distributions if the original package included source (even if the source was not modified prior to compilation); or translations to another programming language, architecture or operating system environment. Derivative works of packages released under this license are also considered subject to this license. However, a software package that requires this package but does not include it or is not based upon it, even if it will not operate without it, is not considered a derivative work. For example, interpreted programs requiring an interpreter issued under this license, assuming they are not distributed with any portion of the interpreter, are not derivative works. Distribution A packaged release of this software, either the author's original work (the "reference distribution") or a derivative work based upon it. Reference distribution A packaged release of this software explicitly designated as the official release, written by or on behalf of the Author with his or her explicit designation as official. Only exact copies of the reference distribution may be called reference distributions; all other forms are derivative works. Source code The human-readable programming instructions of the package which might be easily read as text and subsequently edited, but requiring compilation or interpretation into binary before being directly useable. What you are permitted to do under this license Pursuant to the remainder of the terms below, * You may freely use, copy, and disseminate this software package for any non-commercial purpose as well as the commercial purposes permitted below. * You may freely modify this package, including source code if available. Your modifications need not be released, although you are encouraged to do so. * You may release your derivative works based upon this software in purely binary (non-source) form if you choose. You are not obligated to release any portion of your source code openly, although you are encouraged to do so. * If this package is a tool used for generation, compilation or maintenance of works, including but not limited to readable documents, software packages or images (for example, compilers, interpreters, translators, linkers, editors, assemblers or typesetters), you may freely use it for that purpose, commercial or otherwise, as the works made by this package are not considered subject to this license unless specified otherwise within and may be distributed under any desired license and/or offered for sale or rental. Any run-time library or run-time code section linked into the output by a compiler or similar code-generating tool governed by this license is considered to be an integral part of the output, and its presence does not subject the generated work to this license either. (This is, of course, assuming you are not using said tools to generate a derivative work based on this package in violation of the other license terms.) However, if you are linking or including a separately distributed library that is under this license, no matter what tool you are using to do the linking or inclusion, you are then considered to be making a derivative work based on that library and your work does fall under this license. To avoid this, do not include the library with your work (even though it needs the library to function) and instead offer the library separately without cost. * In addition to non-commercial use and the uses permitted above, you may use this software package in any for-profit endeavour as long as it does not involve the specific sale or rental of this package. Some specific but by no means exhaustive examples are listed below. Note that some of these situations may require additional action be taken to ensure compliance. + If this package or a derivative work allows you to serve data or make data available to others (for example, web servers, mail servers, gopher servers, etc.), you may use it to serve any commercial content or in any commercial setting whether you choose to charge a fee or not, as you are considered to be earning income from the content you serve and/or the services facilitated by your business and not from the sale of this package itself. (This is, of course, assuming that you are not charging a fee for sale or rental of this package or a derivative work based on this package in violation of the other license terms.) Similarly, any data you may acquire from the use of this package is yours, and not governed by this license in any way even if for-profit. + If you are selling a product that includes this package or a derivative work either as part of your product's requirements for function or as a bundled extra, such as an operating system distribution, you may charge a fee for your product as long as you also make this package or said derivative work available for free separately (such as by download or link back to this package's site), as you are considered to be requesting a fee for your own product and the package is merely included as a convenience to your users. + If you offer installation of this package or a derivative work as a service, you may charge a fee for the act of installation as long as you also make this package or said derivative work available for free (such as by download or link back to this package's site), as you are considered to be requesting a fee for the act of installation and not for the software you are installing. + The Author may also grant, in writing, other specified exemptions for your particular commercial purpose that do not contravene the spirit of this license or any license terms this package additionally carries. * In your derivative works based on this package, you may choose to offer warranty support or guarantees of performance. This does not in any way make the original Author legally, financially or in any other respect liable for claims issued under your warranty or guarantee, and you are solely responsible for the fulfillment of your terms even if the Author of the work you have based your work upon offers his or her own. * In your derivative works based on this package, you may further restrict the acceptable uses of your package or situations in which it may be employed as long as you clearly state that your terms apply only to your derivative work and not to the original reference distribution. However, you may not countermand or ignore, directly or otherwise, any restriction already made in the reference distribution's license, including in this document itself, in similar fashion to other licenses allowing compatible licenses to co-govern a particular package's use. What you must not do under this license Remember that these limits apply only to redistribution of a reference distribution, or to a true derivative work. If your project does not include this package or code based upon it, even if it requires this package to function, it is not considered subject to this license or these restrictions. * You must not charge a fee for purchase or rental of this package or any derivative work based on this package. It is still possible to use this package in a commercial environment, however -- see What you are permitted to do under this license. * You must not countermand or ignore, directly or otherwise, the restrictions already extant in this package's license in your derivative work based on it. As a corollary, you must not place your derivative work under a secondary license or description of terms that conflicts with it (for example, this license is not compatible with the GNU Public License). * You must not label any modified distribution of this package as a reference or otherwise official distribution without the permission of the original Author or Authors. You must clearly specify that your modified work is a derivative work, including binary-only releases if the original included source code and you do not even if you did not modify the source prior to compilation. What you must do under this license * You must agree to all terms specified (agreement to which is unconditionally signified by your usage, modification or repurposing of this package), or to remove the package from your computer and not use it further. * In the absence of any specific offer for redress or assistance under warranty or guarantee of performance that the Author of this package might make, you must agree to accept any and all liability that may come from the use of this package, proper or improper, real or imagined, and certify without condition that you use this product at your own risk with no guarantee of function, merchantability or fitness for a particular purpose. If such offer of redress or assistance is extended, it is fulfillable only by the Author who extended the offer, which might not necessarily be this Author, nor might it be the Authors of any packages it might be based upon. * If you choose to publicly redistribute this package or create a derivative work based on this package, you must make it available without any purchase or rental fee of any kind. * If you choose to create a derivative work based on this package, your derivative work must be copyrighted, and must be governed under (at a minimum) the original package's license, which will necessarily include all terms noted here. As such, if you choose to distribute your derivative work, you must include a human-readable license in your distribution containing all restrictions of use, necessarily including this license, and any additional restrictions the Author has mandated that do not contravene this license which you and users of your derivative work must also honour. * If you choose to create and distribute a derivative work based on this package, your derivative work must clearly make reference to this package, any other packages your work or the original work might be based on, and all applicable copyrights, either in your documentation, your work's standard human-readable output, or both. A suggested method might be Contains or is based on the Foo software package. Copyright (C) 2112 D. Original Author. All rights reserved. http://their.web.site.invalid/ Additional notes Enforcement is the responsibility of the Author. However, violation of this license may subject you to criminal and civil penalties depending on your country. This package is bound by the version of license that accompanies it. Future official versions of a particular package may use a more updated license, and you should always review the license before use. This license's most current version is always available from the following locations: [1]http://www.floodgap.com/software/ffsl/ [2]gopher://gopher.floodgap.com/1/ffsl/ This license is version 1, dated 19 November 2006. This license is copyright © 2006 Cameron Kaiser. All rights reserved. The text of this license is available for re-use and re-distribution under the Creative Commons. The use of the term "Floodgap Free Software License" does not imply endorsement of packages using this license by Floodgap Systems or by Cameron Kaiser. Modified licenses using portions of these terms may refer to themselves as modified FFSL, with the proviso that their modifications be clearly marked, as specified below: [3]Creative Commons License This work is licensed under a [4]Creative Commons Attribution-ShareAlike 2.5 License. Only the text of this license, and not programs covered by this license, is so offered under Creative Commons. References 1. http://www.floodgap.com/software/ffsl/ 2. gopher://gopher.floodgap.com/1/ffsl/ 3. http://creativecommons.org/licenses/by-sa/2.5/ 4. http://creativecommons.org/licenses/by-sa/2.5/ oysttyer-2.10.0/README.markdown000066400000000000000000000063051335541774700162210ustar00rootroot00000000000000# oysttyer The official fork and replacement for what was once [Floodgap's TTYtter](http://www.floodgap.com/software/ttytter/). In order to get Cameron Kaiser's blessing, we've had to change the name, take out a new API key and keep the Floodgap Free Software License. **The master branch will be pretty much what I'm running, but that doesn't mean I've not managed to break it in someway**; Tagged releases (i.e. X.X.X) are intended to be stable. The mirror branch reflects all the historical official TTYtter updates. See the [oysttyer User Guide](http://oysttyer.github.io/docs/userGuide.html) for usage information. ## Switching from TTYtter 1. You have to re-authorise (you can't use your `.ttytterkey`) as we have a new API key 2. Move/rename your `.ttytterc` file to `.oysttyerrc` 3. If you use the `ttytteristas` pref it is now called `oysttyeristas` 4. Read the Changelog to see what's new since TTYtter 2.1 I think that's it? ### Launching Oysttyer Depending on how you obtain oysttyer the file could already be executable so you can launch it directly (`./oysttyer.pl`) as long as the shebang matches your path to Perl or you alter the shebang so it does. However, it's probably a lot easier just to do: perl oysttyer.pl ### Using your own oauthkey and oauthsecret Since the transition from TTYtter, Twitter seem to be in the habit of muzzling us (their word for blocking write access). This is done at the oysttyer oauthkey/secret level so affects all users. As a (hopefully) temporary work-around until we can resolve this issue permanently with Twitter you can register our own app (You can call it whatever, but if you are stuck for a name call it "oysttyer-") and specify the `oauthkey` and `oauthsecret` in the `.oysttyerrc` file: oauthkey=xxXxxXxxXXXXXxXxxxXXXxxXX oauthsecret=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx Be sure to avoid trailing whitespace in your key/secret. You will, of course, have to re-authorise and get a new token. I suggest taking advantage of the existing keyfile functionality in oysttyer to do this. **Important**: If you are using you own oauthkey and oauthsecret to get a new token then that token will only work with your own oauthkey and oauthsecret. Tokens are not interchangeable between oauthkeys and oauthsecrets. ### New functionality since TTYtter 2.1 Until we catch up with the documentation, check out the changelog and commitlog, etc. ### Notes to extension developers 1. The `TTYtter_VERSION`, `TTYtter_PATCH_VERSION` and `TTYtter_RC_NUMBER` variables are now `oysttyer_VERSION`, `oysttyer_PATCH_VERSION` and `oysttyer_RC_NUMBER`. 2. User-agent string has changed to `oysttyer/$oysttyer_VERSION`. ## Recommendations I strongly suggest, although it is by no means compulsory, tracking @oysttyer and #oysttyer as that way you become connected to a global support network. Also, check out some available extensions: * [oysttyer-profile](https://github.com/oysttyer/oysttyer-profile) update your profile information from within oysttyer * [oysttyer-deshortify](https://github.com/oysttyer/oysttyer-deshortify) gets rid of shortlinks and displays final URLs * [oysttyer-multigeo](https://github.com/oysttyer/oysttyer-multigeo) for all your geographical location needs oysttyer-2.10.0/oysttyer.pl000077500000000000000000007761451335541774700160020ustar00rootroot00000000000000#!/usr/bin/perl -s # TODO: Eventually we should use Getopt::Long and go back to #!/usr/bin/env perl ######################################################################### # # oysttyer v2.10 (c)2016- oysttyer organisation # (c)2007-2012 cameron kaiser (and contributors). # all rights reserved. # # https://oysttyer.github.io/ # # distributed under the floodgap free software license # http://www.floodgap.com/software/ffsl/ # # After all, we're flesh and blood. -- Oingo Boingo # If someone writes an app and no one uses it, does his code run? -- me # ######################################################################### require 5.005; BEGIN { # ONLY STUFF THAT MUST RUN BEFORE INITIALIZATION GOES HERE! # THIS FUNCTION HAS GOTTEN TOO DAMN CLUTTERED! # @INC = (); # wreck intentionally for testing # dynamically changing PERL_SIGNALS doesn't work in Perl 5.14+ (bug # 92246). we deal with this by forcing -signals_use_posix if the # environment variable wasn't already set. if ($] >= 5.014000 && $ENV{'PERL_SIGNALS'} ne 'unsafe') { $signals_use_posix = 1; } else { $ENV{'PERL_SIGNALS'} = 'unsafe'; } $command_line = $0; $0 = "oysttyer"; $oysttyer_VERSION = "2.10"; $oysttyer_PATCH_VERSION = 0; $oysttyer_RC_NUMBER = 0; # non-zero for release candidate # this is kludgy, yes. $LANG = $ENV{'LANG'} || $ENV{'GDM_LANG'} || $ENV{'LC_CTYPE'} || $ENV{'ALL'}; $my_version_string = "${oysttyer_VERSION}.${oysttyer_PATCH_VERSION}"; (warn ("$my_version_string\n"), exit) if ($version); $packet_length = 2048; $space_pad = " " x $packet_length; $background_is_ready = 0; # for multi-module extension handling $multi_module_mode = 0; $multi_module_context = 0; $muffle_server_messages = 0; undef $master_store; undef %push_stack; $padded_patch_version = substr($oysttyer_PATCH_VERSION . " ", 0, 2); %opts_boolean = map { $_ => 1 } qw( ansi noansi verbose superverbose oysttyeristas noprompt seven silent hold daemon script anonymous readline ssl newline vcheck verify noratelimit notrack nonewrts notimeline synch exception_is_maskable mentions simplestart location readlinerepaint nocounter notifyquiet signals_use_posix dostream nostreamreplies streamallreplies nofilter showusername largeimages origimages doublespace extended ); %opts_sync = map { $_ => 1 } qw( ansi pause dmpause oysttyeristas verbose superverbose url rlurl dmurl newline wrap notimeline lists dmidurl queryurl track colourprompt colourme notrack colourdm colourreply colourwarn coloursearch colourlist idurl notifies filter colourdefault backload searchhits dmsenturl nostreamreplies mentions wtrendurl atrendurl filterusers filterats filterrts filteratonly filterflags nofilter ); %opts_urls = map {$_ => 1} qw( url dmurl uurl rurl wurl frurl rlurl update shorturl apibase queryurl idurl delurl dmdelurl favsurl favurl favdelurl followurl leaveurl muteurl unmuteurl dmupdate credurl blockurl blockdelurl friendsurl modifyliurl adduliurl delliurl getliurl getlisurl getfliurl creliurl delliurl deluliurl crefliurl delfliurl getuliurl getufliurl dmsenturl rturl rtsbyurl dmidurl statusliurl followliurl leaveliurl followersurl oauthurl oauthauthurl oauthaccurl oauthbase wtrendurl atrendurl frupdurl lookupidurl rtsofmeurl ); %opts_secret = map { $_ => 1} qw( superverbose oysttyeristas ); %opts_comma_delimit = map { $_ => 1 } qw( lists notifytype notifies filterflags filterrts filterats filterusers filteratonly ); %opts_space_delimit = map { $_ => 1 } qw( track ); %opts_can_set = map { $_ => 1 } qw( url pause dmurl dmpause superverbose ansi verbose update uurl rurl wurl avatar oysttyeristas frurl track rlurl noprompt shorturl newline wrap verify autosplit notimeline queryurl colourprompt colourme colourdm colourreply colourwarn coloursearch colourlist idurl urlopen delurl notrack dmdelurl favsurl favurl favdelurl slowpost notifies filter colourdefault followurl leaveurl dmupdate mentions backload lat long location searchhits blockurl blockdelurl woeid nocounter linelength quotelinelength friendsurl followersurl lists modifyliurl adduliurl delliurl getliurl getlisurl getfliurl creliurl delliurl deluliurl crefliurl delfliurl atrendurl getuliurl getufliurl dmsenturl rturl rtsbyurl wtrendurl statusliurl followliurl leaveliurl dmidurl nostreamreplies frupdurl filterusers filterats filterrts filterflags filteratonly nofilter rtsofmeurl largeimages origimages extended video_bitrate separator ); %opts_others = map { $_ => 1 } qw( lynx curl seven silent maxhist noansi hold status daemon timestamp twarg user anonymous script readline leader ssl rc norc vcheck apibase notifytype exts nonewrts synch runcommand authtype oauthkey oauthsecret tokenkey tokensecret credurl keyf lockf readlinerepaint simplestart exception_is_maskable oldperl notco notify_tool_path oauthurl oauthauthurl oauthaccurl oauthbase signals_use_posix dostream eventbuf replacement_newline replacement_carriagereturn streamallreplies showusername doublespace ); %valid = (%opts_can_set, %opts_others); $rc = (defined($rc) && length($rc)) ? $rc : ""; unless ($norc) { my $rcf = ($rc =~ m#^/#) ? $rc : "$ENV{'HOME'}/.oysttyerrc${rc}"; if (open(W, $rcf)) { 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); } elsif (length($rc)) { die("couldn't access rc file $rcf: $!\n". "to use defaults, use -norc or don't specify the -rc option.\n\n"); } } warn "** -twarg is deprecated\n" if (length($twarg)); $seven ||= 0; $oldperl ||= 0; $parent = $$; $script = 1 if (length($runcommand)); $supreturnto = $verbose + 0; $postbreak_time = 0; $postbreak_count = 0; # Want to keep original behaviour as well though $newline ||= 0; $replacement_newline ||= $seven ? ' [NL] ' : " \x{2424} "; $replacement_carriagereturn ||= $seven ? ' [CR] ' : " \x{240D} "; # 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 oysttyer is 5.8.6. Perl 5.005 thru 5.8.5 probably can still run oysttyer, 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 .oysttyerrc. bug patches will still be accepted for older Perls; see the oysttyer home page for info. for Perl 5.005, remember to also specify -seven. EOF } # defaults that our extensions can override $last_id = 0; $last_dm = 0; # a correct fix for -daemon would make this unlimited, but this # is good enough for now. $print_max ||= ($daemon) ? 999999 : 250; # shiver $suspend_output = -1; # try to find an OAuth keyfile if we haven't specified key+secret # no worries if this fails; we could be Basic Auth, after all $whine = (length($keyf)) ? 1 : 0; $keyf ||= "$ENV{'HOME'}/.oysttyerkey"; $keyf = "$ENV{'HOME'}/.oysttyerkey${keyf}" if ($keyf !~ m#/#); $attempted_keyf = $keyf; if (!$oauthwizard && ( #!length($oauthkey) || #!length($oauthsecret) || !length($tokenkey) || !length($tokensecret) ) ) { my $keybuf = ''; if(open(W, $keyf)) { while() { chomp; s/\s+//g; $keybuf .= $_; } close(W); my (@pairs) = split(/\&/, $keybuf); foreach(@pairs) { my (@pair) = split(/\=/, $_, 2); $oauthkey = $pair[1] if ($pair[0] eq 'ck') && !length($oauthkey);# && $pair[1] ne 'X'); $oauthsecret = $pair[1] if ($pair[0] eq 'cs') && !length($oauthsecret);# && $pair[1] ne 'X'); $tokenkey = $pair[1] if ($pair[0] eq 'at'); $tokensecret = $pair[1] if ($pair[0] eq 'ats'); } die("** tried to load OAuth tokens from $keyf\n". " but it seems corrupt or incomplete. please see the documentation,\n". " or delete the file so that we can try making your keyfile again.\n") if ((!length($oauthkey) || !length($oauthsecret) || !length($tokenkey) || !length($tokensecret))); } else { die("** couldn't open keyfile $keyf: $!\n". "if you want to run the OAuth wizard to create this file, add ". "-oauthwizard\n") if ($whine); $keyf = ''; # i.e., we loaded nothing from a key file } } # try to init Term::ReadLine if it was requested # (shakes fist at @br3nda, it's all her fault) %readline_completion = (); if ($readline && !$silent && !$script) { $ENV{"PERL_RL"} = "TTYtter" if (!length($ENV{'PERL_RL'})); eval 'use Term::ReadLine; $termrl = new Term::ReadLine ("TTYtter", \*STDIN, \*STDOUT)' || die( "$@\nthis perl doesn't have ReadLine. don't use -readline.\n"); $stdout = $termrl->OUT || \*STDOUT; $stdin = $termrl->IN || \*STDIN; $readline = '' if ($readline eq '1'); $readline =~ s/^"//; # for optimizer $readline =~ s/"$//; #$termrl->Attribs()->{'autohistory'} = undef; # not yet (%readline_completion) = map {$_ => 1} split(/\s+/, $readline); %original_readline = %readline_completion; # readline repaint can't be tested here. we cache our # result later. } else { $stdout = \*STDOUT; $stdin = \*STDIN; } $wrapseq = 0; $lastlinelength = -1; print $stdout "$leader\n" if (length($leader)); # state information $lasttwit = ''; $lastpostid = 0; # stub namespace for multimodules and (eventually) state saving undef %store; $store = \%store; $pack_magic = ($] < 5.006) ? '' : "U0"; $utf8_encode = sub { ; }; $utf8_decode = sub { ; }; unless ($seven) { eval 'use utf8;binmode($stdin,":utf8");binmode($stdout,":utf8");return 1' || die("$@\nthis perl doesn't fully support UTF-8. use -seven.\n"); # this is for the prinput utf8 validator. # adapted from http://mail.nl.linux.org/linux-utf8/2003-03/msg00087.html # eventually this will be removed when 5.6.x support is removed, # and Perl will do the UTF-8 validation for us. $badutf8='[\x00-\x7f][\x80-\xbf]+|^[\x80-\xbf]+|'. '[\xc0-\xdf][\x00-\x7f\xc0-\xff]|'. '[\xc0-\xdf][\x80-\xbf]{2}|'. '[\xe0-\xef][\x80-\xbf]{0,1}[\x00-\x7f\xc0-\xff]|'. '[\xe0-\xef][\x80-\xbf]{3}|'. '[\xf0-\xf7][\x80-\xbf]{0,2}[\x00-\x7f\xc0-\xff]|'. '[\xf0-\xf7][\x80-\xbf]{4}|'. '[\xf8-\xfb][\x80-\xbf]{0,3}[\x00-\x7f\xc0-\xff]|'. '[\xf8-\xfb][\x80-\xbf]{5}|'. '[\xfc-\xfd][\x80-\xbf]{0,4}[\x00-\x7f\xc0-\xff]|'. '\xed[\xa0-\xbf][\x80-\xbf]|'. '\xef\xbf[\xbe-\xbf]|'. '[\xf0-\xf7][\x8f,\x9f,\xaf,\xbf]\xbf[\xbe-\xbf]|'. '\xfe|\xff|'. '[\xc0-\xc1][\x80-\xbf]|'. '\xe0[\x80-\x9f][\x80-\xbf]|'. '\xf0[\x80-\x8f][\x80-\xbf]{2}|'. '\xf8[\x80-\x87][\x80-\xbf]{3}|'. '\xfc[\x80-\x83][\x80-\xbf]{4}'; # gah! eval <<'EOF'; $utf8_encode = sub { utf8::encode(shift); }; $utf8_decode = sub { utf8::decode(shift); }; EOF } $wraptime = sub { my $x = shift; return ($x, $x); }; if ($timestamp) { my $fail = "-- can't use custom timestamps.\nspecify -timestamp by itself to use Twitter's without module.\n"; if (length($timestamp) > 1) { # pattern specified eval 'use Date::Parse;return 1' || die("$@\nno Date::Parse $fail"); eval 'use Date::Format;return 1' || die("$@\nno Date::Format $fail"); $timestamp = "%Y-%m-%d %k:%M:%S" if ($timestamp eq "default" || $timestamp eq "def"); $wraptime = sub { my $time = str2time(shift); my $stime = time2str($timestamp, $time); return ($time, $stime); }; } } } END { &killkid unless ($in_backticks || $in_buffer); # this is disgusting } #### COMMON STARTUP #### # if we requested POSIX signals, or we NEED posix signals (5.14+), we # must check if we have POSIX signals actually if ($signals_use_posix) { eval 'use POSIX'; # God help the system that doesn't have SIGTERM $j = eval 'return POSIX::SIGTERM' ; die(<<"EOF") if (!(0+$j)); *** death permeates me *** your configuration requires using POSIX signalling (either Perl 5.14+ or you specifically asked with -signals_use_posix). however, either you don't have POSIX.pm, or it doesn't work. oysttyer 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 oysttyer. run one of export PERL_SIGNALS=unsafe # sh, bash, ksh, etc. setenv PERL_SIGNALS unsafe # csh, tcsh, etc. and restart oysttyer, 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 oysttyer 2.x, or bad things will happen such as signal mismatches, unexpected quits, and dogs and cats living peacefully in the same house. EOF print $stdout "** t.co support needs Term::ReadLine:TTYtter 1.4+ (-notco to ignore)\n" if (length($trlv) && !$notco && 0+$trlv < 1.4); } # try to get signal numbers for SIG* from POSIX. use internals if failed. eval 'use POSIX; $SIGUSR1 = POSIX::SIGUSR1; $SIGUSR2 = POSIX::SIGUSR2; $SIGHUP = POSIX::SIGHUP; $SIGTERM = POSIX::SIGTERM'; # from $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("-largeimages and -origimages cannot be used together.\n") if ($largeimages && $origimages); die("you can't use automatic ratelimits with -noratelimit.\nuse -pause=#sec\n") if ($noratelimit && $pause eq 'auto'); die("you can't use -synch with -script or -daemon.\n") if ($synch && ($script || $daemon)); die("-script and -daemon cannot be used together.\n") if ($script && $daemon); # set up menu codes and caches $is_background = 0; $alphabet = "abcdefghijkLmnopqrstuvwxyz"; %store_hash = (); $mini_split = 250; # i.e., 10 tweets for the mini-menu (/th) # leaving 50 tweets for the foreground temporary menus $tweet_counter = 0; %dm_store_hash = (); $dm_counter = 0; %id_cache = (); %filter_next = (); # set up threading management $in_reply_to = 0; $expected_tweet_ref = undef; # interpret -script at this level if ($script) { $noansi = $noprompt = 1; $silent = ($verbose) ? 0 : 1; $pause = $vcheck = $slowpost = $verify = 0; } ### now instantiate the oysttyer dynamic API ### ### based off the defaults later in script. #### # first we need to load any extensions specified by -exts. if (length($exts) && $exts ne '0') { $multi_module_mode = -1; # mark as loader stage print "** attempting to load extensions\n" unless ($silent); # unescape \, $j=0; $xstring = "ESCAPED_STRING"; while($exts =~ /$xstring$j/) { $j++; } $xstring .= $j; $exts =~ s/\\,/$xstring/g; foreach $file (split(/,/, $exts)) { #TODO # wildcards? $file =~ s/$xstring/,/g; print "** loading $file\n" unless ($silent); die("** sorry, you cannot load the same extension twice.\n") if ($master_store->{$file}->{'loaded'}); # prepare its working space in $store and load the module $master_store->{$file} = { 'loaded' => 1 }; $store = \%{ $master_store->{$file} }; $EM_DONT_CARE = 0; $EM_SCRIPT_ON = 1; $EM_SCRIPT_OFF = -1; $extension_mode = $EM_DONT_CARE; die("** $file not found: $!\n") if (! -r "$file"); require $file; # and die if bad die("** $file failed to load: $@\n") if ($@); die("** consistency failure: reference failure on $file\n") if (!$store->{'loaded'}); # check type of extension (interactive or non-interactive). if # we are in the wrong mode, bail out. if ($extension_mode) { die( "** this extension requires -script. this may conflict with other extensions\n". " you are loading, which may have their own requirements.\n") if ($extension_mode == $EM_SCRIPT_ON && !$script); die( "** this extension cannot work with -script. this may conflict with other\n". " extensions you are loading, which may have their own requirements.\n") if ($extension_mode == $EM_SCRIPT_OFF && $script); } # pick off all the subroutine references it makes for storage # in an array to iterate and chain over later. # these methods are multi-module safe foreach $arry (qw( handle exception tweettype conclude dmhandle dmconclude heartbeat precommand prepost postpost addaction eventhandle listhandle userhandle shutdown)) { if (defined($$arry)) { $aarry = "m_$arry"; push(@$aarry, [ $file, $$arry ]); undef $$arry; } } # these methods are NOT multi-module safe # if a extension already hooked one of # these and another extension tries to hook it, fatal error. foreach $arry (qw( getpassword prompt main autocompletion)) { if (defined($$arry)) { $sarry = "l_$arry"; if (defined($$sarry)) { die( "** double hook of unsafe method \"$arry\" -- you cannot use this extension\n". " with the other extensions you are loading. see the documentation.\n"); } $$sarry = $$arry; undef $$arry; } } } # success! enable multi-module support in the oysttyer API and then # dispatch calls through the multi-module system instead. $multi_module_mode = 1; # mark as completed loader $handle = \&multihandle; $exception = \&multiexception; $tweettype = \&multitweettype; $conclude = \&multiconclude; $dmhandle = \&multidmhandle; $dmconclude = \&multidmconclude; $heartbeat = \&multiheartbeat; $precommand = \&multiprecommand; $prepost = \&multiprepost; $postpost = \&multipostpost; $addaction = \&multiaddaction; $shutdown = \&multishutdown; $userhandle = \&multiuserhandle; $listhandle = \&multilisthandle; $eventhandle = \&multieventhandle; } else { # the old API single-end-point system $multi_module_mode = 0; # not executing multi module endpoints $handle = \&defaulthandle; $exception = \&defaultexception; $tweettype = \&defaulttweettype; $conclude = \&defaultconclude; $dmhandle = \&defaultdmhandle; $dmconclude = \&defaultdmconclude; $heartbeat = \&defaultheartbeat; $precommand = \&defaultprecommand; $prepost = \&defaultprepost; $postpost = \&defaultpostpost; $addaction = \&defaultaddaction; $shutdown = \&defaultshutdown; $userhandle = \&defaultuserhandle; $listhandle = \&defaultlisthandle; $eventhandle = \&defaulteventhandle; } # unsafe methods use the single-end-point $prompt = $l_prompt || \&defaultprompt; $main = $l_main || \&defaultmain; $getpassword = $l_getpassword || \&defaultgetpassword; # $autocompletion is special: if ($termrl) { $termrl->Attribs()->{'completion_function'} = $l_autocompletion || \&defaultautocompletion; } # fetch_id is based off last_id, if an extension set it $fetch_id = $last_id || 0; # validate the notify method the user chose, if any. # we can't do this in BEGIN, because it may not be instantiated yet, # and we have to do it after loading modules because it might be in one. @notifytypes = (); if (length($notifytype) && $notifytype ne '0' && $notifytype ne '1' && !$status) { # NOT $script! scripts have a use case for notifiers! %dupenet = (); foreach $nt (split(/\s*,\s*/, $notifytype)) { $fnt="notifier_${nt}"; (warn("** duplicate notification $nt was ignored\n"), next) if ($dupenet{$fnt}); eval 'return &$fnt(undef)' || die("** invalid notification framework $nt: $@\n"); $dupenet{$fnt}=1; } @notifytypes = keys %dupenet; $notifytype = join(',', @notifytypes); # warning if someone didn't tell us what notifies they wanted. warn "-- warning: you specified -notifytype, but no -notifies\n" if (!$silent && !length($notifies)); } # set up track tags if (length($tquery) && $tquery ne '0') { my $xtquery = &tracktags_tqueryurlify($tquery); die("** custom tquery is over $linelength length: $xtquery\n") if (length($xtquery) >= $linelength); @trackstrings = ($xtquery); } else { &tracktags_makearray; } # compile filterflags &filterflags_compile; # compile filters exit(1) if (!&filter_compile); $filterusers_sub = &filteruserlist_compile(undef, $filterusers); $filterrts_sub = &filteruserlist_compile(undef, $filterrts); $filteratonly_sub = &filteruserlist_compile(undef, $filteratonly); exit(1) if (!&filterats_compile); # compile lists exit(1) if (!&list_compile); # finally, compile notifies. we do this regardless of notifytype, so that # an extension can look at it if it wants to. ¬ify_compile; # check that we are using a sensible authtype, based on our guessed user agent $authtype ||= "oauth"; die("** supported authtypes are basic or oauth only.\n") if ($authtype ne 'basic' && $authtype ne 'oauth'); if ($termrl) { $streamout = $stdout; # this is just simpler instead of dupping warn(<<"EOF") if ($] < 5.006); *********************************************************** ** -readline may not function correctly on Perls < 5.6.0 ** *********************************************************** EOF print $stdout "-- readline using ".$termrl->ReadLine."\n"; } else { # dup $stdout for benefit of various other scripts open(DUPSTDOUT, ">&STDOUT") || warn("** warning: could not dup $stdout: $!\n"); binmode(DUPSTDOUT, ":utf8") unless ($seven); $streamout = \*DUPSTDOUT; } if ($silent) { close($stdout); open($stdout, ">>/dev/null"); # KLUUUUUUUDGE } # after this point, die() may cause problems # initialize our route back out so background can talk to foreground pipe(W, P) || die("pipe() error [or your Perl doesn't support it]: $!\n"); select(P); $|++; # default command line options $anonymous ||= 0; $ssl ||= 1; die("** -anonymous is no longer supported with Twitter (you must use -apibase also)\n") if ($anonymous && !length($apibase)); undef $user if ($anonymous); print $stdout "-- using SSL for default URLs.\n" if ($ssl); $http_proto = ($ssl) ? 'https' : 'http'; $lat ||= undef; $long ||= undef; $location ||= 0; $linelength ||= 280; $quotelinelength ||= 256; $tco_length ||= 23; # The number of characters that t.co links require $dm_text_character_limit ||= 10000; $oauthbase ||= $apibase || "${http_proto}://api.twitter.com"; # this needs to be AFTER oauthbase so that apibase can set oauthbase. $apibase ||= "${http_proto}://api.twitter.com/1.1"; $nonewrts ||= 0; # special case: if we explicitly refuse backload, don't load initially. $backload = 30 if (!defined($backload)); # zero is valid! $dont_refresh_first_time = 1 if (!$backload); $searchhits ||= 20; $url ||= "${apibase}/statuses/home_timeline.json"; $oauthurl ||= "${oauthbase}/oauth/request_token"; $oauthauthurl ||= "${oauthbase}/oauth/authorize"; $oauthaccurl ||= "${oauthbase}/oauth/access_token"; $credurl ||= "${apibase}/account/verify_credentials.json"; $update ||= "${apibase}/statuses/update.json"; $rurl ||= "${apibase}/statuses/mentions_timeline.json"; $uurl ||= "${apibase}/statuses/user_timeline.json"; $idurl ||= "${apibase}/statuses/show.json"; $delurl ||= "${apibase}/statuses/destroy/%I.json"; $rturl ||= "${apibase}/statuses/retweet"; $rtsbyurl ||= "${apibase}/statuses/retweets/%I.json"; $rtsofmeurl ||= "${apibase}/statuses/retweets_of_me.json"; $wurl ||= "${apibase}/users/show.json"; $frurl ||= "${apibase}/friendships/show.json"; $followurl ||= "${apibase}/friendships/create.json"; $leaveurl ||= "${apibase}/friendships/destroy.json"; $blockurl ||= "${apibase}/blocks/create.json"; $blockdelurl ||= "${apibase}/blocks/destroy.json"; $friendsurl ||= "${apibase}/friends/ids.json"; $followersurl ||= "${apibase}/followers/ids.json"; $frupdurl ||= "${apibase}/friendships/update.json"; $lookupidurl ||= "${apibase}/users/lookup.json"; $muteurl ||= "${apibase}/mutes/users/create.json"; $unmuteurl ||= "${apibase}/mutes/users/destroy.json"; $rlurl ||= "${apibase}/application/rate_limit_status.json"; $dmurl ||= "${apibase}/direct_messages.json"; $dmsenturl ||= "${apibase}/direct_messages/sent.json"; $dmupdate ||= "${apibase}/direct_messages/new.json"; $dmdelurl ||= "${apibase}/direct_messages/destroy.json"; $dmidurl ||= "${apibase}/direct_messages/show.json"; $favsurl ||= "${apibase}/favorites/list.json"; $favurl ||= "${apibase}/favorites/create.json"; $favdelurl ||= "${apibase}/favorites/destroy.json"; $getlisurl ||= "${apibase}/lists/list.json"; $creliurl ||= "${apibase}/lists/create.json"; $delliurl ||= "${apibase}/lists/destroy.json"; $modifyliurl ||= "${apibase}/lists/update.json"; $deluliurl ||= "${apibase}/lists/members/destroy_all.json"; $adduliurl ||= "${apibase}/lists/members/create_all.json"; $getuliurl ||= "${apibase}/lists/memberships.json"; $getufliurl ||= "${apibase}/lists/subscriptions.json"; $delfliurl ||= "${apibase}/lists/subscribers/destroy.json"; $crefliurl ||= "${apibase}/lists/subscribers/create.json"; $getfliurl ||= "${apibase}/lists/subscribers.json"; $getliurl ||= "${apibase}/lists/members.json"; $statusliurl ||= "${apibase}/lists/statuses.json"; $streamurl ||= "https://userstream.twitter.com/1.1/user.json"; $dostream ||= 0; $eventbuf ||= 0; $queryurl ||= "${apibase}/search/tweets.json"; # no more $trendurl in 2.1. $wtrendurl ||= "${apibase}/trends/place.json"; $atrendurl ||= "${apibase}/trends/closest.json"; # pick ONE! #$shorturl ||= "http://api.tr.im/v1/trim_simple?url="; $shorturl ||= "https://is.gd/create.php?format=simple&url="; # figure out the domain to stop shortener loops &generate_shortdomain; $pause = (($anonymous) ? 120 : "auto") if (!defined $pause); # NOT ||= ... zero is a VALID value! $superverbose ||= 0; $avatar ||= ""; $urlopen ||= 'echo %U'; $hold ||= 0; $holdhold ||= 0; $daemon ||= 0; $maxhist ||= 19; undef $shadow_history; $timestamp ||= 0; $noprompt ||= 0; $slowpost ||= 0; $twarg ||= undef; $verbose ||= $superverbose; $dmpause = 4 if (!defined $dmpause); # NOT ||= ... zero is a VALID value! $dmpause = 0 if ($anonymous); $dmpause = 0 if ($pause eq '0'); $ansi = ($noansi) ? 0 : (($ansi || $ENV{'TERM'} eq 'ansi' || $ENV{'TERM'} eq 'xterm-color') ? 1 : 0); $showusername ||= 0; $largeimages ||= 0; $origimages ||= 0; $doublespace ||= 0; $extended ||= 1; $video_bitrate ||= 'highest'; if ($extended) { $tweet_mode = "extended"; $display_mode = "full_text"; } else { $tweet_mode = "compatibility"; $display_mode = "text"; } $separator ||= 0; # synch overrides these options. if ($synch) { $pause = 0; $dmpause = ($dmpause) ? 1 : 0; } $dmcount = $dmpause; $lastshort = undef; # ANSI sequences $colourprompt ||= "CYAN"; $colourme ||= "YELLOW"; $colourdm ||= "GREEN"; $colourreply ||= "RED"; $colourwarn ||= "MAGENTA"; $coloursearch ||= "CYAN"; $colourlist ||= "OFF"; $colourdefault ||= "OFF"; $ESC = pack("C", 27); $BEL = pack("C", 7); &generate_ansi; # to force unambiguous bareword interpretation $true = 'true'; sub true { return 'true'; } $false = 'false'; sub false { return 'false'; } $null = undef; sub null { return undef; } select($stdout); $|++; # figure out what our user agent should be if ($lynx) { if (length($lynx) > 1 && -x "/$lynx") { $wend = $lynx; print $stdout "Lynx forced to $wend\n"; } else { $wend = &wherecheck("trying to find Lynx", "lynx", "specify -curl to use curl instead, or just let oysttyer autodetect stuff.\n"); } } else { if (length($curl) > 1 && -x "/$curl") { $wend = $curl; print $stdout "cURL forced to $wend\n"; } else { $wend = (($curl) ? &wherecheck("trying to find cURL", "curl", "specify -lynx to use Lynx instead, or just let oysttyer autodetect stuff.\n") : &wherecheck("trying to find cURL", "curl")); if (!$curl && !length($wend)) { $wend = &wherecheck("failed. trying to find Lynx", "lynx", "you must have either Lynx or cURL installed to use oysttyer.\n") if (!length($wend)); $lynx = 1; } else { $curl = 1; } } } $baseagent = $wend; # whoops, no Lynx here if we are not using Basic Auth die( "sorry, OAuth is not currently supported with Lynx.\n". "you must use SSL cURL, or specify -authtype=basic.\n") if ($lynx && $authtype ne 'basic' && !$anonymous); # streaming API has multiple prereqs. not fatal; we just fall back on the # REST API if not there. unless($status) { if (!$dostream || $authtype eq 'basic' || !$ssl || $script || $anonymous || $synch) { $reason = (!$dostream) ? "(no -dostream)" : ($script) ? "(-script)" : (!$ssl) ? "(no SSL)" : ($anonymous) ? "(-anonymous)" : ($synch) ? "(-synch)" : ($authtype eq 'basic') ? "(no OAuth)" : "(it's funkatron's fault)"; print $stdout "-- Streaming API disabled $reason (oysttyer will use REST API only)\n"; $dostream = 0; } else { print $stdout "-- Streaming API enabled\n"; # streams change mentions behaviour; we get them automatically. # warn the user if the current settings are suboptimal. if ($mentions) { if ($nostreamreplies) { print $stdout "** warning: -mentions and -nostreamreplies are very inefficient together\n"; } else { print $stdout "** warning: -mentions not generally needed in Streaming mode\n"; } } } } else { $dostream = 0; } # -status suppresses streaming if (!$dostream && $streamallreplies) { print $stdout "** warning: -streamallreplies only works in Streaming mode\n"; } # create and cache the logic for our selected user agent if ($lynx) { $simple_agent = "$baseagent -nostatus -source"; @wend = ('-nostatus'); @wind = (@wend, '-source'); # GET agent @wend = (@wend, '-post_data'); # POST agent # we don't need to have the request signed by Lynx right now; # it doesn't know how to pass custom headers. so this is simpler. $stringify_args = sub { my $basecom = shift; my $resource = shift; my $data = shift; my $dont_do_auth = shift; my $k = join("\n", @_); # if resource is an arrayref, then it's a GET with URL # and args (mostly generated by &grabjson) $resource = join('?', @{ $resource }) if (ref($resource) eq 'ARRAY'); die("wow, we have a bug: Lynx only works with Basic Auth\n") if ($authtype ne 'basic' && !$dont_do_auth); $k = "-auth=".$mytoken.':'.$mytokensecret."\n".$k unless ($dont_do_auth); $k .= "\n"; $basecom = "$basecom \"$resource\" -"; return ($basecom, $k, $data); }; } else { $simple_agent = "$baseagent -s -m 20"; @wend = ('-s', '-m', '20', '-A', "oysttyer/$oysttyer_VERSION", '--http1.1', '-H', 'Expect:'); @wind = @wend; $stringify_args = sub { my $basecom = shift; my $resource = shift; my $data = shift; my $dont_do_auth = shift; my $p; my $l = ''; foreach $p (@_) { if ($p =~ /^-/) { $l .= "\n" if (length($l)); $l .= "$p "; next; } $l .= $p; } $l .= "\n"; # sign our request (Basic Auth or oAuth) unless ($dont_do_auth) { if ($authtype eq 'basic') { $l .= "-u ".$mytoken.":".$mytokensecret."\n"; } else { my $nonce; my $timestamp; my $sig; my $verifier = ''; my $header; my $ttoken = (length($mytoken) ? (' oauth_token=\\"'.$mytoken.'\\",') : ''); ($timestamp, $nonce, $sig, $verifier) = &signrequest($resource, $data); $header = <<"EOF"; -H "Authorization: OAuth oauth_nonce=\\"$nonce\\", oauth_signature_method=\\"HMAC-SHA1\\", oauth_timestamp=\\"$timestamp\\", oauth_consumer_key=\\"$oauthkey\\", oauth_signature=\\"$sig\\",${ttoken}${verifier} oauth_version=\\"1.0\\"" EOF print $stdout $header if ($superverbose); $l .= $header; } } # if resource is an arrayref, then it's a GET with URL # and args (mostly generated by &grabjson) $resource = join('?', @{ $resource }) if (ref($resource) eq 'ARRAY'); $l .= "url = \"$resource\"\n"; $l .= "data = \"$data\"\n" if length($data); return ("$basecom -K -", $l, undef); }; } # update check if ($vcheck && !length($status)) { $vs = &updatecheck(0); } else { $vs = "-- no version check performed (use /vcheck, or -vcheck to check on startup)\n" unless ($script || $status); } print $stdout $vs; # and then again when client starts up ## make sure we have all the authentication pieces we need for the ## chosen method (authtoken handles this for Basic Auth; ## this is where we validate OAuth) # if we use OAuth, then don't use any Basic Auth credentials we gave # unless we specifically say -authtype=basic if ($authtype eq 'oauth' && length($user)) { print "** warning: -user is ignored when -authtype=oauth (default)\n"; $user = undef; } $whoami = (split(/\:/, $user, 2))[0] unless ($anonymous || !length($user)); # yes, this is plaintext. obfuscation would be ludicrously easy to crack, # and there is no way to hide them effectively or fully in a Perl script. # so be a good neighbour and leave this the fark alone, okay? stealing # credentials is mean and inconvenient to users. this is blessed by # arrangement with Twitter. don't be a d*ck. thanks for your cooperation. $oauthkey = (!length($oauthkey) || $oauthkey eq 'X') ? "wmS2Z01t6uHq3sVV1JL4DmZLp" : $oauthkey; $oauthsecret = (!length($oauthsecret) || $oauthsecret eq 'X') ? "838jD95T6hPUm6MoBwq6SHAvL9oNoPV6acPXi8Ee8Vj3Mcj0GR" : $oauthsecret; unless ($anonymous) { # if we are using Basic Auth, ignore any user token we may have in # our keyfile if ($authtype eq 'basic') { $tokenkey = undef; $tokensecret = undef; } # but if we are using OAuth, we can request one, unless we are in script elsif ($authtype eq 'oauth' && (!length($keyf) || $oauthwizard)) { if (length($oauthkey) && length($oauthsecret) && !length($tokenkey) && !length($tokensecret)) { # we have a key, we don't have the user token # but we can't get that with -script if ($script) { print $streamout <<"EOF"; AUTHENTICATION FAILURE YOU NEED TO GET AN OAuth KEY, or use -authtype=basic (run oysttyer 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 oysttyer: Authorize oysttyer by signing into Twitter with OAuth || +------------------------------------------------------------------------------+ Looks like you're starting oysttyer for the first time, and/or creating a keyfile. Welcome to the most user-hostile, highly obfuscated, spaghetti code infested and obscenely obscure Twitter client that's out there. You'll love it. oysttyer generates a keyfile that contains credentials for you, including your access tokens. This needs to be done JUST ONCE. You can take this keyfile with you to other systems. If you revoke oysttyer'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 oysttyer; 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 "\nRequest from $oauthurl ..."; ($tokenkey, $tokensecret) = &tryhardfortoken($oauthurl, "oauth_callback=oob"); $mytoken = $tokenkey; $mytokensecret = $tokensecret; # needs to be in both places # kludge in case user does not specify SSL and this is # Twitter: we know Twitter supports SSL ($oauthauthurl =~ /twitter/) && ($oauthauthurl =~ s/^http:/https:/); print $stdout <<"EOF"; 1. Visit, in your browser, ALL ON ONE LINE, ${oauthauthurl}?oauth_token=$mytoken 2. If you are not already signed in, fill in your username and password. 3. Verify that oysttyer is the requesting application, and that its permissions are as you expect (read your timeline, see who you follow and follow new people, update your profile, post tweets on your behalf and access your direct messages). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW! 4. Click Authorize app. 5. A PIN will appear. Enter it below. EOF $j = ''; while(!(0+$j)) { print $stdout "Enter PIN> "; chomp($j = ); } print $stdout "\nRequest from $oauthaccurl ..."; ($tokenkey, $tokensecret) = &tryhardfortoken($oauthaccurl, "oauth_verifier=$j"); $oauthkey = "X"; $oauthsecret = "X"; open(W, ">$keyf") || die("Failed to write keyfile $keyf: $!\n"); print W <<"EOF"; ck=${oauthkey}&cs=${oauthsecret}&at=${tokenkey}&ats=${tokensecret} EOF close(W); chmod(0600, $keyf) || print $stdout "Warning: could not change permissions on $keyf : $!\n"; print $stdout <<"EOF"; Written keyfile $keyf Now, restart oysttyer to use this keyfile. (To choose between multiple keyfiles other than the default .oysttyerkey, tell oysttyer where the key is using -keyf=... .) EOF exit; } # if we get three of the four, this must have been command line if (length($oauthkey) && length($oauthsecret) && (!length($tokenkey) || !length($tokensecret))) { my $error = undef; my $k; foreach $k (qw(oauthkey oauthsecret tokenkey tokensecret)) { $error .= "** you need to specify -$k\n" if (!length($$k)); } if (length($error)) { print $streamout <<"EOF"; you are missing portions of the OAuth sequence. either create a keyfile and point to it with -keyf=... or add these missing pieces: $error then restart oysttyer, or use -authtype=basic. EOF exit; } } } elsif ($retoke && length($keyf)) { # start the "re-toke" wizard to convert DM-less cloned app keys. # dup STDIN for systems that can only "close" it once open(STDIN2, "<&STDIN") || die("couldn't dup STDIN: $!\n"); print $stdout <<"EOF"; +-------------------------------------------------------------------------+ || The Re-Toke Wizard: Generate a new oysttyer keyfile for your app/token || +-------------------------------------------------------------------------+ Twitter is requiring tokens to now have specific permissions to READ direct messages. This will be enforced by 1 July 2011. If you find you are unable to READ direct messages, you will need this wizard. DO NOT use this wizard if you are NOT using a cloned app key (1.2 and on) -- use -oauthwizard. This wizard will create a new keyfile for you from your app/user keys/tokens. You do NOT need this wizard if you are using oysttyer for a purpose that does not require direct message access. For example, if oysttyer is acting as your command line posting agent, or you are only using it to read your timeline, you do NOT need a new token. You also do not need a new token to SEND a direct message, only to READ ones this account has received. You SHOULD NOT need this wizard if your app key was cloned after 1 June 2011. However, you can still use it if you experience this specific issue with DMs, or need to rebuild your keyfile for any other reason. ** This wizard will overwrite the key at $keyf ** To change this, restart oysttyer with -retoke -keyf=/path/to/keyfile Press RETURN/ENTER to continue, or CTRL-C NOW! to abort. EOF $j = ; print $stdout <<"EOF"; First: let's get your API key, consumer key and consumer secret. Start your browser. 1. Log into https://twitter.com/ with your desired account. 2. Go to this URL. You must be logged into Twitter FIRST! https://dev.twitter.com/apps 3. Click the oysttyer cloned app key you need to regenerate or upgrade. 4. Click Edit Application Settings. 5. Make sure Read, Write & Private Message is selected, and click the "Save application" button. 6. Select All (CTRL/Command-A) on the next screen, copy (CTRL/Command-C) it, and paste (CTRL/Command-V) it into this window. (You can also cut and paste a smaller section if I can't understand your browser's layout.) 7. Press ENTER/RETURN and CTRL-D when you have pasted the window contents. EOF $q = $/; PASTE1LOOP: for(;;) { print $stdout <<"EOF"; -- Press ENTER and CTRL-D AFTER you have pasted the window contents! --------- Go ahead: EOF undef $/; $j = ; print $stdout <<"EOF"; -- EOF ----------------------------------------------------------------------- Processing ... EOF $j =~ s/[\r\n]/ /sg; # process this. as a checksum, API key should == consumer key. $ck = ''; $cs = ''; ($j =~ /Consumer key\s+([-a-zA-Z0-9_]{10,})\s+/) && ($ck = $1); ($j =~ /Consumer secret\s+([-a-zA-Z0-9_]{10,})\s+/) && ($cs = $1); if (!length($ck) || !length($cs)) { # escape hatch print $stdout <<"EOF"; Something's wrong: I could not find your consumer key or consumer secret in that text. If this was a misfired paste, please restart the wizard. Otherwise, bug us \@oysttyer or \#oysttyer or https://github.com/oysttyer/oysttyer Please don't send keys or secrets. EOF exit; } last PASTE1LOOP; } # this part is similar to the retoke. $oauthkey = $ck; $oauthsecret = $cs; print $stdout "\nI'm testing this key to see if it works.\n"; print $stdout "Request from $oauthurl ..."; ($tokenkey, $tokensecret) = &tryhardfortoken($oauthurl, "oauth_callback=oob"); $mytoken = $tokenkey; $mytokensecret = $tokensecret; # kludge in case user does not specify SSL and this is # Twitter: we know Twitter supports SSL ($oauthauthurl =~ /twitter/) && ($oauthauthurl =~ s/^http:/https:/); $/ = $q; print $stdout <<"EOF"; Okay, your consumer key is ==> $ck and your consumer secret ==> $cs IF THIS IS WRONG, PRESS CTRL-C NOW AND RESTART THE WIZARD! Now we will verify your Imperial battle station is fully operational by signing in with OAuth. 1. Visit, in your browser, ALL ON ONE LINE (you should still be logged in), ${oauthauthurl}?oauth_token=$mytoken 2. Verify that your app is the requesting application, and that its permissions are as you expect (read your timeline, see who you follow and follow new people, update your profile, post tweets on your behalf and access your direct messages). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW! 3. Click Authorize app. 4. A PIN will appear. Enter it below. EOF print $stdout "Enter PIN> "; chomp($j = ); print $stdout "\nRequest from $oauthaccurl ..."; ($at, $ats) = &tryhardfortoken($oauthaccurl, "oauth_verifier=$j"); print $stdout <<"EOF"; Consumer key =========> $ck Consumer secret ======> $cs Access token =========> $at Access token secret ==> $ats EOF open(W, ">$keyf") || (print $stdout ("Unable to write to $keyf: $!\n"), exit); print W "ck=$ck&cs=$cs&at=$at&ats=$ats\n"; close(W); chmod(0600, $keyf) || print $stdout "Warning: could not change permissions on $keyf : $!\n"; print $stdout "Keys written to regenerated keyfile $keyf\n"; print $stdout "Now restart oysttyer.\n"; exit; } # now, get a token (either from Basic Auth, the keyfile or OAuth) ($mytoken, $mytokensecret) = &authtoken; } # unless anonymous # if we are testing the stream, this is where we split if ($streamtest) { print $stdout ">>> STREAMING CONNECT TEST <<< (kill process to end)\n"; &start_streaming; } # this never returns in this mode # initial login tests and command line controls if ($statusurl) { $shorstatusturl = &urlshorten($statusurl); $status = ((length($status)) ? "$status " : "") . $shorstatusturl; } $phase = 0; $didhold = $hold; $hold = -1 if ($hold == 1 && !$script); $credentials = ''; $status = pack("U0C*", unpack("C*", $status)) unless ($seven || !length($status) || $LANG =~ /8859/); # kludgy also if ($status eq '-') { chomp(@status = ); $status = join("\n", @status); } for(;;) { $rv = 0; die( "sorry, you can't tweet anonymously. use an authenticated username.\n") if ($anonymous && length($status)); die( "sorry, status too long: reduce by @{[ &length_tco($status)-$linelength ]} chars, ". "or use -autosplit={word,char,cut}.\n") if (&length_tco($status) > $linelength && !$autosplit); ($status, $next) = &csplit($status, $autosplit) if (!length($next)); if ($autosplit eq 'cut' && length($next)) { print "-- warning: input autotrimmed to $linelength bytes\n"; $next = ""; } if (!$anonymous && !length($whoami) && !length($status)) { # we must be using OAuth tokens. we'll need # to get our screen name from Twitter. we DON'T need this # if we're just posting with -status. print "(checking credentials) "; $data = $credentials = &backticks($baseagent, '/dev/null', undef, $credurl, undef, $anonymous, @wind); $rv = $? || &is_fail_whale($data) || &is_json_error($data); } if (!$rv && length($status) && $phase) { print "post attempt "; $rv = &updatest($status, 0); } else { # no longer a way to test anonymous logins unless ($rv || $anonymous) { print "test-login "; $data = &backticks($baseagent, '/dev/null', undef, $url, undef, $anonymous, @wind); $rv = $?; } } if ($rv || &is_fail_whale($data) || &is_json_error($data)) { if ($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(sub { ; }, qw(USR1 PWR XCPU)); &sigify(sub { $background_is_ready++ }, qw(USR2 SYS UNUSED XFSZ)); if (length($credentials)) { print "-- processing credentials: "; $my_json_ref = &parsejson($credentials); $whoami = lc($my_json_ref->{'screen_name'}); if (!length($whoami)) { print "FAILED!\nis your account suspended, or wrong token?\n"; exit; } print "logged in as $whoami\n"; $credlog = "-- you are logged in as $whoami\n"; } #### BOT/DAEMON MODE STARTUP #### $last_rate_limit = undef; $rate_limit_left = undef; $rate_limit_rate = undef; $rate_limit_next = 0; $effpause = 0; # for both daemon and background if ($daemon) { if (!$pause) { print $stdout "*** kind of stupid to run daemon with pause=0\n"; exit 1; } $lockf ||= "$ENV{'HOME'}/.oysttyerlock"; $lockf = "$ENV{'HOME'}/.oysttyerlock${lockf}" if ($lockf !~ m#/#); if ( -f $lockf) { unless (open(L, "<$lockf")) { print $stdout "*** unable to open existing lock: $!\n"; exit 1; } while () { chomp(); next unless (/^\d+$/); if (kill 0, $_) { print $stdout "*** instance already running: $_\n"; exit 1; } } unless (unlink($lockf)) { print $stdout "*** unable to remove stale lock: $!\n"; exit 1; } } unless (open(L, ">$lockf")) { print $stdout "*** unable to create lock: $lockf: $!\n"; exit 1; } if ($child = fork()) { unless (print L "$child\n") { print $stdout "*** unable to write lock: $!\n"; kill 15, $child; exit 1; } unless (close(L)) { print $stdout "*** unable to close lock: $!\n"; kill 15, $child; } 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); &rmlock; kill 9, $$; }, qw(TERM HUP PIPE)); &sigify("IGNORE", qw(INT)); $bufferpid = &start_streaming; $rin = ''; vec($rin, fileno(STBUF), 1) = 1; } else { &sigify(sub { &rmlock; kill 9, $$; }, qw(TERM HUP PIPE)); } $parent = 0; $dmcount = 1 if ($dmpause); # force fetch $is_background = 1; DAEMONLOOP: for(;;) { my $snooze; my $nfound; my $wake; &$heartbeat; &update_effpause; &refresh(0); $dont_refresh_first_time = 0; if ($dmpause) { if (!--$dmcount) { &dmrefresh(0); $dmcount = $dmpause; } } # service events on the streaming socket, if # we have one. $snooze = ($effpause || 0+$pause || 60); $wake = time() + $snooze; if (!$bufferpid) { sleep $snooze; } else { my $read_failure = 0; SLEEP_AGAIN: for(;;) { $nfound = select($rout = $rin, undef, undef, $snooze); if ($nfound && vec($rout, fileno(STBUF), 1)==1) { my $buf = ''; my $rbuf = ''; my $len; read(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. read(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) { read(STBUF, $rbuf, ($len-length($buf))); $buf .= $rbuf; } &streamevents( &parsejson($buf) ); $snooze = $wake - time(); next SLEEP_AGAIN if ($snooze > 0); } last SLEEP_AGAIN; } } } } die("uncaught fork() exception\n"); } #### INTERACTIVE MODE and CONSOLE STARTUP #### unless ($simplestart) { print <<"EOF"; ###################################################### +oo=========oo+ ${EM}oysttyer ${oysttyer_VERSION}.${padded_patch_version} (c)2017 oysttyer organisation (c)2007-2012 cameron kaiser${OFF} EOF $e = <<'EOF'; all rights reserved. .#*^#=. https://oysttyer.github.io/ %'.,`.#` ;',. ./#` freeware under the floodgap free software license. ({.`,` #/ http://www.floodgap.com/software/ffsl/ `& ,` %,~=*'"*=~=-., \`=_/'.`` - `'. *\. tweet us http://twitter.com/oysttyer (%. - - Ë‹-. `& `&` ~ @ . # ###################################################### `\`. ` .....ËŠ %' # `^~._.,,,.-+=~*' # 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"; oysttyer ${oysttyer_VERSION}.${padded_patch_version} (c)2017 oysttyer organisation (c)2007-2012 cameron kaiser all rights reserved. freeware under the floodgap free software license. http://www.floodgap.com/software/ffsl/ tweet us http://twitter.com/oysttyer type /help for commands or /quit to quit. starting background monitoring process. EOF } if ($superverbose) { print $stdout "-- OMGSUPERVERBOSITYSPAM enabled.\n\n"; } else { print $stdout "-- verbosity enabled.\n\n" if ($verbose); } sleep 3 unless ($silent); # these three functions are outside of the usual API assertions for clarity. # they represent the main loop, which by default is the interactive console. # the main loop can be redefined. #configure promptprefix if ($showusername) { $promptprefix = $whoami ; } else { $promptprefix = "oysttyer"; } sub defaultprompt { my $rv = ($noprompt) ? "" : "$promptprefix> "; my $rvl = ($noprompt) ? 0 : 9; return ($rv, $rvl) if (shift); $wrapseq = 0; print $stdout "${CCprompt}$rv${OFF}" unless ($termrl); } sub defaultaddaction { return 0; } sub defaultmain { if (length($runcommand)) { &prinput($runcommand); &sync_n_quit; } @history = (); print C "rsga---------------\n"; $dont_use_counter = $nocounter; eval '$termrl->hook_no_counter'; $tco_sub = sub { return &main::fastturntotco(shift); }; eval '$termrl->hook_no_tco'; if ($termrl) { while(defined ($_ = $termrl->readline((&$prompt(1))[0]))) { kill $SIGUSR1, $child; # suppress output $rv = &prinput($_); kill $SIGUSR2, $child; # resume output last if ($rv < 0); &sync_console unless (!$rv || !$synch); if ($dont_use_counter ne $nocounter) { # only if we have to -- this is expensive $dont_use_counter = $nocounter; eval '$termrl->hook_no_counter' } } } else { &$prompt; while(<>) { #not stdin so we can read from script files kill $SIGUSR1, $child; # suppress output $rv = &prinput(&uforcemulti($_)); kill $SIGUSR2, $child; # resume output last if ($rv < 0); &sync_console unless (!$rv || !$synch); &$prompt; } &sync_n_quit if ($script); } } # SIGPIPE in particular must be trapped in case someone kills the background # or, in streaming mode, buffer processes. we can't recover from that. # the streamer MUST have been initialized before we start these signal # handlers, or the streamer will try to run them too. eeek! # # DO NOT trap SIGCHLD: we generate child processes that die normally. &sigify(\&end_me, qw(PIPE INT)); &sigify(\&repaint, qw(USR1 PWR XCPU)); sub sigify { # this routine abstracts setting signals to a subroutine reference. # check and see if we have to use POSIX.pm (Perl 5.14+) or we can # still use $SIG for proper signalling. We prefer the latter, but # must support the former. my $subref = shift; my $k; if ($signals_use_posix) { my @w; my $sigaction = POSIX::SigAction->new($subref); while ($k = shift) { my $e = &posix_signal_of($k); # some signals may not exist on all systems. next if (!(0+$e)); POSIX::sigaction($e, $sigaction) || die("sigaction failure: $! $@\n"); } } else { while ($k = shift) { $SIG{$k} = $subref; } } } sub posix_signal_of { die("never call posix_signal_of if signals_use_posix is false\n") if (!$signals_use_posix); # this assumes that POSIX::SIG* returns a scalar int value. # not all signals exist on all systems. this ensures zeroes are # returned for locally bogus ones. return 0+(eval("return POSIX::SIG".shift)); } sub send_repaint { unless ($wrapseq){ return; } $wrapseq = 0; return if ($daemon); if ($child) { # we are the parent, call our repaint &repaint; } else { # we are not the parent, call the parent to repaint itself kill $SIGUSR1, $parent; # send SIGUSR1 } } sub repaint { # try to speed this up, since we do it a lot. $wrapseq = 0; return &$repaintcache if ($repaintcache) ; # cache our repaint function (no-op or redisplay) $repaintcache = sub { ; }; # no-op return unless ($termrl && ($termrl->Features()->{'canRepaint'} || $readlinerepaint)); return if ($daemon); $termrl->redisplay; $repaintcache = sub { $termrl->redisplay; }; } sub send_removereadline { # this just stubs into its own removereadline return &$removereadlinecache if ($removereadlinecache); $removereadlinecache = sub { ; }; return unless ($termrl && $termrl->Features()->{'canRemoveReadline'}); return if ($daemon); $termrl->removereadline; $removereadlinecache = sub { $termrl->removereadline; }; } # start the background process # this has to be last or the background process can't see the full API if ($child = open(C, "|-")) { close(P); } else { close(W); goto MONITOR; } eval'$termrl->hook_background_control' if ($termrl); select(C); $|++; select($stdout); # handshake for synchronicity mode, if we want it. if ($synch) { # we will get two replies for this. print C "synm---------------\n"; &thump; # the second will be cleared by the console } # wait for background to become ready sleep 1 while (!$background_is_ready); # start the &$main; # loop until we quit and then we'll &sync_n_quit if ($script); # else exit; #### command processor #### sub prinput { my $i; local($_) = shift; # bleh # validate this string if we are in UTF-8 mode unless ($seven) { $probe = $_; &$utf8_encode($probe); die("utf8 doesn't work right in this perl. run with -seven.\n") if (&ulength($probe) < length($_)); # should be at least as big if ($probe =~ /($badutf8)/) { print $stdout "*** invalid UTF-8: partial delete of a wide character?\n"; print $stdout "*** ignoring this string\n"; return 0; } } $in_reply_to = 0; $quoted_status_url = undef; 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' || /^oysttyer>/ || $_ eq 'ls' || $_ eq '?' || m#^help /# || $_ eq 'exit')) { &add_history($_); unless ($_ eq 'exit' || /^oysttyer>/ || $_ eq 'ls') { print $stdout "*** did you mean /$_ ?\n"; print $stdout "*** to send this as a command, type /%%\n"; } else { print $stdout "*** did you really mean to tweet \"$_\"?\n"; } print $stdout "*** to tweet it anyway, type %%\n"; return 0; } if (/^\%(\%|-\d+):p$/) { my $x = $1; if ($x eq '%') { print $stdout "=> \"$history[0]\"\n"; } else { $x += 0; if (!$x || $x < -(scalar(@history))) { print $stdout "*** illegal index\n"; } else { print $stdout "=> \"$history[-($x + 1)]\"\n"; } } return 0; } # handle history substitution (including /%%, %%--, %%*, etc.) $i = 0; # flag if (/^\%(\%|-\d+)(--|-\d+|\*)?/) { ($i, $proband, $r, $s) = &sub_helper($1, $2, $_); return 0 if (!$i); $s = quotemeta($s); s/^\%${r}${s}/$proband/; } if (/[^\\]\%(\%|-\d+)(--|-\d+|\*)?$/) { ($i, $proband, $r, $s) = &sub_helper($1, $2, $_); return 0 if (!$i); $s = quotemeta($s); s/\%${r}${s}$/$proband/; } # handle variables second, in case they got in history somehow ... $i = 1 if (s/^\%URL\%/$urlshort/ || s/\%URL\%$/$urlshort/); $i = 1 if (s/^\%RT\%/$retweet/ || s/\%RT\%$/$retweet/); # and escaped history s/^\\\%/%/; if ($i) { print $stdout "(expanded to \"$_\")\n" ; $in_reply_to = $expected_tweet_ref->{'id_str'} || 0 if (defined $expected_tweet_ref && ref($expected_tweet_ref) eq 'HASH'); } else { $expected_tweet_ref = undef; } return 0 unless length; # actually possible to happen # with control char filters and history. &add_history($_); $shadow_history = $_; # handle history display if ($_ eq '/history' || $_ eq '/h') { for ($i = scalar(@history); $i >= 1; $i--) { print $stdout "\t$i\t$history[($i-1)]\n"; } return 0; } my $slash_first = ($_ =~ m#^/#); return -1 if ($_ eq '/quit' || $_ eq '/q' || $_ eq '/bye' || $_ eq '/exit'); return 0 if (scalar(&$addaction($_))); # add commands here # dumper if (m#^/du(mp)? ([zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($2); unless ($code =~ /^d[0-9][0-9]+$/) { # this is a DM. my $tweet = &get_tweet($code); my $k; my $sn; my $id; my @superfields = ( [ "user", "screen_name" ], # must always be first [ "extended_tweet", "full_text" ], [ "retweeted_status", "id_str" ], [ "retweeted_status", "full_text" ], [ "retweeted_status", "text" ], [ "user", "geo_enabled" ], [ "place", "id" ], [ "place", "country_code" ], [ "place", "full_name" ], [ "place", "place_type" ], [ "tag", "type" ], [ "tag", "payload" ], ); my $superfield; if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } foreach $superfield (@superfields) { my $sfn = join('->', @{ $superfield }); my $sfk = "{'" . join("'}->{'", @{ $superfield }) . "'}"; my $sfv; eval "\$sfv = &descape(\$tweet->$sfk);"; print $stdout substr("$sfn ", 0, 25). " $sfv\n"; $sn = $sfv if (!length($sn) && length($sfv)); } # geo is special print $stdout "geo->coordinates (" . join(', ', @{ $tweet->{'geo'}->{'coordinates'} }) . ")\n"; foreach $k (sort keys %{ $tweet }) { next if (ref($tweet->{$k})); print $stdout substr("$k ", 0, 25) . " " . &descape($tweet->{$k}) . "\n"; } # include a URL to the tweet per @augmentedfourth $urlshort = "${http_proto}://twitter.com/$sn/statuses/$tweet->{'id_str'}"; print $stdout "-- %URL% is now $urlshort (/short to shorten)\n"; return 0; } # if dxxxx, fall through to the below. } if (m#^/du(mp)? ([dD][a-zA-Z]?[0-9]+)$#) { my $code = lc($2); my $dm = &get_dm($code); my $k; my $sn; my $id; my @superfields = ( [ "sender", "screen_name" ], # must always be first ); if (!defined($dm)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } foreach $superfield (@superfields) { my $sfn = join('->', @{ $superfield }); my $sfk = "{'" . join("'}->{'", @{ $superfield }) . "'}"; my $sfv; eval "\$sfv = &descape(\$dm->$sfk);"; print $stdout substr("$sfn ", 0, 25). " $sfv\n"; $sn = $sfv if (!length($sn) && length($sfv)); } foreach $k (sort keys %{ $dm }) { next if (ref($dm->{$k})); print $stdout substr("$k ", 0, 25) . " " . &descape($dm->{$k}) . "\n"; } return 0; } # evaluator if (m#^/ev(al)? (.+)$#) { $k = eval $2; print $stdout "==> "; print $streamout "$k $@\n"; return 0; } # version check if (m#^/v(ersion)?check$# || m#^/u(pdate)?check$#) { print $stdout &updatecheck(1); return 0; } # url shortener routine if (($_ eq '/sh' || $_ eq '/short') && length($urlshort)) { $_ = "/short $urlshort"; print $stdout "*** assuming you meant %URL%: $_\n"; # and fall through to ... } if (m#^/sh(ort)? (https?|gopher)(://[^ ]+)#) { my $url = $2 . $3; my $answer = (&urlshorten($url) || 'FAILED -- %% to retry'); print $stdout "*** shortened to: "; print $streamout ($answer . "\n"); $urlshort = $answer; return 0; } # getter for internal value settings if (/^\/r(ate)?l(imit)?$/) { $_ = '/print rate_limit_rate'; # and fall through to ... } if ($_ eq '/p' || $_ eq '/print') { foreach $key (sort keys %opts_can_set) { print $stdout "*** $key => $$key\n" if (!$opts_secret{$key}); } return 0; } if (/^\/p(rint)?\s+([^ ]+)/) { my $key = $2; if ($valid{$key} || $key eq 'effpause' || $key eq 'rate_limit_rate' || $key eq 'rate_limit_left') { my $value = &getvariable($key); print $stdout "*** "; print $stdout "(read-only value) " if (!$opts_can_set{$key}); print $stdout "$key => $value\n"; # I don't see a need for these in &getvariable, so they are # not currently supported. whine if you disagree. } elsif ($key eq 'tabcomp') { if ($termrl) { &generate_otabcomp; } else { print $stdout "*** readline isn't on\n"; } } elsif ($key eq 'ntabcomp') { # sigh if ($termrl) { print $stdout "*** new TAB-comp entries: "; $did_print = 0; foreach(keys %readline_completion) { next if ($original_readline{$_}); $did_print = 1; print $stdout "$_ "; } print $stdout "(none)" if (!$did_print); print $stdout "\n"; } else { print $stdout "*** readline isn't on\n"; } } else { print "*** not a valid option or setting: $key\n"; } return 0; } if ($_ eq '/verbose' || $_ eq '/ve') { $verbose ^= 1; $_ = "/set verbose $verbose"; print $stdout "-- verbosity.\n" if ($verbose); # and fall through to set } # search api integration (originally based on @kellyterryjones', # @vielmetti's and @br3nda's patches) if (/^\/se(arch)?\s+(\+\d+\s+)?(.+)\s*$/) { my $countmaybe = $2; my $kw = $3; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $countmaybe ||= $searchhits; $kw = &url_oauth_sub($kw); $kw = "q=$kw" if ($kw !~ /^q=/); my $r = &grabjson("$queryurl?$kw", 0, 0, $countmaybe, { "type" => "search", "payload" => $k }, 1); if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })) { &dt_tdisplay($r, 'search'); } else { print $stdout "-- sorry, no results were found.\n"; } &$conclude; return 0; } if ($_ eq '/notrack') { # special case print $stdout "*** all tracking keywords cancelled\n"; $track = ''; &setvariable('track', $track, 1); return 0; } if (s/^\/troff\s+// && s/\s*// && length) { # remove it from array, regenerate $track, call tracktags_makearray # and then sync my $k; my $l = ''; my $q = 0; my %w; $_ = lc($_); my (@ptags) = split(/\s+/, $_); # filter duplicates and merge quoted strings (again) # but this time we're building up a hash for fast searches foreach $k (@ptags) { if ($q && $k =~ /"$/) { # this has to be first $l .= " $k"; $q = 0; } elsif ($k =~ /^"/ || $q) { $l .= (length($l)) ? " $k" : $k; $q = 1; next; } else { $l = $k; } next if ($w{$l}); # ignore silently here $w{$l} = 1; $l = ''; } print $stdout "-- warning: syntax error, missing quote?\n" if ($q); # now filter out of @tracktags @ptags = (); foreach $k (@tracktags) { push (@ptags, $k) unless ($w{$k}); } unless (scalar(@ptags) < scalar(@tracktags)) { print $stdout "-- sorry, no track terms matched.\n"; print $stdout (length($track) ? "-- you are tracking: $track\n" : "-- (maybe because you're not tracking anything?)\n"); return 0; } print $stdout "*** ok, filtered @{[ keys(%w) ]}\n"; $track = join(' ', @ptags); &setvariable('track', $track, 1); return 0; } if (s#^/tre(nds)?\s*##) { my $t = undef; my $wwoeid = (length) ? $_ : $woeid; $wwoeid ||= "1"; my $r = &grabjson("${wtrendurl}?id=${wwoeid}", 0, 0, 0, undef, 1); my $fr = ($wwoeid && $wwoeid ne '1') ? " FOR WOEID $wwoeid" : ' GLOBALLY'; if (defined($r) && ref ($r) eq 'ARRAY') { $t = $r->[0]->{'trends'}; } if (defined($t) && ref($t) eq 'ARRAY') { my $i; my $j; print $stdout "${EM}<<< TRENDING TOPICS${fr} >>>${OFF}\n"; foreach $j (@{ $t }) { my $k = &descape($j->{'name'}); my $l = ($k =~ /\sOR\s/) ? $k : ($k =~ /^"/) ? $k : ('"' . $k . '"'); print $streamout "/search $l\n"; $k =~ s/\sOR\s/ /g; $k = '"' . $k . '"' if ($k =~ /\s/ && $k !~ /^"/); print $streamout "/tron $k\n"; } print $stdout "${EM}<<< TRENDING TOPICS >>>${OFF}\n"; } else { print $stdout "-- sorry, trends not available for WOEID $wwoeid.\n"; } return 0; } # woeid finder based on lat/long if ($_ eq '/woeids') { my $max = 10; if (!$lat && !$long) { print $stdout "-- set your location with lat/long first.\n"; return 0; } my $r = &grabjson("$atrendurl?lat=$lat&long=$long", 0, 0, 0, undef, 1); if (defined($r) && ref($r) eq 'ARRAY') { my $i; foreach $i (@{ $r }) { my $woeid = &descape($i->{'woeid'}); my $nm = &descape($i->{'name'}) . ' (' . &descape($i->{'countryCode'}) .')'; print $streamout "$nm\n/set woeid $woeid\n"; last unless ($max--); } } else { print $stdout "-- sorry, couldn't get a supported WOEID for your location.\n"; } return 0; } 1 if (s/^\/#([^\s]+)/\/tron #\1/); # /# command falls through to tron if (s/^\/tron\s+// && s/\s*$// && length) { $_ = lc($_); $track .= " " if (length($track)); $_ = "/set track ${track}$_"; # fall through to set } if (/^\/track ([^ ]+)/) { s#^/#/set #; # and fall through to set } # /listoff if (s/^\/list?off\s+// && s/\s*$// && length) { if (/,/ || /\s+/) { print $stdout "-- one list at a time please\n"; return 0; } if (!scalar(@listlist)) { print $stdout "-- ok! that was easy! (you don't have any lists in your timeline)\n"; return 0; } my $w; my $newlists = ''; my $didfilter = 0; foreach $w (@listlist) { my $x = join('/', @{ $w }); if ($x eq $_ || "$whoami$_" eq $x || "$whoami/$_" eq $x) { print $stdout "*** ok, filtered $x\n"; $didfilter = 1; } else { $newlists .= (length($newlists)) ? ",$x" : $x; } } if ($didfilter) { &setvariable('lists', $newlists, 1); } else { print $stdout "*** hmm, no such list? current value:\n"; print $stdout "*** lists => ", &getvariable('lists'), "\n"; } return 0; } # /liston if (s/^\/list?on\s+// && s/\s*$// && length) { if (/,/ || /\s+/) { print $stdout "-- one list at a time please\n"; return 0; } my $uname; my $lname; if (m#/#) { ($uname, $lname) = split(m#/#, $_, 2); } else { $lname = $_; $uname = ''; } if (!length($uname) && $anonymous) { print $stdout "-- you must specify a username for a list when anonymous.\n"; return 0; } $uname ||= $whoami; # check the list validity my $my_json_ref = &grabjson( "${statusliurl}?owner_screen_name=${uname}&slug=${lname}", 0, 0, 0, undef, 1); if (!$my_json_ref || ref($my_json_ref) ne 'ARRAY') { print $stdout "*** list $uname/$lname seems bogus; not added\n"; return 0; } $_ = "/add lists $uname/$lname"; # fall through to add } if (s/^\/a(uto)?lists?\s+// && s/\s*$// && length) { s/\s+/,/g if (!/,/); print $stdout "--- warning: lists aren't checked en masse; make sure they exist\n"; $_ = "/set lists $_"; # and fall through to set } # setter for internal value settings # shortcut for boolean settings if (/^\/s(et)? ([^ ]+)\s*$/) { my $key = $2; $_ = "/set $key 1" if($opts_boolean{$key} && $opts_can_set{$key}); # fall through to three argument version } if (/^\/uns(et)? ([^ ]+)\s*$/) { my $key = $2; if ($opts_can_set{$key} && $opts_boolean{$key}) { &setvariable($key, 0, 1); return 0; } &setvariable($key, undef, 1); return 0; } # stubs out to set variable if (/^\/s(et)? ([^ ]+) (.+)\s*$/) { my $key = $2; my $value = $3; &setvariable($key, $value, 1); return 0; } # append to a variable (if not boolean) if (/^\/ad(d)? ([^ ]+) (.+)\s*$/) { my $key = $2; my $value = $3; if ($opts_boolean{$key}) { print $stdout "*** why are you appending to a boolean?\n"; return 0; } if (length(&getvariable($key))) { $value = " $value" if ($opts_space_delimit{$key}); $value = ",$value" if ($opts_comma_delimit{$key}); } &setvariable($key, &getvariable($key).$value, 1); return 0; } # delete from a variable (if not boolean) if (/^\/del ([^ ]+) (.+)\s*$/) { my $key = $1; my $value = $2; my $old; if ($opts_boolean{$key}) { print $stdout "*** why are you deleting from a boolean?\n"; return 0; } if (!length($old = &getvariable($key))) { print $stdout "*** $key is already empty\n"; return 0; } my $del = ($opts_space_delimit{$key}) ? '\s+' : ($opts_comma_delimit{$key}) ? '\s*,\s*' : undef; if (!defined($del)) { # simple substitution 1 while ($old =~ s/$value//g); } else { 1 while ($old =~ s/$del$value($del)/\1/g); 1 while ($old =~ s/^$value$del//); 1 while ($old =~ s/$del$value//); } &setvariable($key, $old, 1); return 0; } # I thought about implementing a /pdel but besides being ugly # I don't think most people will push a truncated setting. tell me # if I'm wrong. # stackable settings if (/^\/pu(sh)? ([^ ]+)\s*$/) { my $key = $2; if ($opts_can_set{$key}) { if ($opts_boolean{$key}) { $_ = "/push $key 1"; # fall through to three argument version } else { if (!$opts_can_set{$key}) { print $stdout "*** setting is not stackable: $key\n"; return 0; } my $old = &getvariable($key); push(@{ $push_stack{$key} }, $old); print $stdout "--- saved on stack for $key: $old\n"; return 0; } } } # common code for set and append if (/^\/(pu|push|pad|padd) ([^ ]+) (.+)\s*$/) { my $comm = $1; my $key = $2; my $value = $3; $comm = ($comm =~ /^pu/) ? "push" : "padd"; if ($opts_boolean{$key} && $comm eq 'padd') { print $stdout "*** why are you appending to a boolean?\n"; return 0; } if (!$opts_can_set{$key}) { print $stdout "*** setting is not stackable: $key\n"; return 0; } my $old = &getvariable($key); $old += 0 if ($opts_boolean{$key}); push(@{ $push_stack{$key} }, $old); print $stdout "--- saved on stack for $key: $old\n"; if ($comm eq 'padd' && length($old)) { $value = " $value" if ($opts_space_delimit{$key}); $value = ",$value" if ($opts_comma_delimit{$key}); $old .= $value; } else { $old = $value; } &setvariable($key, $old, 1); return 0; } # we assume that if the setting is in the push stack, it's valid if (/^\/pop ([^ ]+)\s*$/) { my $key = $1; if (!scalar(@{ $push_stack{$key} })) { print $stdout "*** setting is not stacked: $key\n"; return 0; } &setvariable($key, pop(@{ $push_stack{$key} }), 1); return 0; } # shell escape if (s/^\/\!// && s/\s*$// && length) { system("$_"); $x = $? >> 8; print $stdout "*** exited with $x\n" if ($x); return 0; } if ($_ eq '/help' || $_ eq '/?') { print <<'EOF'; [1 of 5] *** BASIC COMMANDS: :a$AAOOOOOOOOOOOOOOOOOAA$a, ================== +@A:. .:B@+ ANYTHING WITHOUT /refresh =@B HELP!!! HELP!!! B@= A LEADING / IS grabs the newest :a$Ao oA$a, SENT AS A TWEET! tweets right ;AAA$a; :a$AAAAAAAAAAA; ================== away (or tells :AOaaao:, .:oA*:. JUST TYPE TO TALK! you if there .;=$$$OBO***+ .+aaaa$: is nothing new) :*; :***O@Aaaa*o, ============ by thumping .+++++: o#o REMEMBER!! the background :OOOOOOA*:::, =@o ,:::::. ============ process. .+++++++++: =@*.....=a$OOOB#; MANY COMMANDS, AND =@OoO@BAAA#@$o, ALL TWEETS ARE /again =@o .+aaaaa: --ASYNCHRONOUS-- displays most recent =@Aaaaaaaaaa*o*a;, and might not always tweets, both old and =@$++=++++++:,;+aA: respond new. ,+$@*.=O+ ...oO; oAo+. immediately! ,+o$OO=.+aA#####Oa;.*OO$o+. /dm and /dmagain for DMs. +Ba::;oaa*$Aa=aA$*aa=;::$B: ,===O@BOOOOOOOOO#@$===, /replies o@BOOOOOOOOO#@+ ================== shows replies and mentions. o@BOB@B$B@BO#@+ USE + FOR A COUNT: o@*.a@o a@o.$@+ /re +30 => last 30 replies /quit resumes your boring life. o@B$B@o a@A$#@+ ========================== EOF &linein("PRESS RETURN/ENTER>"); print <<"EOF"; [2 of 5] +- MORE COMMANDS --+ -=-=- USER STUFF -=-=- | | /whois username displays info about username | See the oysttyer | /again username views their most recent tweets | home page for | /wagain username combines them all | complete list | /follow username follow a username | | /leave username stop following a username +----------------- + EOF &linein("PRESS RETURN/ENTER>"); print <<"EOF"; [3 of 5] +--- TWEET SELECTION --------------------------------------------------------+ | all tweets have menu codes (letters + number). example: | | a5> Send me Dr Pepper https://oysttyer.github.io/ | | /reply a5 message replies to tweet a5 | | example: /reply a5 I also like Dr Pepper | | becomes \@oysttyer I also like Dr Pepper (and is threaded) | | /thread a5 if a5 is part of a thread (the username | | has a \@ or \") then show all posts up | | to that | | /url a5 opens all URLs in tweet a5 | | Mac OS X users, do first: /set urlopen open %U | | Dummy terminal users, try /set urlopen lynx -dump %U | more | | /delete a5 deletes tweet a5, if it's your tweet | | /rt a5 retweets (or quotes) tweet a5 | | example: /rt a5 | | becomes: RT \@oysttyer: Send me... | | example: /rt a5 message | | becomes: Some smart comment about [tweet a5] | +--- Abbreviations: /re, /th, /url, /del --- menu codes wrap around at end --+ EOF &linein("PRESS RETURN/ENTER>"); print <<"EOF"; [4 of 5] +--- DM SPECIFIC ------------------------------------------------------------+ | all DMs have menu codes (letters + number, prefixed with d). example: | | [DM da0][oysttyer/Sun Jan 32 1969] I think you are cute | | /dm username message send a username a DM | | /qdm a5 username Share a tweet via a DM | | example: /qdm a5 \@oysttyer A secret comment about this tweet | | becomes: d oysttyer A secret comment about this tweet https://... | | /edm username message Opens message in \$EDITOR before sending | | /edmreply da0 message Also opens message in \$EDITOR | +---------------------------------------------------------------------------+ =====> /reply, /delete and /url work for direct message menu codes too! <===== EOF &linein("PRESS RETURN/ENTER>"); print <<"EOF"; [5 of 5] 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: https://oysttyer.github.io/ oysttyer $oysttyer_VERSION is (c)2017 oysttyer organisation (c)2007-2012 cameron kaiser + contributors. all rights reserved. this software is offered AS IS, with no guarantees. it is not endorsed by Obvious or the executives and developers of Twitter. *** subscribe to updates at http://twitter.com/oysttyer submit your suggestions at https://github.com/oysttyer/oysttyer EOF return 0; } if ($_ eq '/ruler' || $_ eq '/ru') { my ($prompt, $prolen) = (&$prompt(1)); $prolen = " " x $prolen; print $stdout <<"EOF"; ${prolen} 1 2 3 4 5 6 7 8 9 0 1 2 3 XX ${prompt}1...5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5...XX EOF return 0; } if ($_ eq '/cls' || $_ eq '/clear') { if ($ansi) { print $stdout "${ESC}[H${ESC}[2J\n"; } else { print $stdout ("\n" x ($ENV{'ROWS'} || 50)); } return 0; } if ($_ eq '/refresh' || $_ eq '/thump' || $_ eq '/r') { print $stdout "-- /refresh in streaming mode is pretty impatient\n" if ($dostream); &thump; return 0; } if (m#^/a(gain)?(\s+\+\d+)?$#) { # the asynchronous form my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if ($countmaybe > 999) { print $stdout "-- greedy bastard, try +fewer.\n"; return 0; } $countmaybe = sprintf("%03i", $countmaybe); print $stdout "-- background request sent\n" unless ($synch); print C "reset${countmaybe}-----------\n"; &sync_semaphore; return 0; } # this is for users -- list form is below if ($_ =~ m#^/(w)?a(gain)?\s+(\+\d+\s+)?([^\s/]+)$#) { #synchronous form my $mode = $1; my $uname = lc($4); my $countmaybe = $3; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $uname =~ s/^\@//; $readline_completion{'@'.$uname}++ if ($termrl); print $stdout "-- synchronous /again command for $uname ($countmaybe)\n" if ($verbose); my $my_json_ref = &grabjson("${uurl}?screen_name=${uname}&include_rts=true", 0, 0, $countmaybe, undef, 1); &dt_tdisplay($my_json_ref, 'again'); unless ($mode eq 'w' || $mode eq 'wf') { return 0; } # else fallthrough } if ($_ =~ m#^/w(hois|a|again)?\s+(\+\d+\s+)?\@?([^\s]+)#) { my $uname = lc($3); $uname =~ s/^\@//; $readline_completion{'@'.$uname}++ if ($termrl); print $stdout "-- synchronous /whois command for $uname\n" if ($verbose); my $my_json_ref = &grabjson("${wurl}?screen_name=${uname}", 0, 0, 0, undef, 1); if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' && length($my_json_ref->{'screen_name'})) { my $sturl = undef; my $purl = &descape($my_json_ref->{'profile_image_url'}); if ($avatar && length($purl) && $purl !~ m#^http://[^.]+\.(twimg\.com|twitter\.com).+/images/default_profile_\d+_normal.png#) { my $exec = $avatar; my $fext; ($purl =~ /\.([a-z0-9A-Z]+)$/) && ($fext = $1); if ($purl !~ /['\\]/) { # careful! $exec =~ s/\%U/'$purl'/g; $exec =~ s/\%N/$uname/g; $exec =~ s/\%E/$fext/g; print $stdout "\n"; print $stdout "($exec)\n" if ($verbose); system($exec); } } print $streamout "\n"; &userline($my_json_ref, $streamout); print $streamout &wwrap( "\"@{[ &strim(&descape($my_json_ref->{'description'})) ]}\"\n") if (length(&strim($my_json_ref->{'description'}))); if (length($my_json_ref->{'url'})) { $sturl = $urlshort = &descape($my_json_ref->{'url'}); $urlshort =~ s/^\s+//; $urlshort =~ s/\s+$//; print $streamout "${EM}URL:${OFF}\t\t$urlshort\n"; } print $streamout &wwrap( "${EM}Location:${OFF}\t@{[ &descape($my_json_ref->{'location'}) ]}\n") if (length($my_json_ref->{'location'})); print $streamout <<"EOF"; ${EM}Picture:${OFF}\t@{[ &descape($my_json_ref->{'profile_image_url'}) ]} EOF unless ($anonymous || $whoami eq $uname) { my $g = &grabjson( "$frurl?source_screen_name=$whoami&target_screen_name=$uname", 0, 0, 0, undef, 1); print $streamout &wwrap( "${EM}Do you follow${OFF} this user? ... ${EM}$g->{'relationship'}->{'target'}->{'followed_by'}${OFF}\n") if (ref($g) eq 'HASH'); my $g = &grabjson( "$frurl?source_screen_name=$uname&target_screen_name=$whoami", 0, 0, 0, undef, 1); print $streamout &wwrap( "${EM}Does this user follow${OFF} you? ... ${EM}$g->{'relationship'}->{'target'}->{'followed_by'}${OFF}\n") if (ref($g) eq 'HASH'); print $streamout "\n"; } print $stdout &wwrap( "-- %URL% is now $urlshort (/short shortens, /url opens)\n") if (defined($sturl)); } return 0; } if (m#^/(df|doesfollow)\s+\@?([^\s]+)$#) { if ($anonymous) { print $stdout "-- who follows anonymous anyway?\n"; return 0; } $_ = "/doesfollow $2 $whoami"; print $stdout "*** assuming you meant: $_\n"; # fall through to ... } if (m#^/(df|doesfollow)\s+\@?([^\s]+)\s+\@?([^\s]+)$#) { my $user_a = $2; my $user_b = $3; if ($user_a =~ m#/# || $user_b =~ m#/#) { print $stdout "--- sorry, this won't work on lists.\n"; return 0; } my $g = &grabjson( "${frurl}?source_screen_name=${user_a}&target_screen_name=${user_b}", 0, 0, 0, undef, 1); if ($msg = &is_json_error($g)) { print $stdout <<"EOF"; ${MAGENTA}*** warning: server error message received *** "$ec"${OFF} EOF } elsif ($g->{'relationship'}->{'target'}) { print $stdout "--- does $user_a follow ${user_b}? => "; print $streamout "$g->{'relationship'}->{'target'}->{'followed_by'}\n" } else { print $stdout "-- sorry, bogus server response, try again later.\n"; } return 0; } # this is dual-headed and supports both lists and regular followers. if(s#^/(frs|friends|fos|followers)(\s+\+\d+)?\s*##) { my $countmaybe = $2; my $mode = $1; my $arg = lc($_); my $lname = ''; my $user = ''; my $what = ''; $arg =~ s/^@//; $who = $arg; ($who, $lname) = split(m#/#, $arg, 2) if (m#/#); if (length($lname) && !length($user) && $anonymous) { print $stdout "-- you must specify a username for a list when anonymous.\n"; return 0; } $who ||= $whoami; if (!length($lname)) { $what = ($mode eq 'frs' || $mode eq 'friends') ? "friends" : "followers"; $mode = ($mode eq 'frs' || $mode eq 'friends') ? $friendsurl : $followersurl; } else { $what = ($mode eq 'frs' || $mode eq 'friends') ? "friends/members" : "followers/subscribers"; $mode = ($mode eq 'frs' || $mode eq 'friends') ? $getliurl : $getfliurl; $user = "&owner_screen_name=${who}&slug=${lname}"; $who = "list $who/$lname"; } $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $countmaybe ||= 20; # we use the undocumented count= support to, by default, # reduce the JSON parsing overhead. if we always had to take # all 100, we really eat it on parsing. the downside is that, # per @episod, the stuff we get is "less" fresh. my $countper = ($countmaybe < 100) ? $countmaybe : 100; if (!length($lname)) { # we need to get IDs, then call lookup. right now it's # limited to 5000 because that is the limit for API 1.1 # without having to do pagination here too. sorry. if ($countmaybe >= 5000) { print $stdout "-- who do you think you are? Scoble? currently limited to 4999 or less\n"; return 0; } # grab all the IDs my $ids_ref = &grabjson( "$mode?count=${countmaybe}&screen_name=${who}&stringify_ids=true", 0, 0, 0, undef, 1); return 0 if (!$ids_ref || ref($ids_ref) ne 'HASH' || !$ids_ref->{'ids'}); $ids_ref = $ids_ref->{'ids'}; return 0 if (ref($ids_ref) ne 'ARRAY'); my @ids = @{ $ids_ref }; @ids = sort { 0+$a <=> 0+$b } @ids; # make it somewhat deterministic my $dount = &min($countmaybe, scalar(@ids)); my $swallow = &min(100, $dount); my @usarray = undef; shift(@usarray); # force underflow my $l_ref = undef; # for each block of $countper, emit my $printed = 0; FFABIO: while ($dount--) { if (!scalar(@usarray)) { my @next_ids; last FFABIO if (!scalar(@ids)); # if we asked for less than 100, get # that. otherwise, # get the top 100 off that list (or # the list itself, if 100 or less) if (scalar(@ids) <= $swallow) { @next_ids = @ids; @ids = (); } else { @next_ids = @ids[0..($swallow-1)]; @ids = @ids[$swallow..$#ids]; } # turn it into a list to pass to # lookupidurl and get the list $l_ref = &postjson($lookupidurl, "user_id=".&url_oauth_sub(join(',', @next_ids))); last FFABIO if(ref($l_ref) ne 'ARRAY'); @usarray = sort { 0+($a->{'id'}) <=> 0+($b->{'id'}) } @{ $l_ref }; last if (!scalar(@usarray)); } &$userhandle(shift(@usarray)); $printed++; } print $stdout "-- sorry, no $what found for $who.\n" if (!$printed); return 0; } # lists # loop through using the cursor until desired number. my $cursor = -1; # initial value my $printed = 0; my $nofetch = 0; my $json_ref = undef; my @usarray = undef; shift(@usarray); # force underflow # this is a simpler version of the above. FABIO: while($countmaybe--) { if(!scalar(@usarray)) { last FABIO if ($nofetch); $json_ref = &grabjson( "${mode}?count=${countper}&cursor=${cursor}${user}", 0, 0, 0, undef, 1); @usarray = @{ $json_ref->{'users'} }; last FABIO if (!scalar(@usarray)); $cursor = $json_ref->{'next_cursor_str'} || $json_ref->{'next_cursor'} || -1; $nofetch = ($cursor < 1) ? 1 : 0; } &$userhandle(shift(@usarray)); $printed++; } print $stdout "-- sorry, no $what found for $who.\n" if (!$printed); return 0; } # threading if (m#^/th(read)?\s+(\+\d+\s+)?([zZ]?[a-zA-Z]?[0-9]+)$#) { my $countmaybe = $2; if (length($countmaybe)) { print $stdout "-- /thread does not (yet) support +count\n"; return 0; } my $code = lc($3); my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } my $limit = 9; my $id = $tweet->{'retweeted_status'}->{'id_str'} || $tweet->{'in_reply_to_status_id_str'} || $tweet->{'quoted_status_id_str'}; my $thread_ref = [ $tweet ]; while ($id && $limit) { print $stdout "-- thread: fetching $id\n" if ($verbose); my $next = &grabjson("${idurl}?id=${id}", 0, 0, 0, undef, 1); $id = 0; $limit--; if (defined($next) && ref($next) eq 'HASH') { push(@{ $thread_ref }, &fix_geo_api_data($next)); $id = $next->{'retweeted_status'}->{'id_str'} || $next->{'in_reply_to_status_id_str'} || $next->{'quoted_status_id_str'} || 0; } } &tdisplay($thread_ref, 'thread', 0, 1); # use the mini-menu return 0; } # pull out entities. this works for DMs and tweets. # btw: T.CO IS WACK. if (m#^/ent?(ities)? ([dDzZ]?[a-zA-Z]?[0-9]+)$#) { my $v; my $w; my $thing; my $genurl; my $code = lc($2); my $hash; if ($code !~ /[a-z]/) { # this is an optimization: we don't need to get # the old tweet since we're going to fetch it anyway. $hash = { "id_str" => $code }; $thing = "tweet"; $genurl = $idurl; } elsif ($code =~ /^d.[0-9]+$/) { $hash = &get_dm($code); $thing = "DM"; $genurl = $dmidurl; } else { $hash = &get_tweet($code); $thing = "tweet"; $genurl = $idurl; } if (!defined($hash)) { print $stdout "-- no such $thing (yet?): $code\n"; return 0; } my $id = $hash->{'id_str'}; $hash = &grabjson("${genurl}?id=${id}", 0, 0, 0, undef, 1); if (!defined($hash) || ref($hash) ne 'HASH') { print $stdout "-- failed to get entities from server, sorry\n"; return 0; } # if a retweeted status, get the status. $hash = $hash->{'retweeted_status'} if (defined($hash->{'retweeted_status'}) && ref($hash->{'retweeted_status'}) eq 'HASH'); my $didprint = 0; my $entitiesprint = 0; # Twitter puts entities in multiple fields. # Target extended_entities, originally based on following from @myshkin (github) / @justarobert (twitter) # from: https://gist.github.com/myshkin/5bfb2f5e795bc2cf2146#file-gistfile1-pl foreach my $entities (qw(entities extended_entities)) { $entitiesprint = 1; foreach $type (qw(media urls)) { my $array = $hash->{$entities}->{$type}; next if (!defined($array) || ref($array) ne 'ARRAY'); foreach $entry (@{ $array }) { next if (!defined($entry) || ref($entry) ne 'HASH'); next if (!length($entry->{'url'}) || (!length($entry->{'expanded_url'}) && !length($entry->{'media_url'}))); if ($entitiesprint) { print $stdout "$entities:\n"; $entitiesprint = 0; } my $u1 = &descape($entry->{'url'}); if (defined($entry->{'video_info'})) { foreach $variant (@{ $entry->{'video_info'}->{'variants'} }) { my $videourl = &descape($variant->{'url'}); print $stdout "$u1 => $videourl\n"; } } else { my $u2 = &descape($entry->{'expanded_url'}); my $u3 = &descape($entry->{'media_url'}); my $u4 = &descape($entry->{'media_url_https'}); $u2 = $u4 || $u3 || $u2; print $stdout "$u1 => $u2\n"; } #To stay compliant with TOS we can only open the tco. $urlshort = $u1; $didprint++; } } } if ($didprint) { print $stdout &wwrap( "-- %URL% is now $urlshort (/url opens)\n"); } else { print $stdout "-- no entities or URLs found\n"; } return 0; } if (($_ eq '/url' || $_ eq '/open') && length($urlshort)) { $_ = "/url $urlshort"; print $stdout "*** assuming you meant %URL%: $_\n"; # and fall through to ... } if (m#^/(url|open)\s+(http|gopher|https|ftp)://.+# && s#^/(url|open)\s+##) { &openurl($_); return 0; } if (m#^/(url|open|web) ([dDzZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($2); my $tweet; my $genurl = undef; $urlshort = undef; if ($code =~ /^d/ && length($code) > 2) { $tweet = &get_dm($code); # USO! if (!defined($tweet)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } $genurl = $dmidurl; } else { $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } $genurl = $idurl; } # Just open the link to the tweet itself if (m#^/web#) { # DMs don't have links if ($code =~ /^d[${alphabet}]/) { print "*** DMs don\'t have links\n"; } else { &openurl("${http_proto}://twitter.com/$tweet->{'user'}->{'screen_name'}/statuses/$tweet->{'id_str'}"); } return 0; } # to be TOS-compliant, we must try entities first to use # t.co wrapped links. this is a tiny version of /entities. unless ($notco) { my $id = $tweet->{'retweeted_status'}->{'id_str'} || $tweet->{'id_str'}; my $hash; # only fetch if we have to. if we already fetched # because we were given a direct id_str instead of a # menu code, then we already have the entities. if ($code !~ /^[0-9]+$/) { $hash = &grabjson("${genurl}?id=${id}", 0, 0, 0, undef, 1); } else { # MAKE MONEY FAST WITH OUR QUICK CACHE PLAN $hash = $tweet; } if (defined($hash) && ref($hash) eq 'HASH') { my $w; my $v; my $didprint = 0; # Twitter puts entities in multiple fields. Now also target extended_entities # Unfortunately if TOS-compliance means opening t.co links then Twitter uses one link for all photos, videos, etc # so... no point opening multiple links if the same. Use hash to avoid duplicates my $links = {}; foreach my $entities (qw(entities extended_entities)) { foreach $type (qw(media urls)) { my $array = $hash->{$entities}->{$type}; next if (!defined($array) || ref($array) ne 'ARRAY'); foreach $entry (@{ $array }) { next if (!defined($entry) || ref($entry) ne 'HASH'); next if (!length($entry->{'url'}) || (!length($entry->{'expanded_url'}) && !length($entry->{'media_url'}))); my $u1 = &descape($entry->{'url'}); $links->{$u1} = 1; } } } while (( $link, $_l ) = each %$links ) { &openurl($link); $didprint++; } print $stdout "-- sorry, couldn't find any URL.\n" if (!$didprint); return 0; } print $stdout "-- unable to use t.co URLs, using fallback\n"; } # that failed, so fall back on the old method. my $text = &descape($tweet->{'text'}); # findallurls while ($text =~ s#(h?ttp|h?ttps|ftp|gopher)://([a-zA-Z0-9_~/:%\-\+\.\=\&\?\#,]+)##){ # sigh. I HATE YOU TINYARRO.WS #TODO # eventually we will have to put a punycode implementation into openurl # to handle things like Mac OS X's open which don't understand UTF-8 URLs. # when we do, uncomment this again # =~ s#(http|https|ftp|gopher)://([^'\\]+?)('|\\|\s|$)##) { my $url = $1 . "://$2"; $url = "h$url" if ($url =~ /^ttps?:/); $url =~ s/[\.\?]$//; &openurl($url); } print $stdout "-- sorry, couldn't find any URL.\n" if (!defined($urlshort)); return 0; } #TODO if (s/^\/(likes)(\s+\+\d+)?\s*//) { my $my_json_ref; my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if (length) { $my_json_ref = &grabjson("${favsurl}?screen_name=$_", 0, 0, $countmaybe, undef, 1); } else { if ($anonymous) { print $stdout "-- sorry, you can't haz likes if you're anonymous.\n"; } else { print $stdout "-- synchronous /likes user command\n" if ($verbose); $my_json_ref = &grabjson($favsurl, 0, 0, $countmaybe, undef, 1); } } if (defined($my_json_ref) && ref($my_json_ref) eq 'ARRAY') { if (scalar(@{ $my_json_ref })) { my $w = "-==- likes " x 10; $w = $EM . substr($w, 0, $wrap || 79) . $OFF; print $stdout "$w\n"; &tdisplay($my_json_ref, "likes"); print $stdout "$w\n"; } else { print $stdout "-- no likes found, boring impartiality concluded.\n"; } } &$conclude; return 0; } if ( m#^/(un)?l(rt|retweet|i|ike)? ([zZ]?[a-zA-Z]?[0-9]+)$#) { my $mode = $1; my $secondmode = $2; my $code = lc($3); $secondmode = ($secondmode eq 'retweet') ? 'rt' : $secondmode; if ($mode eq 'un' && $secondmode eq 'rt') { print $stdout "-- hmm. seems contradictory. no dice.\n"; return 0; } my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } &cordfav($tweet->{'id_str'}, 1, (($mode eq 'un') ? $favdelurl : $favurl), &descape($tweet->{'text'}), (($mode eq 'un') ? 'removed' : 'created')); if ($secondmode eq 'rt') { $_ = "/rt $code"; # and fall through } else { return 0; } } # Retweet API (including quoted tweets) and manual RTs if (s#^/([oe]?)r(etweet|t) ([zZ]?[a-zA-Z]?[0-9]+)\s*##) { my $mode = $1; my $code = lc($3); my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } # use a native retweet unless we can't (or user used /ort /ert) unless ($nonewrts || length || length($mode)) { # we don't always get rs->text, so we simulate it. my $text = &descape($tweet->{'text'}); $text =~ s/^RT \@[^\s]+:\s+// if ($tweet->{'retweeted_status'}->{'id_str'}); print $stdout "-- status retweeted\n" unless(&updatest($text, 1, 0, undef, $tweet->{'retweeted_status'}->{'id_str'} || $tweet->{'id_str'})); return 0; } # we can't or user requested /ert /ort if (($mode eq 'o') || ($mode eq 'e') || $nonewrts ) { $retweet = "RT @" . &descape($tweet->{'user'}->{'screen_name'}) . ": " . &descape($tweet->{'text'}); if ($mode eq 'e') { &add_history($retweet); print $stdout &wwrap( "-- ok, %RT% and %% are now \"$retweet\"\n"); return 0; } $_ = (length) ? "$retweet $_" : $retweet; } # otherwise it is a quote tweet $sn = &descape($tweet->{'user'}->{'screen_name'}); $quoted_status_url = "${http_proto}://twitter.com/$sn/statuses/$tweet->{'id_str'}"; print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto TWEETPRINT; # fugly! FUGLY! } if (m#^/(re)?rts?of?me?(\s+\+\d+)?$# && !$nonewrts) { #TODO # when more fields are added, integrate them over the JSON_ref my $mode = $1; my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; my $my_json_ref = &grabjson($rtsofmeurl, 0, 0, $countmaybe); &dt_tdisplay($my_json_ref, "rtsofme"); if ($mode eq 're') { $_ = '/re'; # and fall through ... } else { return 0; } } if (m#^/rts?of\s+([zZ]?[a-zA-Z]?[0-9]+)$# && !$nonewrts) { my $code = lc($1); my $tweet = &get_tweet($code); my $id; if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } $id = $tweet->{'retweeted_status'}->{'id_str'} || $tweet->{'id_str'}; if (!$id) { print $stdout "-- hmmm, that tweet is major bogus.\n"; return 0; } my $url = $rtsbyurl; $url =~ s/%I/$id/; my $users_ref = &grabjson("$url", 0, 0, 100, undef, 1); return if (!defined($users_ref) || ref($users_ref) ne 'ARRAY'); my $k = scalar(@{ $users_ref }); if (!$k) { print $stdout "-- no known retweeters, or they're private.\n"; return 0; } my $j; foreach $j (@{ $users_ref }) { &$userhandle($j->{'user'}); } return 0; } # enable and disable NewRTs from users # we allow this even if newRTs are off from -nonewrts if (s#^/rts(on|off)\s+## && length) { &rtsonoffuser($_, 1, ($1 eq 'on')); return 0; } if (m#^/del(ete)?\s+([zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($2); unless ($code =~ /^d[0-9][0-9]+$/) { # this is a DM. my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } if (lc(&descape($tweet->{'user'}->{'screen_name'})) ne lc($whoami)) { print $stdout "-- not allowed to delete somebody's else's tweets\n"; return 0; } print $stdout &wwrap( "-- verify you want to delete: \"@{[ &descape($tweet->{'text'}) ]}\""); print $stdout "\n"; $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, tweet is NOT deleted.\n"; return 0; } $lastpostid = -1 if ($tweet->{'id_str'} == $lastpostid); &deletest($tweet->{'id_str'}, 1); return 0; } # dxxx falls through to ... } # DM delete version if (m#^/del(ete)? ([dD][a-zA-Z]?[0-9]+)$#) { my $code = lc($2); my $dm = &get_dm($code); if (!defined($dm)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } print $stdout &wwrap( "-- verify you want to delete: " . "(from @{[ &descape($dm->{'sender'}->{'screen_name'}) ]}) ". "\"@{[ &descape($dm->{'text'}) ]}\""); print $stdout "\n"; $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, DM is NOT deleted.\n"; return 0; } &deletedm($dm->{'id_str'}, 1); return 0; } # /deletelast if (m#^/de?l?e?t?e?last$#) { if (!$lastpostid) { print $stdout "-- you haven't posted yet this time!\n"; return 0; } if ($lastpostid == -1) { print $stdout "-- you already deleted it!\n"; return 0; } print $stdout &wwrap( "-- verify you want to delete: \"$lasttwit\""); print $stdout "\n"; $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, tweet is NOT deleted.\n"; return 0; } &deletest($lastpostid, 1); $lastpostid = -1; return 0; } if (s#^/(v)?re(ply)? ([zZ]?[a-zA-Z]?[0-9]+) ## && length) { my $mode = $1; my $code = lc($3); unless ($code =~ /^d[0-9][0-9]+/) { # this is a DM my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } my $target = &descape($tweet->{'user'}->{'screen_name'}); unless (lc($target) eq lc($whoami)) { $_ = '@' . $target . " $_"; } $in_reply_to = $tweet->{'id_str'}; $expected_tweet_ref = $tweet; if ($mode eq 'v') { $_ = ".$_"; } $readline_completion{'@'.lc($target)}++ if ($termrl); print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto TWEETPRINT; # fugly! FUGLY! } else { # this is a DM, reconstruct it $_ = "/${mode}re $code $_"; # and fall through to ... } } # DM reply version if (s#^/(dm)?re(ply)? ([dD][a-zA-Z]?[0-9]+) ## && length) { my $code = lc($3); my $dm = &get_dm($code); if (!defined($dm)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } # in the future, add DM in_reply_to here my $target = &descape($dm->{'sender'}->{'screen_name'}); $readline_completion{'@'.lc($target)}++ if ($termrl); $_ = "/dm $target $_"; print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; # and fall through to /dm } # Share a tweet through DM if (s#^/qdm ([zZ]?[a-zA-Z]?[0-9]+) \@?([^\s]+)\s+##) { my $code = lc($1); my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } $sn = &descape($tweet->{'user'}->{'screen_name'}); $quoted_status_url = "${http_proto}://twitter.com/$sn/statuses/$tweet->{'id_str'}"; return &common_split_post($_ . " " . $quoted_status_url, undef, undef, $2); } if (s#^/e(dm)?re(ply)? ([dD][a-zA-Z]?[0-9]+) ## && length) { my $code = lc($3); my $dm = &get_dm($code); if (!defined($dm)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } # in the future, add DM in_reply_to here my $target = &descape($dm->{'sender'}->{'screen_name'}); $readline_completion{'@'.lc($target)}++ if ($termrl); $_ = "/edm $target $_"; # and fall through to edm } if (s#^/edm \@?([^\s]+)\s+## && length) { # Stolen from Floodgap's texapp my $string = $_; my $target = $1; print $stdout $target; my $fn = "/tmp/oysttyer-".$$.time().".txt"; my $editor = $ENV{'EDITOR'} || "/usr/bin/vi"; my $can_fail = 1; # try to validate, if it's not too complicated if (! -x $editor) { my $binname = $editor; if ($binname !~ /\\/) { ($binname, $crap) = split(/\s+/, $binname, 2) if ($binname =~ /\s/); if (! -x $binname) { print $stdout "-- editor $binname seems invalid; set full path to EDITOR\n"; return 96; } } } if(!open(K, ">$fn")) { print $stdout "-- unable to create $fn: $!\n"; return 96; } print K $string if (length($string)); close(K); while ($can_fail) { # hold the background during editing &ensure_held; system("$editor $fn"); &ensure_not_held; if(!open(K, "$fn")) { print $stdout "-- 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) > $dm_text_character_limit) { print $stdout "-- too long: @{[ length($string) ]} characters, max $dm_text_character_limit\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) || print $stdout "-- warning: couldn't remove $fn: $!\n"; $string =~ s/\s+$//; chomp($string); $string =~ s/\s+$//; if (!length($string)) { print $stdout "-- editor returned nothing, not posting\n"; return 97; } #Handle newlines because otherwise they get flattened $string =~ s/\n/\\n/sg; # and fall through to dm $_ = "/dm $target $string"; } # replyall (based on @FunnelFiasco's extension) if (s#^/(v)?r(eply)?(to)?a(ll)? ([zZ]?[a-zA-Z]?[0-9]+) ## && length) { my $mode = $1; my $code = $5; # common code from /vreply my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } my $target = &descape($tweet->{'user'}->{'screen_name'}); my $text = $_; if (lc($target) eq lc($whoami)) { $_ = ''; } else { $_ = '@' . $target; } $in_reply_to = $tweet->{'id_str'}; $expected_tweet_ref = $tweet; if ($mode eq 'v') { $_ = ".$_"; } # don't repeat the target or myself; track other mentions my %did_mentions = map { $_ => 1 } (lc($target)); my $reply_tweet = &descape($tweet->{'text'}); while($reply_tweet =~ s/\@(\w+)//) { my $name = $1; my $mame = lc($name); # preserve camel case next if ($mame eq $whoami || $did_mentions{$mame}++); if ( $_ eq '.' ) { # Save a character. They're precious. $_ .= "\@$name"; } else { $_ .= " \@$name"; } } $_ .= " $text"; # add everyone in did_mentions to readline_completion grep { $readline_completion{'@'.$_}++ } (keys %did_mentions) if ($termrl); # and fall through to post print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto TWEETPRINT; # fugly! FUGLY! } if (m#^/re(plies)?(\s+\+\d+)?$#) { my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if ($anonymous) { print $stdout "-- sorry, how can anyone reply to you if you're anonymous?\n"; } else { # we are intentionally not keeping track of "last_re" # in this version because it is not automatically # updated and may not act as we expect. print $stdout "-- synchronous /replies command\n" if ($verbose); my $my_json_ref = &grabjson($rurl, 0, 0, $countmaybe, undef, 1); &dt_tdisplay($my_json_ref, "replies"); } return 0; } # DMs if ($_ eq '/dm' || $_ eq '/dmrefresh' || $_ eq '/dmr') { &dmthump; return 0; } # /dmsent, /dmagain if (m#^/dm(s|sent|a|again)(\s+\+\d+)?$#) { my $mode = $1; my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if ($countmaybe > 999) { print $stdout "-- greedy bastard, try +fewer.\n"; return 0; } $countmaybe = sprintf("%03i", $countmaybe); print $stdout "-- background request sent\n" unless ($synch); $mode = ($mode =~ /^s/) ? 's' : 'd'; print C "${mode}mreset${countmaybe}---------\n"; &sync_semaphore; return 0; } if (s#^/dm \@?([^\s]+)\s+## && length) { return &common_split_post($_, undef, undef, $1); } # follow and leave users if (m#^/(follow|leave|unfollow) \@?([^\s/]+)$#) { my $m = $1; my $u = lc($2); &foruuser($u, 1, (($m eq 'follow') ? $followurl : $leaveurl), (($m eq 'follow') ? 'started' : 'stopped')); return 0; } # follow and leave lists. this is, frankly, pointless; it does # nothing other than to mark you. otherwise, /liston and /listoff # actually add lists to your timeline. if (m#^/(l?follow|l?leave|l?unfollow) \@?([^\s/]*)/([^\s/]+)$#) { my $m = $1; my $uname = lc($2); my $lname = lc($3); if (!length($uname) || $uname eq $whoami) { print $stdout &wwrap( "** you can't mark/unmark yourself as a follower of your own lists!\n"); print $stdout &wwrap( "** to add/remove your own lists from your timeline, use /liston /listoff\n"); return 0; } if ($m !~ /^l/) { print $stdout &wwrap( "-- to mark/unmark you as a follower of a list, use /lfollow /lleave\n"); print $stdout &wwrap( "-- to add/remove your own lists from your timeline, use /liston /listoff\n"); return 0; } my $r = &postjson( ($m ne 'lfollow') ? $delfliurl : $crefliurl, "owner_screen_name=$uname&slug=$lname"); if ($r) { my $t = ($m eq 'lfollow') ? "" : "un"; print $stdout &wwrap( "*** ok, you are now ${t}marked as a follower of $uname/${lname}.\n"); my $c = ($t eq 'un') ? "off" : "on"; $t = ($t eq 'un') ? "remove from" : "add to"; print $stdout &wwrap( "--- to also $t your timeline, use /list${c}\n"); } return 0; } # block and unblock users if (m#^/(block|unblock) \@?([^\s/]+)$#) { my $m = $1; my $u = lc($2); if ($m eq 'block') { $answer = lc(&linein( "-- sure you want to block $u? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, $u is NOT blocked.\n"; return 0; } } &boruuser($u, 1, (($m eq 'block') ? $blockurl : $blockdelurl), (($m eq 'block') ? 'started' : 'stopped')); return 0; } # mute and unmute users if (m#^/(mute|unmute) \@?([^\s/]+)$#) { my $m = $1; my $u = lc($2); if ($m eq 'mute') { $answer = lc(&linein( "-- sure you want to mute $u? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, $u is NOT muted.\n"; return 0; } } &muteuser($u, 1, (($m eq 'mute') ? $muteurl : $unmuteurl), (($m eq 'mute') ? 'started' : 'stopped')); return 0; } # list support # /withlist (/withlis, /with, /wl) if (s#^/(withlist|withlis|withl|with|wl)\s+([^/\s]+)\s+## && ($lname=lc($2)) && s/\s*$// && length) { my $comm = ''; my $args = ''; my $dont_return = 0; if ($anonymous) { print $stdout "-- no list love for anonymous\n"; return 0; } if (/\s+/) { ($comm, $args) = split(/\s+/, $_, 2); } else { $comm = $_; } my $return; # this is a Twitter bug -- it will not give you the # new slug in the returned hash. my $state = "modified list $lname (WAIT! then /lists to see new slug)"; if ($comm eq 'create') { my $desc; ($args, $desc) = split(/\s+/, $args, 2) if ($args =~ /\s+/); if ($args ne 'public' && $args ne 'private') { print $stdout "-- must specify public or private\n"; return 0; } $state = "created new list $lname (mode $args)"; $desc = "description=".&url_oauth_sub($desc)."&" if (length($desc)); $return = &postjson($creliurl, "${desc}mode=$args&name=$lname"); } elsif ($comm eq 'private' || $comm eq 'public') { $return = &postjson($modifyliurl, "mode=$comm&owner_screen_name=${whoami}&slug=${lname}"); } elsif ($comm eq 'desc' || $comm eq 'description') { if (!length($args)) { print $stdout "-- $comm needs an argument\n"; return 0; } $return = &postjson($modifyliurl, "description=".&url_oauth_sub($args). "&owner_screen_name=${whoami}&slug=${lname}"); } elsif ($comm eq 'name') { if (!length($args)) { print $stdout "-- $comm needs an argument\n"; return 0; } $return = &postjson($modifyliurl, "name=".&url_oauth_sub($args). "&owner_screen_name=${whoami}&slug=${lname}"); $state = "RENAMED list $lname (WAIT! then /lists to see new slug)"; } elsif ($comm eq 'add' || $comm eq 'adduser' || ($comm eq 'delete' && length($args))) { my $u = ($comm eq 'delete') ? $deluliurl : $adduliurl; $state = ($comm eq 'delete') ? "user(s) deleted from list $lname" : "user(s) added to list $lname"; if ($args !~ /,/ || $args =~ /\s+/) { 1 while ($args =~ s/\s+/,/); } if ($args =~ /\s*,\s+/ || $args =~ /\s+,\s*/) { 1 while ($args =~ s/\s+//); } if (!length($args)) { print $stdout "-- illegal/missing argument\n"; return 0; } print $stdout "--- warning: user list not checked\n"; $return = &postjson($u, "owner_screen_name=${whoami}". "&screen_name=".&url_oauth_sub($args). "&slug=${lname}"); } elsif ($comm eq 'delete' && !length($args)) { $state = "deleted list $lname"; print $stdout "-- verify you want to delete list $lname\n"; my $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, list is NOT deleted.\n"; return 0; } $return = &postjson($delliurl, "owner_screen_name=${whoami}&slug=${lname}"); if ($return) { # check and see if this is in our autolists. # if it is, delete it there too. my $value = &getvariable('lists'); &setvariable('lists', $value, 1) if ($value=~s#(^|,)${whoami}/${lname}($|,)##); } } elsif ($comm eq 'list') { # synonym for /list $_ = "/list /$lname"; $dont_return = 1; # and fall through } else { print $stdout "*** illegal list operation $comm\n"; } if ($return) { print $stdout "*** ok, $state\n"; } return 0 unless ($dont_return); } # /a to show statuses in a list if (m#^/a(gain)?\s+(\+\d+\s+)?\@?([^\s/]*)/([^\s/]+)#) { my $uname = lc($3); if ($anonymous && !length($uname)) { print $stdout "-- you must specify a username when anonymous.\n"; return 0; } my $lname = lc($4); my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $uname ||= $whoami; my $my_json_ref = &grabjson( "${statusliurl}?owner_screen_name=${uname}&slug=${lname}", 0, 0, $countmaybe, undef, 1); &dt_tdisplay($my_json_ref, "again"); return 0; } # /lists command: if @, show their lists. if @?../... show that list. # trivially duplicates /frs and /fos for lists # also handles /listfos and /listfrs if (length($whoami) && (m#^/list?s?$# || m#^/list?f[ro](llower|iend)?s$#)) { $_ .= " $whoami"; } if (m#^/lis(t|ts|t?fos|tfollowers|t?frs|tfriends)?\s+(\+\d+\s+)?(\@?[^\s]+)$#) { my $mode = $1; my $countmaybe = $2; my $uname = lc($3); my $lname = ''; # Handle a case like issue 114 where you want to get a specific number of # your own lists. if ($uname =~ m/^\+/) { $countmaybe = $uname; $uname = $whoami; } $mode = ($mode =~ /^t?fo/) ? 'fo' : ($mode =~ /^t?fr/) ? 'fr' : ''; $uname =~ s/^\@//; ($uname, $lname) = split(m#/#, $uname, 2) if ($uname =~ m#/#); if ($anonymous && !length($uname) && length($mode)) { print $stdout "-- you must specify a username when anonymous.\n"; return 0; } $uname ||= $whoami; if (length($lname) && length($mode)) { print $stdout "-- specify username only\n"; return 0; } $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $countmaybe ||= 20; # this is copied from /friends and /followers (q.v.) my $countper = ($countmaybe < 100) ? $countmaybe : 100; my $cursor = -1; # initial value my $nofetch = 0; my $printed = 0; my $json_ref = undef; my @usarray = undef; shift(@usarray); # force underflow my $furl = (length($lname)) ? ($getliurl."?owner_") : ($mode eq '') ? ($getlisurl."?") : ($mode eq 'fo') ? ($getuliurl."?") : ($getufliurl."?"); $furl .= "screen_name=${uname}"; $furl .= "&slug=${lname}" if (length($lname)); LABIO: while($countmaybe--) { if(!scalar(@usarray)) { last LABIO if ($nofetch); $json_ref = &grabjson( "${furl}&count=${countper}&cursor=${cursor}", 0, 0, 0, undef, 1); @usarray = @{ ((length($lname)) ? $json_ref->{'users'} : $json_ref ) }; last LABIO if (!scalar(@usarray)); if (length($lname)) { $cursor = $json_ref->{'next_cursor_str'} || $json_ref->{'next_cursor'} || -1; $nofetch = ($cursor < 1) ? 1 : 0; } else { $nofetch = 1; } } my $list_ref = shift(@usarray); if (length($lname)) { &$userhandle($list_ref); } else { # lists/list returns their lists AND the # ones they subscribe to, different from 1.0. # right now we just deal with that. #next if ($uname ne # $list_ref->{'user'}->{'screen_name'}); # listhandle? my $list_name = "\@$list_ref->{'user'}->{'screen_name'}/@{[ &descape($list_ref->{'slug'}) ]}"; my $list_full_name = (length($list_ref->{'name'})) ? &descape($list_ref->{'name'})."${OFF} ($list_name)" : $list_name; my $list_mode = (lc(&descape($list_ref->{'mode'})) ne 'public') ? " ${EM}(@{[ ucfirst(&descape($list_ref->{'mode'})) ]})${OFF}" : ""; print $streamout <<"EOF"; ${CCprompt}$list_full_name${OFF} (f:$list_ref->{'member_count'}/$list_ref->{'subscriber_count'})$list_mode EOF my $desc = &strim(&descape($list_ref->{'description'})); my $klen = ($wrap || 79) - 9; $klen = 10 if ($klen < 0); $desc = substr($desc, 0, $klen)."..." if (length($desc) > $klen); print $streamout (' "' . $desc . '"' . "\n") if (length($desc)); } $printed++; } if (!$printed) { print $stdout ((length($lname)) ? "-- list $uname/$lname does not follow anyone.\n" : ($mode eq 'fr') ? "-- user $uname doesn't follow any lists.\n" : ($mode eq 'fo') ? "-- user $uname isn't followed by any lists.\n" : "-- no lists found for user $uname.\n"); } return 0; } &sync_n_quit if ($_ eq '/end' || $_ eq '/e'); ##### # # below this point, we are posting # ##### if (m#^/me\s#) { $slash_first = 0; # kludge! } if ($slash_first) { if (!m#^//#) { print $stdout "*** invalid command\n"; print $stdout "*** to pass as a tweet, type /%%\n"; return 0; } s#^/##; # leave the second slash on } TWEETPRINT: # fugly! FUGLY! return &common_split_post($_, $quoted_status_url, $in_reply_to, undef); } # this is the common code used by standard updates and by the /dm command. sub common_split_post { my $k = shift; my $quoted_status_url = shift; my $in_reply_to = shift; my $dm_user = shift; my $dm_lead = (length($dm_user)) ? "/dm $dm_user " : ''; my $ol = "$dm_lead$k"; my $maxchars = $linelength; if ($quoted_status_url) { $maxchars = $quotelinelength; } # Direct messages allegedly have no length restrictions now if ( $dm_lead ne '' || $k =~ m/^[dD] / ) { $maxchars = $dm_text_character_limit; } my (@tweetstack) = &csplit($k, $autosplit, $maxchars); my $m = shift(@tweetstack); if (scalar(@tweetstack)) { $l = "$dm_lead$m"; $history[0] = $l; if (!$autosplit) { print $stdout &wwrap( "*** sorry, too long to send; ". "truncated to \"$l\" (@{[ length_newline($m) ]} chars)\n"); print $stdout "*** use %% for truncated version, or append to %%.\n"; return 0; } print $stdout &wwrap( "*** over $maxchars; autosplitting to \"$l\"\n"); } # If a quoted status need to append that on after the length checking. if ($quoted_status_url) { $m = $m . " " . $quoted_status_url } # there was an error; stop autosplit, restore original command if (&updatest($m, 1, $in_reply_to, $dm_user)) { $history[0] = $ol; return 0; } # TODO: Perhaps also need to think about quoted tweets in the below. if (scalar(@tweetstack)) { $k = shift(@tweetstack); $l = "$dm_lead$k"; &add_history($l); print $stdout &wwrap("*** next part is ready: \"$l\"\n"); print $stdout "*** (this will also be automatically split)\n" if (length_newline($k) > $linelength); print $stdout "*** to send this next portion, use %%.\n"; } return 1; } # helper functions for the command line processor. sub add_history { my $h = shift; @history = (($h, @history)[0..&min(scalar(@history), $maxhist)]); if ($termrl) { if ($termrl->Features()->{'canSetTopHistory'}) { $termrl->settophistory($h); } else { $termrl->addhistory($h); } } } sub sub_helper { my $r = shift; my $s = shift; my $g = shift; my $x; my $q = 0; my $proband; if ($r eq '%') { $x = -1; } else { $x = $r + 0; } if (!$x || $x < -(scalar(@history))) { print $stdout "*** illegal history index\n"; return (0, $_, undef, undef, undef); } $proband = $history[-($x + 1)]; if ($s eq '--') { $q = 1; } elsif ($s eq '*') { if ($x != -1 || !length($shadow_history)) { print $stdout "*** can only %%* on most recent command\n"; return (0, $_, undef, undef, undef); } # we assume it's at the end; it's only relevant there $proband = substr($shadow_history, length($g)-(2+length($r))); } else { $q = -(0+$s); } if ($q) { my $j; my $c; for($j=0; $j<$q; $j++) { $c++ if ($proband =~ s/\s+[^\s]+$//); } if ($j != $c) { print $stdout "*** illegal word index\n"; return (0, $_, undef, undef, undef); } } return (1, $proband, $r, $s); } # this is used for synchronicity mode to make sure we receive the # GA semaphore from the background before printing another prompt. sub sync_console { &thump; &dmthump unless (!$dmpause); } sub sync_semaphore { if ($synch) { my $k = ''; while(!length($k)) { sysread(W, $k, 1); } # wait for semaphore } } # wrapper function to get a line from the terminal. sub linein { my $prompt = shift; my $return; return 'y' if ($script); $prompt .= " "; if ($termrl) { $dont_use_counter = 1; eval '$termrl->hook_no_counter'; $return = $termrl->readline($prompt); $dont_use_counter = $nocounter; eval '$termrl->hook_no_counter'; } else { print $stdout $prompt; chomp($return = lc(<$stdin>)); } return $return; } #### this is the background part of the process #### MONITOR: %store_hash = (); $is_background = 1; $first_synch = $synchronous_mode = 0; $rin = ''; vec($rin,fileno(STDIN),1) = 1; # paranoia binmode($stdout, ":crlf") if ($termrl); unless ($seven) { binmode(STDIN); binmode($stdout, ":utf8"); } # allow foreground process to squelch us # we have to cover all the various versions of 30/31 signals on various # systems just in case we are on a system without POSIX.pm. this set should # cover Linux 2.x/3.x, AIX, Mac OS X, *BSD and Solaris. we have to assert # these signals before starting streaming, or we may "kill" ourselves by # accident because it is possible to process a tweet before these are # operational. &sigify(sub { $suspend_output ^= 1 if ($suspend_output != -1); $we_got_signal = 1; }, qw(USR1 PWR XCPU)); &sigify( sub { $suspend_output = -1; $we_got_signal = 1; }, qw(USR2 SYS UNUSED XFSZ)); &sigify("IGNORE", qw(INT)); # don't let slowpost kill us # now we can safely initialize streaming if ($dostream) { @events = (); $lasteventtime = time(); &sigify(sub { print $stdout "-- killing processes $nursepid $bufferpid\n" if ($verbose); kill $SIGHUP, $nursepid if ($nursepid); kill $SIGHUP, $bufferpid if ($bufferpid); kill 9, $curlpid if ($curlpid); sleep 1; # send myself a shutdown kill 9, $nursepid if ($nursepid); kill 9, $bufferpid if ($bufferpid); kill $SIGTERM, $$; }, qw(HUP)); # use SIGHUP etc. from parent process to signal end $bufferpid = &start_streaming; vec($rin, fileno(STBUF), 1) = 1; } else { &sigify("IGNORE", qw(HUP)); # we only respond to SIGKILL/SIGTERM } $interactive = $previous_last_id = $we_got_signal = 0; $hold = 0; $suspend_output = -1; $stream_failure = 0; $dm_first_time = ($dmpause) ? 1 : 0; $stuck_stdin = 0; # tell the foreground we are ready kill $SIGUSR2, $parent; # loop until we are killed or told to stop. # we receive instructions on stdin, and send data back on our pipe(). for(;;) { &$heartbeat; &update_effpause; $wrapseq = 0; # remember, we don't know when commands are sent. &refresh($interactive, $previous_last_id) unless (!$effpause && !$interactive); $dont_refresh_first_time = 0; $previous_last_id = $last_id; if ($dmpause && ($effpause || $synch)) { if ($dm_first_time) { &dmrefresh(0); $dmcount = $dmpause; } elsif (!$interactive) { if (!--$dmcount) { &dmrefresh($interactive); # using dm_first_time $dmcount = $dmpause; } } } DONT_REFRESH: # nrvs is tricky with synchronicity if (!$synch || ($synch && $synchronous_mode && !$dm_first_time)) { $k = length($notify_rate) + length($vs) + length($credlog); if ($k) { &send_removereadline if ($termrl); print $stdout $notify_rate; print $stdout $vs; print $stdout $credlog; $wrapseq = 1; } $notify_rate = ""; $vs = ""; $credlog = ""; } print P "0" if ($synchronous_mode && $interactive); &send_repaint if ($termrl); # this core loop is tricky. most signals will not restart the call. # -- respond to alarms if we are ignoring our timeout. # -- do not respond to bogus packets if a signal handler triggered it. # -- clear our flag when we detect a signal handler has been called. # if our master select is interrupted, we must restart with the # appropriate time taken from effpause. however, most implementations # don't report timeleft, so we must. $restarttime = time() + $effpause; RESTART_SELECT: &send_repaint if ($termrl); $interactive = 0; $we_got_signal = 0; # acknowledge all signals if ($effpause == undef) { # -script and anonymous have no effpause. print $stdout "-- select() loops forever\n" if ($verbose); $nfound = select($rout = $rin, undef, undef, undef); } else { $actualtime = $restarttime - time(); print $stdout "-- select pending ($actualtime sec left)\n" if ($superverbose); if ($actualtime <= 0) { $nfound = 0; } else { $nfound = select( $rout = $rin, undef, undef, $actualtime); } } if ($nfound > 0) { my $len; # service the streaming socket first, if we have one. if ($dostream) { if (vec($rout, fileno(STBUF), 1) == 1) { my $json_ref; my $buf = ''; my $rbuf; my $reads = 0; print $stdout "-- data on streaming socket\n" if ($superverbose); # read until we get eight hex digits. this forces the # data stream to synchronize. # first, however, make sure we actually have valid # data, or we sit here and slow down the user. read(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 oysttyer. 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. read(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) { read(STBUF, $rbuf, ($len-length($buf))); $buf .= $rbuf; } print $stdout "-- streaming data ($len) --\n$buf\n-- streaming data --\n\n" if ($superverbose); $json_ref = &parsejson($buf); push(@events, $json_ref); if (scalar(@events) > $eventbuf || (scalar(@events) && (time()-$lasteventtime) > $effpause)){ sleep 5 while ($suspend_output > 0); &streamevents(@events); &send_repaint if ($termrl); @events = (); $lasteventtime = time(); } } DONESTREAM: print $stdout "-- done with streaming events\n" if ($superverbose); } # then, check if there is data on our control socket. # command packets should always be (initially) 20 characters. # if we come up short, it's either a bug, signal or timeout. if ($we_got_signal) { goto RESTART_SELECT; } goto RESTART_SELECT if(vec($rout, fileno(STDIN), 1) != 1); print $stdout "-- waiting for data ", scalar localtime, "\n" if ($superverbose); if(sysread(STDIN, $rout, 20) != 20) { # if we get repeated "ready" but no data on STDIN, # like the streaming buffer, we probably lost our # IPC and we should die here. if (++$stuck_stdin > 100) { print $stdout "parent is dead; we die too\n"; kill 9,$$; } goto RESTART_SELECT; } $stuck_stdin = 0; # background communications central command code # we received a command from the console, so let's look at it. print $stdout "-- command received ", scalar localtime, " $rout" if ($verbose); if ($rout =~ /^hold/) { $holdhold ^= 1; # toggle hold flag goto RESTART_SELECT; } elsif ($rout =~ /^rsga/) { $suspend_output = 0; # reset our status goto RESTART_SELECT; } elsif ($rout =~ /^pipet (..)/) { my $key = &get_tweet($1); my $ms = $key->{'menu_select'} || 'XX'; my $ds = $key->{'created_at'} || 'argh, no created_at'; $ds =~ s/\s/_/g; my $src = $key->{'source'} || 'unknown'; # Figured out this is where the stream gets processed and oysttyer picks out the fields that get stored # So quoted_status_id_str needed adding in here. $src =~ s/\|//g; # shouldn't be any anyway. $key = substr(( join "\0", $ms, $key->{'id_str'}, $key->{'in_reply_to_status_id_str'}, $key->{'quoted_status_id_str'}, $key->{'quoted_status'}->{'text'}, $key->{'quoted_status'}->{'full_text'}, $key->{'quoted_status'}->{'extended_tweet'}->{'full_text'}, $key->{'retweeted_status'}->{'id_str'}, $key->{'retweeted_status'}->{'text'}, $key->{'retweeted_status'}->{'full_text'}, $key->{'retweeted_status'}->{'extended_tweet'}->{'full_text'}, $key->{'retweeted_status'}->{'quoted_status'}->{'id_str'}, $key->{'retweeted_status'}->{'quoted_status'}->{'text'}, $key->{'retweeted_status'}->{'quoted_status'}->{'full_text'}, $key->{'retweeted_status'}->{'quoted_status'}->{'extended_tweet'}->{'full_text'}, $key->{'user'}->{'geo_enabled'} || "false", $key->{'geo'}->{'coordinates'}->[0], $key->{'geo'}->{'coordinates'}->[1], $key->{'place'}->{'id'}, $key->{'place'}->{'country_code'}, $key->{'place'}->{'place_type'}, unpack("${pack_magic}H*", $key->{'place'}->{'full_name'}), $key->{'tag'}->{'type'}, unpack("${pack_magic}H*", $key->{'tag'}->{'payload'}), $key->{'retweet_count'} || "0", $key->{'user'}->{'screen_name'}, $ds, $src, unpack("${pack_magic}H*", $key->{'text'}). $space_pad), 0, $packet_length); print P $key; goto RESTART_SELECT; } elsif ($rout =~ /^piped (..)/) { my $key = $dm_store_hash{$1}; my $ms = $key->{'menu_select'} || 'XX'; my $ds = $key->{'created_at'} || 'argh, no created_at'; $ds =~ s/\s/_/g; $key = substr(( "$ms ".($key->{'id_str'})." ". $key->{'sender'}->{'screen_name'}." $ds ". unpack("${pack_magic}H*", $key->{'text'}). $space_pad), 0, $packet_length); print P $key; goto RESTART_SELECT; } elsif ($rout =~ /^ki ([^\s]+) /) { my $key = $1; my $module; read(STDIN, $module, $packet_length); $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, $packet_length); goto RESTART_SELECT; } elsif ($rout =~ /^kn ([^\s]+) /) { my $key = $1; my $module; read(STDIN, $module, $packet_length); $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; read(STDIN, $module, $packet_length); $module =~ s/\s+$//; $module = pack("H*", $module); read(STDIN, $value, $packet_length); $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, $packet_length); } else { read(STDIN, $value, $packet_length); $value =~ s/\s+$//; $interactive = ($comm eq '+') ? 0 : 1; if ($key eq 'tquery') { print $stdout "*** custom query installed\n" if ($interactive || $verbose); print $stdout "$value" if ($verbose); @trackstrings = (); # already URL encoded push(@trackstrings, $value); } else { $$key = $value; print $stdout "*** changed: $key => $$key\n" if ($interactive || $verbose); &generate_ansi if ($key eq 'ansi' || $key =~ /^colour/); $rate_limit_next = 0 if ($key eq 'pause' && $value eq 'auto'); &tracktags_makearray if ($key eq 'track'); &filter_compile if ($key eq 'filter'); ¬ify_compile if ($key eq 'notifies'); &list_compile if ($key eq 'lists'); &filterflags_compile if ($key eq 'filterflags'); $filterrts_sub = &filteruserlist_compile( $filterrts_sub, $value) if ($key eq 'filterrts'); $filterusers_sub = &filteruserlist_compile( $filterusers_sub,$value) if ($key eq 'filterusers'); $filteratonly_sub = &filteruserlist_compile( $filteratonly_sub, $value) if ($key eq 'filteratonly'); &filterats_compile if ($key eq 'filterats'); } } goto RESTART_SELECT; } else { $interactive = 1; ($fetchwanted = 0+$1, $fetch_id = 0, $last_id = 0) if ($rout =~ /^reset(\d+)/); ($dmfetchwanted = 0+$1, $last_dm = 0) if ($rout =~ /^dmreset(\d+)/); if ($rout =~ /^smreset/) { # /dmsent $dmfetchwanted = 0+$1 if ($rout =~ /(\d+)/); &dmrefresh(1, 1); &send_repaint if ($termrl); # we do not want to force a refresh. goto DONT_REFRESH; } if ($rout =~ /^dm/) { &dmrefresh($interactive); &send_repaint if ($termrl); $dmcount = $dmpause; goto DONT_REFRESH; } } } else { if ($we_got_signal || $nfound == -1 || $holdhold) { # we need to restart the call. we might be waiting # longer, but this is unavoidable. goto RESTART_SELECT; } print $stdout "-- routine refresh (effpause = $effpause, $dmcount to next dm) ", scalar localtime, "\n" if ($verbose); } } #### internal implementation functions for the twitter API. DON'T ALTER #### # manage automatic rate limiting by checking our max. #TODO # autoslowdown as we run out of requests, then speed up when hour # has passed. sub update_effpause { return ($effpause = undef) if ($script); # for select() if ($pause ne 'auto' && $noratelimit) { $effpause = (0+$pause) || undef; return; } $effpause = (0+$pause) || undef if ($anonymous || (!$pause && $pause ne 'auto')); if (!$rate_limit_next && !$anonymous && ($pause > 0 || $pause eq 'auto')) { # Twitter 1.0 used a simple remaining_hits and # hourly_limit. 1.1 uses multiple rate endpoints. we # are only interested in certain specific ones, though # we currently fetch them all and we might use more later. $rate_limit_next = 5; $rate_limit_ref = &grabjson($rlurl, 0, 0, 0, undef, 1); if (defined $rate_limit_ref && ref($rate_limit_ref) eq 'HASH') { # of mentions_timeline, home_timeline and search/tweets, # choose the MOST restrictive and normalize that. $rate_limit_left = &min( 0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/home_timeline'}->{'remaining'}, &min( 0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/mentions_timeline'}->{'remaining'}, 0+$rate_limit_ref->{'resources'}->{'search'}->{'\\/search\\/tweets'}->{'remaining'})); $rate_limit_rate = &min( 0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/home_timeline'}->{'limit'}, &min( 0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/mentions_timeline'}->{'limit'}, 0+$rate_limit_ref->{'resources'}->{'search'}->{'\\/search\\/tweets'}->{'limit'})); if ($rate_limit_left < 3 && $rate_limit_rate) { $estring = "*** warning: API rate limit imminent"; if ($pause eq 'auto') { $estring .= "; temporarily halting autofetch"; $effpause = 0; } &$exception(5, "$estring\n"); } else { if ($pause eq 'auto') { # the new rate limits do not require us to reduce our fetching for mentions, # direct messages or search, because they pull from different buckets, and # their rate limits are roughly the same. $effpause = 5*$rate_limit_rate; # this will usually be 75s # for lists, however, we have to drain the list bucket faster, so for every # list AFTER THE FIRST ONE we subscribe to, add rate_limit_rate to slow. # for search, it has 180 requests, so we don't care so much. if this # changes later, we will probably need something similar to this for # cases where the search array is > 1. $effpause += ((scalar(@listlist)-1)* $rate_limit_rate) if (scalar(@listlist) > 1); if (!$effpause) { print $stdout "-- rate limit rate failure: using 180 second fallback\n"; $effpause = 180; } # we don't go under sixty. $effpause = 60 if ($effpause < 60); } else { $effpause = 0+$pause; } } print $stdout "-- rate limit check: $rate_limit_left/$rate_limit_rate (rate is $effpause sec)\n" if ($verbose); $adverb = (!$last_rate_limit) ? ' currently' : ($last_rate_limit < $rate_limit_rate) ? ' INCREASED to': ($last_rate_limit > $rate_limit_rate) ? ' REDUCED to': ''; $notify_rate = "-- notification: API rate limit is${adverb} ${rate_limit_rate} req/15min\n" if ($last_rate_limit != $rate_limit_rate); $last_rate_limit = $rate_limit_rate; } else { $rate_limit_next = 0; $effpause = ($pause eq 'auto') ? 180 : 0+$pause; print $stdout "-- failed to fetch rate limit (rate is $effpause sec)\n" if ($verbose); } } else { $rate_limit_next-- unless ($anonymous); } } # streaming API support routines ### INITIALIZE STREAMING ### spin off a nurse process to proxy data from curl, and a buffer process ### to protect the background process from signals curl may generate. sub start_streaming { $bufferpid = 0; unless ($streamtest) { if($bufferpid = open(STBUF, "-|")) { # streaming processes initialized return $bufferpid; } } # now within buffer process # verbosity does not work here, so force both off. $verbose = 0; $superverbose = 0; $0 = "oysttyer (streaming buffer thread)"; $in_buffer = 1; # set up signal handlers $streampid = 0; &sigify(sub { # in an earlier version we wrote a disconnect packet to the # pipe in this handler. THIS IS NOT SAFE on certain OS/Perl # combinations. I moved this down to the HELLOAGAINNURSE loop, # or otherwise you get random seg faults. $i = $streampid; $streampid = 0; waitpid $i, 0 if ($i); }, qw(CHLD PIPE)); &sigify(sub { $i = $streampid; $streampid = 0; # suppress handler above kill ($SIGHUP, $i) if ($i); waitpid $i, 0 if ($i); kill 9, $curlpid if ($curlpid && !$i); kill 9, $$; }, qw(HUP TERM)); &sigify("IGNORE", qw(INT)); $packets_read = 0; # part of exponential backoff $wait_time = 0; # open the nurse process HELLOAGAINNURSE: $w = "{\"packet\" : \"connect\", \"payload\" : {} }"; select(STDOUT); $|++; printf STDOUT ("%08x%s", length($w), $w); close(NURSE); if (!$packets_read) { $wait_time += (($wait_time) ? $wait_time : 1) } else { $wait_time = 0; } $packets_read = 0; $wait_time = ($wait_time > 60) ? 60 : $wait_time; if ($streampid = open(NURSE, "-|")) { # within the buffer process select(NURSE); $|++; select(STDOUT); my $rin = ''; vec($rin,fileno(NURSE),1) = 1; my $datasize = 0; my $buf = ''; my $cuf = ''; my $duf = ''; # read the curlpid from the stream read(NURSE, $curlpax, 8); $curlpid = hex($curlpax); # if we are testing the socket, just emit data. if ($streamtest) { my $c; for(;;) { read(NURSE, $c, 1); print STDOUT $c; } } HELLONURSE: while(1) { # restart nurse process if it/curl died goto HELLOAGAINNURSE if(!$streampid); # read a line of text (hopefully numbers) chomp($buf = ); # 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 = "oysttyer (waiting $wait_time sec to connect to stream)"; sleep $wait_time; $curlpid = 0; $replarg = ($streamallreplies) ? '&replies=all' : ''; &sigify(sub { kill 9, $curlpid if ($curlpid); waitpid $curlpid, 0 unless (!$curlpid); $curlpid = 0; kill 9, $$; }, qw(CHLD PIPE)); &sigify(sub { kill 9, $curlpid if ($curlpid); }, qw(INT HUP TERM)); # which will cascade into SIGCHLD ($comm, $args, $data) = &$stringify_args($baseagent, [ $streamurl, "delimited=length${replarg}" ], undef, undef, '-s', '-A', "oysttyer_Streaming/$oysttyer_VERSION", '-N', '-H', 'Expect:'); ($curlpid = open(K, "|$comm")) || die("failed curl: $!\n"); printf STDOUT ("%08x", $curlpid); # "DIE QUICKLY" $0 = "oysttyer (streaming socket nurse thread to ${curlpid})"; select(K); $|++; select(STDOUT); $|++; print K "$args\n"; close(K); waitpid $curlpid, 0; $curlpid = 0; kill 9, $$; } } # handle a set of events acquired from the streaming socket. # ordinarily only the background is calling this. sub streamevents { my (@events) = (@_); my $w; my @x; my %k; # need temporary dedupe foreach $w (@events) { my $tmp; # don't send non-data events (yet). next if ($w->{'packet'} ne 'data'); # try to get PID information if available for faster shutdown $nnursepid = 0+($w->{'pid'}); if ($nnursepid != $nursepid) { $nursepid = $nnursepid; print $stdout "-- got new pid of streaming nurse socket process: $nursepid\n" if ($verbose); } $ncurlpid = 0+($w->{'curlpid'}); if ($ncurlpid != $curlpid) { $curlpid = $ncurlpid; print $stdout "-- got new pid of streaming curl process: $ncurlpid\n" if ($verbose); } # we don't use this (yet). next if ($w->{'payload'}->{'friends'}); sleep 5 while ($suspend_output > 0); # dispatch tweets if ($w->{'payload'}->{'text'} && !$notimeline) { # normalize the tweet first. my $payload = &normalizejson($w->{'payload'}); my $sid = $payload->{'id_str'}; $payload->{'tag'}->{'type'} = 'timeline'; $payload->{'tag'}->{'payload'} = 'stream'; # filter replies from streaming socket if the # user requested it. use $tweettype to determine # this so the user can interpose custom logic. if ($nostreamreplies) { my $sn = &descape( $payload->{'user'}->{'screen_name'}); my $text = &descape($payload->{'text'}); next if (&$tweettype($payload, $sn, $text) eq 'reply'); } # finally, filter everything else and dedupe. unless (length($id_cache{$sid}) || $filter_next{$sid} || $k{$sid}) { &tdisplay([ $payload ]); $k{$sid}++; } # roll *_id so that we don't do unnecessary work # testing the API. don't roll fetch_id, search uses # it. don't roll if last_id was zero, because that # means we are streaming *before* the API backfetch. $last_id = $sid unless (!$last_id); } # dispatch DMs elsif (($tmp = $w->{'payload'}->{'direct_message'}) && $dmpause) { &dmrefresh(0, 0, [ $tmp ]); # don't roll last_dm yet. } # must be an event. see if standardevent can make sense of it. elsif (!$notimeline) { $w = $w->{'payload'}; my $sou_sn = &descape($w->{'source'}->{'screen_name'}); if (!length($sou_sn) || !$filterusers_sub || !&$filterusers_sub($sou_sn)) { &send_removereadline if ($termrl); &$eventhandle($w); $wrapseq = 1; &send_repaint if ($termrl); } } } } # REST API support # # thump for timeline # THIS MUST ONLY BE RUN BY THE BACKGROUND. sub refresh { my $interactive = shift; my $relative_last_id = shift; my $k; my $my_json_ref = undef; my $i; my @streams = (); my $dont_roll_back_too_far = 0; # this mixes all the tweet streams (timeline, hashtags, replies # and lists) into a single unified data river. # backload can be zero, but this will still work since &grabjson # sees a count of zero as "default." # first, get my own timeline # note that anonymous has no timeline (but they can sample the # stream) unless ($notimeline || $anonymous) { # in streaming mode, use $last_id # in API mode, use $fetch_id my $base_json_ref = &grabjson($url, ($dostream) ? $last_id : $fetch_id, 0, (($last_id) ? 250 : $fetchwanted || $backload), { "type" => "timeline", "payload" => "api" }, 1); # if I can't get my own timeline, ABORT! highest priority! return if (!defined($base_json_ref) || ref($base_json_ref) ne 'ARRAY'); # we have to filter against the ID cache right now, because # we might not have any other streams! if ($fetch_id && $last_id) { $my_json_ref = []; my $l; my %k; # need temporary dedupe foreach $l (@{ $base_json_ref }) { unless (length($id_cache{$l->{'id_str'}}) || $filter_next{$l->{'id_str'}} || $k{$l->{'id_str'}}) { push(@{ $my_json_ref }, $l); $k{$l->{'id_str'}}++; } } } else { $my_json_ref = $base_json_ref; } } # add stream for replies, if requested if ($mentions) { # same thing my $r = &grabjson($rurl, ($dostream && !$nostreamreplies) ? $last_id : $fetch_id, 0, (($last_id) ? 250 : $fetchwanted || $backload), { "type" => "reply", "payload" => "" }, 1); push(@streams, $r) if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })); } # next handle hashtags and tracktags # failure here does not abort, because search may be down independently # of the main timeline. if (!$notrack && scalar(@trackstrings)) { my $r; my $k; my $l; if (!$last_id) { $l = &min($backload, $searchhits); } else { $l = (($fetchwanted) ? $fetchwanted : &max(100, $searchhits)); } # temporarily squelch server complaints (see below) $muffle_server_messages = 1 unless ($verbose); foreach $k (@trackstrings) { # use fetch_id here in both modes. $r = &grabjson("$queryurl?${k}&result_type=recent", $fetch_id, 0, $l, { "type" => "search", "payload" => $k }, 1); # depending on the state of the search API, we might be using # a bogus search ID that is too far back. so if this fails, # try again with last_id, but not if we're streaming (it # will always fetch zero). if (!defined($r) || ref($r) ne 'ARRAY' || !$dostream) { print $stdout "-- search retry $k attempted with last_id\n" if ($verbose); $r = &grabjson("$queryurl?${k}&result_type=recent", $last_id, 0, $l, { "type" => "search", "payload" => $k }, 1); $dont_roll_back_too_far = 1; } # or maybe not even then? if (!defined($r) || ref($r) ne 'ARRAY') { print $stdout "-- search retry $k attempted with zero!\n" if ($verbose); $r = &grabjson("$queryurl?${k}&result_type=recent", 0, 0, $l, { "type" => "search", "payload" => $k }, 1); $dont_roll_back_too_far = 1; } push(@streams, $r) if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })); } $muffle_server_messages = 0; } # add stream for lists we have on with /set lists, and tag it with # the list. if (scalar(@listlist)) { foreach $k (@listlist) { # always use fetch_id my $r = &grabjson( "${statusliurl}?owner_screen_name=".$k->[0].'&slug='.$k->[1], $fetch_id, 0, (($last_id) ? 250 : $fetchwanted), { "type" => "list", "payload" => ($k->[0] ne $whoami) ? "$k->[0]/$k->[1]" : "$k->[1]" }, 1); push(@streams, $r) if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })); } } $fetchwanted = 0; # done with that. # now, streamix all the streams into my_json_ref, discarding duplicates # a simple hash lookup is no good; it has to be iterative. because of # that, we might as well just splice it in here and save a sort later. # the streammix logic is unnecessarily complex, probably. # remember, the most recent tweets are FIRST. if (scalar(@streams)) { my $j; my $k; my $l = scalar(@{ $my_json_ref }); my $m; my $n; foreach $n (@streams) { SMIX0: foreach $j (@{ $n }) { my $id = $j->{'id_str'}; # for ease of use # possible to happen if search tryhard is on next SMIX0 if ($id < $fetch_id); # filter this lot against the id cache # and any tweets we just filtered. next SMIX0 if (length($id_cache{$id}) && $fetch_id); next SMIX0 if ($filter_next{$id} && $fetch_id); if (!$l) { # degenerate case push (@{ $my_json_ref }, $j); $l++; next SMIX0; } # find the same ID, or one just before, # and splice in $m = -1; SMIX1: for($i=0; $i<$l; $i++) { next SMIX0 # it's a duplicate if($my_json_ref->[$i]->{'id_str'} == $id); if($my_json_ref->[$i]->{'id_str'} < $id) { $m = $i; last SMIX1; # got it } } if ($m == -1) { # didn't find push (@{ $my_json_ref }, $j); } elsif ($m == 0) { # degenerate case unshift (@{ $my_json_ref }, $j); } else { # did find, so splice splice(@{ $my_json_ref }, $m, 0, $j); } $l++; } } } %filter_next = (); # fetch_id gyration. initially start with last_id, then roll. we # want to keep a window, though, so we try to pick a sensible value # that doesn't fetch too much but includes some overlap. we can't # do computations on the ID itself, because it's "opaque." $fetch_id = 0 if ($last_id == 0); &send_removereadline if ($termrl); if ($dont_refresh_first_time) { $last_id = &max($my_json_ref->[0]->{'id_str'}, $last_id); } else { ($last_id, $crap) = &tdisplay($my_json_ref, undef, $relative_last_id); } my $new_fi = (scalar(@{ $my_json_ref })) ? $my_json_ref->[(scalar(@{ $my_json_ref })-1)]->{'id_str'} : ''; # try to widen the window to a "reasonable amount" $fetch_id = ($fetch_id == 0) ? $last_id : (length($new_fi) && $new_fi ne $last_id && $new_fi > $fetch_id) ? $new_fi : ($relative_last_id > 0 && $relative_last_id ne $last_id && $relative_last_id > $fetch_id) ? $relative_last_id : $fetch_id; print $stdout "-- last_id $last_id, fetch_id $fetch_id, rollback $relative_last_id\n". "-- (@{[ scalar(keys %id_cache) ]} cached)\n" if ($verbose); &send_removereadline if ($termrl); &$conclude; $wrapseq = 1; &send_repaint if ($termrl); } # convenience function for filters (see below) sub killtw { my $j = shift; $filtered++; $filter_next{$j->{'id_str'}}++ if ($is_background); } # handle (i.e., display) an array of tweets in standard format sub tdisplay { # used by both synchronous /again and asynchronous refreshes my $my_json_ref = shift; my $class = shift; my $relative_last_id = shift; my $mini_id = shift; my $printed = 0; my $disp_max; my $save_counter = -1; my $i; my $j; my $return_j; my $t; my %ids; my $injected_json_ref = []; # This is a little messy, but I can't think of a better way until I properly understand return values from tdisplay # Set return values based on original json structure # Note: Where does $last_id come from? $return_j = $my_json_ref->[0]; $return_max = &max($my_json_ref->[0]->{'id_str'}, $last_id); # Build hash of IDs passed to this subroutine foreach $t (@{ $my_json_ref }) { $ids{ $t->{'id_str'} } = 1; } # Inject quote tweets, but only if not already at parent level in $my_json_ref # This prevents /thread from displaying them twice # Twitter website only displays one level of quotation so no looping through, use /thread for more foreach $t (@{ $my_json_ref }) { $parent_t = $t; if ((length($t->{'quoted_status_id_str'})) || (length($t->{'retweeted_status'}->{'id_str'}))) { # If it is a retweet, get the original status and check that for quoted_status if (length($t->{'retweeted_status'}->{'id_str'})) { $t = $t->{'retweeted_status'}; }; $t = $t->{'quoted_status'}; # Using smartmatch would be easier, but we are kind on older versions of Perl if (($t) && !exists($ids{$t->{'id_str'}})) { # Add reference to allow badging in standardtweet $t->{'oysttyer_quoted'} = 'true'; push(@{ $injected_json_ref }, $t); } } # Push the parent after the quote to get ordering correct # Don't remove the url from the parent tweet though: https://twittercommunity.com/t/api-returns-url-to-twitters-status-update-at-the-end-of-the-text/50424/8 push(@{ $injected_json_ref }, $parent_t); } $my_json_ref = $injected_json_ref; # Set display max to suit injected json $disp_max = &min($print_max, scalar(@{ $my_json_ref })); if ($disp_max) { # null list may be valid if we get code 304 unless ($is_background) { # reset store hash each console if ($mini_id) { # TODO: # generalize this at some point instead of hardcoded menu codes # maybe an ma0-mz9? $save_counter = $tweet_counter; $tweet_counter = $mini_split; for(0..9) { undef $store_hash{"zz$_"}; } }# else { # $tweet_counter = $back_split; # %store_hash = (); #} } for($i = $disp_max; $i > 0; $i--) { my $g = ($i-1); $j = $my_json_ref->[$g]; my $id = $j->{'id_str'}; my $sn = $j->{'user'}->{'screen_name'}; next if (!length($sn)); $sn = lc(&descape($sn)); # # implement filter stages: # do so in such a way that we can toss tweets out # quickly, because multiple layers eat CPU! # # zeroth: if this is us, do not filter. if (($anonymous || $sn ne $whoami) && !($nofilter)) { # first, filterusers. this is very fast. # do for the tweet (&killtw($j), next) if ($filterusers_sub && &$filterusers_sub($sn)); # and if the tweet has a retweeted status, do for # that. (&killtw($j), next) if ($j->{'retweeted_status'} && $filterusers_sub && &$filterusers_sub(lc(&descape($j-> {'retweeted_status'}-> {'user'}->{'screen_name'})))); # second, filterrts. this is almost as fast. (&killtw($j), next) if ($filterrts_sub && (length($j->{'retweeted_status'}->{'id_str'}) || length($j->{'quoted_status_id_str'}))&& &$filterrts_sub($sn)); # third, filteratonly. this has a fast case and a # slow case. my $tex = &descape($j->{'text'}); (&killtw($j), next) if ($filteratonly_sub && &$filteratonly_sub($sn) && # fast test $tex !~ /\@$whoami\b/i); # slow test # fourth, filterats. this is somewhat expensive. (&killtw($j), next) if ($filterats_c && &$filterats_c($tex)); # finally, classic -filter. this is the most expensive. (&killtw($j), next) if ($filter_c && &$filter_c($tex)); } # damn it, user may actually want this tweet. # assign menu codes and place into caches $key = (($is_background) ? '' : 'z' ). substr($alphabet, $tweet_counter/10, 1) . $tweet_counter % 10; $tweet_counter = ($tweet_counter == 259) ? $mini_split : ($tweet_counter == ($mini_split - 1)) ? 0 : ($tweet_counter+1); $j->{'menu_select'} = $key; $key = lc($key); # recover ID cache memory: find the old ID with this # menu code and remove it, then add the new one # except if this is the foreground. we don't use this # in the foreground. if ($is_background) { delete $id_cache{$store_hash{$key}->{'id_str'}}; $id_cache{$id} = $key; } # finally store in menu code cache $store_hash{$key} = $j; sleep 5 while ($suspend_output > 0); &send_removereadline if ($termrl); $wrapseq++; $printed += scalar(&$handle($j, ($class || (($id <= $relative_last_id) ? 'again' : undef)))); } } $tweet_counter = $save_counter if ($save_counter > -1); sleep 5 while ($suspend_output > 0); &$exception(6,"*** warning: more tweets than menu codes; truncated\n") if (scalar(@{ $my_json_ref }) > $print_max); if (($interactive || $verbose) && !$printed) { &send_removereadline if ($termrl); print $stdout "-- sorry, nothing to display.\n"; $wrapseq = 1; } return ($return_max, $return_j); } sub dt_tdisplay { my $my_json_ref = shift; my $class = shift; if (defined($my_json_ref) && ref($my_json_ref) eq 'ARRAY' && scalar(@{ $my_json_ref })) { my ($crap, $art) = &tdisplay($my_json_ref, $class); unless ($timestamp) { my ($time, $ts1) = &$wraptime( $my_json_ref->[(&min($print_max,scalar(@{ $my_json_ref }))-1)]->{'created_at'}); my ($time, $ts2) = &$wraptime($art->{'created_at'}); print $stdout &wwrap( "-- update covers $ts1 thru $ts2\n"); } &$conclude; } } # thump for DMs sub dmrefresh { my $interactive = shift; my $sent_dm = shift; # for streaming API to inject DMs it receives my $my_json_ref = shift; if ($anonymous) { print $stdout "-- sorry, you can't read DMs if you're anonymous.\n" if ($interactive); return; } # no point in doing this if we can't even get to our own timeline # (unless user specifically requested it, or our timeline is off) return if (!$interactive && !$last_id && !$notimeline); # NOT last_dm $my_json_ref = &grabjson((($sent_dm) ? "$dmsenturl?full_text=true" : "$dmurl?full_text=true"), (($sent_dm) ? 0 : $last_dm), 0, $dmfetchwanted, undef, 1) if (!defined($my_json_ref) || ref($my_json_ref) ne 'ARRAY'); return if (!defined($my_json_ref) || ref($my_json_ref) ne 'ARRAY'); my $orig_last_dm = $last_dm; $last_dm = 0 if ($sent_dm); $dmfetchwanted = 0; my $printed = 0; my $max = 0; my $disp_max = &min($print_max, scalar(@{ $my_json_ref })); my $i; my $g; my $key; if ($disp_max) { # an empty list can be valid if ($dm_first_time) { sleep 5 while ($suspend_output > 0); &send_removereadline if ($termrl); print $stdout "-- checking for most recent direct messages:\n"; $disp_max = 2; $interactive = 1; } for($i = $disp_max; $i > 0; $i--) { $g = ($i-1); my $j = $my_json_ref->[$g]; next if (!$sent_dm && $j->{'id_str'} <= $last_dm); next if (!length($j->{'sender'}->{'screen_name'}) || !length($j->{'recipient'}->{'screen_name'})); $key = substr($alphabet, $dm_counter/10, 1) . $dm_counter % 10; $dm_counter = ($dm_counter == 259) ? 0 : ($dm_counter+1); $j->{'menu_select'} = $key; $dm_store_hash{lc($key)} = $j; sleep 5 while ($suspend_output > 0); &send_removereadline if ($termrl); $wrapseq++; $printed += scalar(&$dmhandle($j)); } $max = $my_json_ref->[0]->{'id_str'}; } sleep 5 while ($suspend_output > 0); if (($interactive || $verbose) && !$printed && !$dm_first_time) { &send_removereadline if ($termrl); print $stdout (($sent_dm) ? "-- you haven't sent anything yet.\n" : "-- sorry, no new direct messages.\n"); $wrapseq = 1; } $last_dm = ($sent_dm) ? $orig_last_dm : &max($last_dm, $max); $dm_first_time = 0 if ($last_dm || !scalar(@{ $my_json_ref })); print $stdout "-- dm bookmark is $last_dm.\n" if ($verbose); &$dmconclude; &send_repaint if ($termrl); } # post an update # this is a general API function that handles status updates and sending DMs. sub updatest { my $string = shift; my $interactive = shift; my $in_reply_to = shift; my $user_name_dm = shift; my $rt_id = shift; # even if this is set, string should also be set. my $urle = ''; my $i; my $subpid; my $istring; my $verb = (length($user_name_dm)) ? "DM $user_name_dm" : ($rt_id) ? 'RE-tweet' : 'tweet'; if ($anonymous) { print $stdout "-- sorry, you can't $verb if you're anonymous.\n" if ($interactive); return 99; } # "the pastebrake" if (!$slowpost && !$verify && !$script) { if ((time() - $postbreak_time) < 5) { $postbreak_count++; if ($postbreak_count == 3) { print $stdout "-- you're posting pretty fast. did you mean to do that?\n". "-- waiting three seconds before taking the next set of tweets\n". "-- hit CTRL-C NOW! to kill oysttyer if you accidentally pasted in this window\n"; sleep 3; $postbreak_count = 0; } } else { $postbreak_count = 0; } $postbreak_time = time(); } my $payload = (length($user_name_dm)) ? 'text' : 'status'; $string = &$prepost($string) unless ($user_name_dm || $rt_id); # YES, you *can* verify and slowpost. I thought about this and I # think I want to allow it. if ($verify && !$status) { my $answer; print $stdout &wwrap("-- verify you want to $verb: \"$string\"\n"); $answer = lc(&linein( "-- send to server? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, NOT sent to server.\n"; return 97; } } unless ($rt_id) { $urle = ''; #newlinehandler. New lines will indicated by "\n", which is two characters in the string #so need to keep track of backslashes that come up my $nlh = 'false'; #To send a literal "\" followed by an "n" prefix with another "\". I.e. "\\n" #Therefore two "\\" should always work out to be just one "\" #TODO: Would be nice to remove some of the duplication below. foreach $i (unpack("${pack_magic}C*", $string)) { my $k = chr($i); if ($nlh eq 'true') { #Then already have a slash and need to check for an "n" if ($k eq "n") { #Encoding for a newline $urle .= "%0A"; $nlh = 'false'; } else { #There is no "n" so might need to send the slash we've been holding onto and next character if ($k ne "\\") { #If it isn't another slash send the slash we held onto $urle .= "%5C"; } #Then send the character itself if ($k =~ /[-._~a-zA-Z0-9]/) { $urle .= $k; } else { $k = sprintf("%02X", $i); $urle .= "%$k"; } #Clear handler $nlh = 'false'; } } elsif ($k eq "\\") { #Could be the start of a new line $nlh = 'true'; } else { #Handle how we've always handled it if ($k =~ /[-._~a-zA-Z0-9]/) { $urle .= $k; } else { $k = sprintf("%02X", $i); $urle .= "%$k"; } #Clear handler $nlh = 'false'; } } } if ($nlh eq 'true') { #Then last one was a slash $urle .= "%5C"; } $user_name_dm = (length($user_name_dm)) ? "&user=$user_name_dm" : ''; my $i = ''; $i .= "source=oysttyer&" if ($authtype eq 'basic'); $i .= "in_reply_to_status_id=${in_reply_to}&" if ($in_reply_to > 0); if (!$rt_id && defined $lat && defined $long && $location) { print $stdout "-- using lat/long: ($lat, $long)\n"; $i .= "lat=${lat}&long=${long}&"; } elsif ((defined $lat || defined $long) && $location && !$rt_id) { print $stdout "-- warning: incomplete location ($lat, $long) ignored\n"; } $i .= "${payload}=${urle}${user_name_dm}" unless ($rt_id); $i .= "id=$rt_id" if ($rt_id); $slowpost += 0; if ($slowpost && !$script && !$status && !$silent) { if($pid = open(SLOWPOST, '-|')) { # pause background so that it doesn't kill itself # when this signal occurs. kill $SIGUSR1, $child; print $stdout &wwrap( "-- waiting $slowpost seconds to $verb, ^C cancels: \"$string\"\n"); close(SLOWPOST); # this should wait for us if ($? > 256) { print $stdout "\n-- not sent, cancelled by user\n"; return 97; } print $stdout "-- sending to server\n"; kill $SIGUSR2, $child; &send_removereadline if ($termrl && $dostream); } else { $in_backticks = 1; # defeat END sub &sigify(sub { exit 254; }, qw(BREAK INT TERM PIPE)); sleep $slowpost; exit 0; } } my $return = &backticks($baseagent, '/dev/null', undef, (length($user_name_dm)) ? $dmupdate : ($rt_id) ? "$rturl/${rt_id}.json" : $update, $i, 0, @wend); print $stdout "-- return --\n$return\n-- return --\n" if ($superverbose); if ($? > 0) { $x = $? >> 8; print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: connect timeout or no confirmation received ($x) *** to attempt a resend, type %%${OFF} EOF return $?; } my $ec; if ($ec = &is_json_error($return)) { print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: server error message received *** "$ec"${OFF} EOF return 98; } if ($ec = &is_fail_whale($return) || $return =~ /^\[?\]?/i || $return =~ /^<\??xml\s+/) { print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: Twitter Fail Whale${OFF} EOF return 98; } $lastpostid = &parsejson($return)->{'id_str'}; unless ($user_name_dm || $rt_id) { $lasttwit = $string; &$postpost($string); } return 0; } # this dispatch routine replaces the common logic of deletest, deletedm, # follow, leave and the favourites system. # this is a modified, abridged version of &updatest. sub central_cd_dispatch { my ($payload, $interactive, $update) = (@_); my $return = &backticks($baseagent, '/dev/null', undef, $update, $payload, 0, @wend); print $stdout "-- return --\n$return\n-- return --\n" if ($superverbose); if ($? > 0) { $x = $? >> 8; print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: connect timeout or no confirmation received ($x) *** to attempt again, type %%${OFF} EOF return ($?, ''); } my $ec; if ($ec = &is_json_error($return)) { print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: server error message received *** "$ec"${OFF} EOF return (98, $return); } return (0, $return); } # the following functions may be user-exposed in a future version of # oysttyer, but are officially still "private interfaces." # delete a status sub deletest { my $id = shift; my $interactive = shift; my $url = $delurl; $url =~ s/%I/$id/; my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $url); print $stdout "-- tweet id #${id} has been removed\n" if ($interactive && !$en); print $stdout "*** (was the tweet already deleted?)\n" if ($interactive && $en); return 0; } # delete a DM sub deletedm { my $id = shift; my $interactive = shift; my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $dmdelurl); print $stdout "-- DM id #${id} has been removed\n" if ($interactive && !$en); print $stdout "*** (was the DM already deleted?)\n" if ($interactive && $en); return 0; } # create or destroy a favourite sub cordfav { my $id = shift; my $interactive = shift; my $basefav = shift; my $text = shift; my $verb = shift; my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $basefav); print $stdout "-- like $verb for tweet id #${id}: \"$text\"\n" if ($interactive && !$en); print $stdout "*** (was the like already ${verb}?)\n" if ($interactive && $en); return 0; } # follow or unfollow a user sub foruuser { my $uname = shift; my $interactive = shift; my $basef = shift; my $verb = shift; my ($en, $em) = ¢ral_cd_dispatch("screen_name=$uname", $interactive, $basef); print $stdout "-- ok, you have $verb following user $uname.\n" if ($interactive && !$en); return 0; } # block or unblock a user sub boruuser { my $uname = shift; my $interactive = shift; my $basef = shift; my $verb = shift; my ($en, $em) = ¢ral_cd_dispatch("screen_name=$uname", $interactive, $basef); print $stdout "-- ok, you have $verb blocking user $uname.\n" if ($interactive && !$en); return 0; } # mute or unmute a user sub muteuser { my $uname = shift; my $interactive = shift; my $basef = shift; my $verb = shift; my ($en, $em) = ¢ral_cd_dispatch("screen_name=$uname", $interactive, $basef); print $stdout "-- ok, you have $verb muting user $uname.\n" if ($interactive && !$en); return 0; } # enable or disable retweets for a user sub rtsonoffuser { my $uname = shift; my $interactive = shift; my $selection = shift; my $verb = ($selection) ? 'enabled' : 'disabled'; my $tval = ($selection) ? 'true' : 'false'; my ($en, $em) = ¢ral_cd_dispatch( "retweets=${tval}&screen_name=${uname}", $interactive, $frupdurl); print $stdout "-- ok, you have ${verb} retweets for user $uname.\n" if ($interactive && !$en); return 0; } #### oysttyer internal API utility functions #### # ... which your API *can* call # gets and returns the contents of a URL (optionally pass a POST body) sub graburl { my $resource = shift; my $data = shift; return &backticks($baseagent, '/dev/null', undef, $resource, $data, 1, @wind); } # format a tweet based on user options sub standardtweet { my $ref = shift; my $nocolour = shift; my $sn = &descape($ref->{'user'}->{'screen_name'}); my $tweet = &descape($ref->{'text'}); my $colour; my $g; my $h; my $quote_badge = &descape("↑"); # wordwrap really ruins our day here, thanks a lot, @augmentedfourth # have to insinuate the ansi sequences after the string is wordwrapped $g = $colour = ${'CC' . scalar(&$tweettype($ref, $sn, $tweet)) } unless ($nocolour); $colour = $OFF . $colour unless ($nocolour); # prepend screen name "badges" $sn = "\@$sn" if ($ref->{'in_reply_to_status_id_str'} > 0); $sn = "+$sn" if ($ref->{'user'}->{'geo_enabled'} eq 'true' && (($ref->{'geo'}->{'coordinates'}->[0] ne 'undef' && length($ref->{'geo'}->{'coordinates'}->[0]) && $ref->{'geo'}->{'coordinates'}->[1] ne 'undef' && length($ref->{'geo'}->{'coordinates'}->[0])) || length($ref->{'place'}->{'id'}))); $sn = "%$sn" if (length($ref->{'retweeted_status'}->{'id_str'})); # badge the parent of the quoted tweet. Note: is_quote_status seems to be undocumented? $sn = "\"$sn" if ($ref->{'is_quote_status'} eq 'true'); # badge quoted statuses themselves $sn = ($quote_badge . $sn) if ($ref->{'oysttyer_quoted'} eq 'true'); $sn = "*$sn" if ($ref->{'source'} =~ /oysttyer/ && $oysttyeristas); # prepend list information, if this tweet originated from a list $sn = "($ref->{'tag'}->{'payload'})$sn" if (length($ref->{'tag'}->{'payload'}) && $ref->{'tag'}->{'type'} eq 'list'); $tweet = "<$sn> $tweet"; # twitter doesn't always do this right. $h = $ref->{'retweet_count'}; $h += 0; #$h = "${h}+" if ($h >= 100); # twitter doesn't always handle single retweets right. good f'n grief. $tweet = "(x${h}) $tweet" if ($h > 1 && !$nonewrts); # br3nda's modified timestamp patch if ($timestamp) { my ($time, $ts); # Print the timestamp of the original tweet, not when it was RTed. if (length($ref->{'retweeted_status'}->{'id_str'})) { ($time, $ts) = &wraptime($ref->{'retweeted_status'}->{'created_at'}); } else { ($time, $ts) = &wraptime($ref->{'created_at'}); } $tweet = "[$ts] $tweet"; } # pull it all together $tweet = &wwrap($tweet, ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0) if ($wrap); # remember to account for prompt length on #1 $tweet =~ s/^([^<]*)<([^>]+)>/${g}\1<${EM}\2${colour}>/ unless ($nocolour); $tweet =~ s/\n*$//; $tweet .= ($nocolour) ? "\n" : "$OFF\n"; # highlight anything that we have in track if(scalar(@tracktags)) { # I'm paranoid foreach $h (@tracktags) { $h =~ s/^"//; $h =~ s/"$//; # just in case $tweet =~ s/(^|[^a-zA-Z0-9])($h)([^a-zA-Z0-9]|$)/\1${EM}\2${colour}\3/ig unless ($nocolour); } } # smb's underline/bold patch goes on last (modified for lists) unless ($nocolour) { # only do this after the < > portion. my $k = index($tweet, ">"); my $botsub = substr($tweet, $k); my $topsub = substr($tweet, 0, $k); $botsub =~ s/(^|[^a-zA-Z0-9_])\@([a-zA-Z0-9_\/]+)/\1\@${UNDER}\2${colour}/g; $tweet = $topsub . $botsub; } if ($largeimages) { $tweet =~ s#(https://pbs.twimg.com/media/\S+)\.(png|jpg)#\1.\2\:large#g; } elsif ($origimages) { $tweet =~ s#(https://pbs.twimg.com/media/\S+)\.(png|jpg)#\1.\2\:orig#g; } return $tweet; } # format a DM based on standard user options sub standarddm { my $ref = shift; my $nocolour = shift; my ($time, $ts) = &$wraptime($ref->{'created_at'}); my $text = &descape($ref->{'text'}); my $sns = lc(&descape($ref->{'sender'}->{'screen_name'})); if ($sns eq $whoami) { $sns = "->" . &descape($ref->{'recipient'}->{'screen_name'}); } my $g = &wwrap("[DM d$ref->{'menu_select'}]". "[$sns/$ts] $text", ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0); $g =~ s/^\[DM ([^\/]+)\//${CCdm}[DM ${EM}\1${OFF}${CCdm}\// unless ($nocolour); $g =~ s/\n*$//; $g .= ($nocolour) ? "\n" : "$OFF\n"; $g =~ s/(^|[^a-zA-Z0-9_])\@(\w+)/\1\@${UNDER}\2${OFF}${CCdm}/g unless ($nocolour); return $g; } # format an event record based on standard user options (mostly for # streaming API, perhaps REST API one day) sub standardevent { my $ref = shift; my $nocolour = shift; my $g = '>>> '; my $verb = &descape($ref->{'event'}); # https://dev.twitter.com/docs/streaming-apis/messages if (length($verb)) { # see below for server-level events my $tar_sn = '@'.&descape($ref->{'target'}->{'screen_name'}); my $sou_sn = '@'.&descape($ref->{'source'}->{'screen_name'}); my $tar_list_name = ''; my $tar_list_desc = ''; # For all verbs starting with "list", get name and desc if ($verb =~ m/^list/ ) { $tar_list_name = &descape($ref->{'target_object'}->{'full_name'}); $tar_list_desc = &descape($ref->{'target_object'}->{'description'}); } # Twitter still uses (un)?favorite, but we add (un)?like as a bit of future-proofing. if ($verb eq 'like' || $verb eq 'unlike' || $verb eq 'favorite' || $verb eq 'unfavorite') { my $rto = &destroy_all_tco($ref->{'target_object'}); my $txt = &descape($rto->{'text'}); $verb =~ s/favorite/like/; $g .= "$sou_sn just ${verb}d ${tar_sn}'s tweet: \"$txt\""; } elsif ($verb eq 'liked_retweet' || $verb eq 'favorited_retweet') { # Put these in a separate case since the English gets a little more complicated my $rto = &destroy_all_tco($ref->{'target_object'}); my $txt = &descape($rto->{'text'}); $verb =~ s/favorite/like/; # This event gets sent for both likes of tweets you retweeted and when you # like a tweet that was retweeted into your timeline. We only want to # display this message in the former case. $g .= "$sou_sn just liked a tweet you retweeted: \"$txt\"" unless (lc($sou_sn) eq '@' . lc($whoami)) ; } elsif ($verb eq 'follow') { $g .= "$sou_sn is now following $tar_sn"; } elsif ($verb eq 'user_update') { $g .= "$sou_sn updated their profile (/whois $sou_sn to see)"; } elsif ($verb eq 'list_member_added') { $g .= "$sou_sn added $tar_sn to the list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'list_member_removed') { $g .= "$sou_sn removed $tar_sn from the list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'list_user_subscribed') { $g .= "$sou_sn is now following the list \"$tar_list_desc\" ($tar_list_name) from $tar_sn"; } elsif ($verb eq 'list_user_unsubscribed') { $g .= "$sou_sn is no longer following the list \"$tar_list_desc\" ($tar_list_name) from $tar_sn"; } elsif ($verb eq 'list_created') { $g .= "$sou_sn created the new list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'list_destroyed') { $g .= "$sou_sn destroyed the list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'list_updated') { $g .= "$sou_sn updated the list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'block' || $verb eq 'unblock') { $g .= "$sou_sn ${verb}ed $tar_sn ($tar_sn is not ". "notified)"; } elsif ($verb eq 'mute' || $verb eq 'unmute') { $g .= "$sou_sn ${verb}d $tar_sn ($tar_sn is not ". "notified)"; } elsif ($verb eq 'access_revoked') { $g .= "$sou_sn revoked oAuth access to $tar_sn"; } elsif ($verb eq 'access_unrevoked') { $g .= "$sou_sn restored oAuth access to $tar_sn"; } elsif ($verb eq 'quoted_tweet') { my $rto = &destroy_all_tco($ref->{'target_object'}); my $txt = &descape($rto->{'text'}); $g .= "$sou_sn just quoted ${tar_sn}'s tweet: \"$txt\""; } elsif ($verb eq 'retweeted_retweet') { my $rto = &destroy_all_tco($ref->{'target_object'}); my $txt = &descape($rto->{'text'}); $g .= "$sou_sn just retweeted a tweet you retweeted: \"$txt\""; } else { # try to handle new types of events we don't # recognize yet. $verb .= ($verb =~ /e$/) ? 'd' : 'ed'; $g .= "$sou_sn $verb $tar_sn (basic)"; } # server events ("public stream messages") are handled differently. # we support almost all except for the ones that are irrelevant to # this medium. } elsif ($ref->{'delete'}) { # this is the best we can do -- it's already on the screen! # we don't want to make it easy which tweet it is, since that # would be embarrassing, so just say a delete occurred. $g .= "tweet ID# ".$ref->{'delete'}->{'status'}->{'id_str'}. " deleted by server"; } elsif ($ref->{'status_withheld'}) { # Twitter doesn't document id_str as available here. check. if (!length($ref->{'status_withheld'}->{'id_str'})) { # do nothing right now } else { $g .= "tweet ID# ".$ref->{'status_withheld'}->{'id_str'}. " censored by server in your country"; } } elsif ($ref->{'user_withheld'}) { $g .= "user ID# ".$ref->{'user_withheld'}->{'user_id'}. " censored by server in your country"; } elsif ($ref->{'disconnect'}) { $g .= "DISCONNECTED BY SERVER (".$ref->{'disconnect'}->{'code'}. "); will retry: ".$ref->{'disconnect'}->{'reason'}; } else { # we have no idea what this is. just BS our way out. $g .= "unknown server event received (non-fatal)\n"; } if ($timestamp) { my ($time, $ts) = &$wraptime($ref->{'created_at'}); $g = "[$ts] $g"; } $g = &wwrap("$g\n", ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0); # highlight screen names $g =~ s/(^|[^a-zA-Z0-9_])\@([a-zA-Z0-9_\-\/]+)/\1\@${UNDER}\2${OFF}/g unless ($nocolour); return $g; } # for future expansion: this is the declared API callable method # for executing a command as if the console had typed it. sub ucommand { die("** can't call &ucommand during multi-module loading.\n") if ($multi_module_mode == -1); &prinput(@_); } # your application can also call &grabjson to get a hashref # corresponding to parsed JSON from an arbitrary resource. # see that function later on. #### DEFAULT oysttyer INTERNAL API METHODS #### # don't change these here. instead, use -exts=yourlibrary.pl and set there. # note that these are all anonymous subroutine references. # anything you don't define is overwritten by the defaults. # it's better'n'superclasses. # NOTE: defaultaddaction, defaultmain and defaultprompt # are all defined in the "console" section above for # clarity. # this first set are the multi-module aware ones. # the standard iterator for multi-module methods sub multi_module_dispatch { my $default = shift; my $dispatch_chain = shift; my $rv_handler = shift; my @args = @_; local $dispatch_ref; # on purpose; get_key/set_key may need it # $*_call_default is a global $did_call_default = 0; $this_call_default = 0; $multi_module_context = 0; if ($rv_handler == 0) { $rv_handler = sub { return 0; }; } # fall through to default if no dispatch chain if (!scalar(@{ $dispatch_chain })) { return &$default(@args); } foreach $dispatch_ref (@{ $dispatch_chain }) { # each reference has the code, and the file that specified it. # set up a multi-module context and run that function. if the # default ever gets called, we log it to tell the multi-module # handler to call the default at the end. my $rv; my $irv; my $caller = (caller(1))[3]; $caller =~ s/^main::multi//; $multi_module_context = 1; # defaults then know to defer $this_call_default = 0; $store = $master_store->{ $dispatch_ref->[0] }; print "-- calling \$$caller in $dispatch_ref->[0]\n" if ($verbose); my $code_ref = $dispatch_ref->[1]; $rv = &$rv_handler(@irv = &$code_ref(@args)); $multi_module_context = 0; if ($rv & 4) { # rv_handler indicating to call default and halt # if it was called. return &$default(@args) if ($did_call_default); } if ($rv & 2) { # rv_handler indicating to make new @args from @irv @args = @irv; } if ($rv & 1) { # rv_handler indicating to halt early. do so. return (wantarray) ? @irv : $irv[0]; } } $multi_module_context = 0; return &$default(@args) if ($did_call_default); return (wantarray) ? @irv : $irv[0]; } # these are the stubs that call the dispatcher. sub multiaddaction { &multi_module_dispatch(\&defaultaddaction, \@m_addaction, sub{ # return immediately on the first extension to accept return (shift>0); }, @_); } sub multiconclude { &multi_module_dispatch(\&defaultconclude, \@m_conclude, 0, @_); } sub multidmconclude { &multi_module_dispatch(\&defaultdmconclude, \@m_dmconclude, 0, @_); } sub multidmhandle { &multi_module_dispatch(\&defaultdmhandle, \@m_dmhandle, sub { my $rv = shift; # skip default calls. return 0 if ($this_call_default); # if not a default call, and the DM was refused for # processing by this extension, then the DM is now # suppressed. do not call any other extensions after this. # even if it ends in suppression, we still call the default # if it was ever called before. return 5 if ($rv == 0); # if accepted in any manner, keep calling. return 0; }, @_); } sub multieventhandle { &multi_module_dispatch(\&defaulteventhandle, \@m_eventhandle, sub { my $rv = shift; # skip default calls. return 0 if ($this_call_default); # if not a default call, and the event was refused for # processing by this extension, then the event is now # suppressed. do not call any other extensions after this. # even if it ends in suppression, we still call the default # if it was ever called before. return 5 if ($rv == 0); # if accepted in any manner, keep calling. return 0; }, @_); } sub multiexception { # this is a secret option for people who want to suppress errors. if ($exception_is_maskable) { &multi_module_dispatch(\&defaultexception, \@m_exception, sub { my $rv = shift; # same logic as handle/dmhandle, except return -1- # to mask from subsequent extensions. return 0 if ($this_call_default); return 5 if ($rv); return 0; }, @_); } else { &multi_module_dispatch( \&defaultexception, \@m_exception, 0, @_); } } sub multishutdown { return if ($shutdown_already_called++); &multi_module_dispatch(\&defaultshutdown, \@m_shutdown, 0, @_); } sub multiuserhandle { &multi_module_dispatch(\&defaultuserhandle, \@m_userhandle, sub{ # skip default calls. return 0 if ($this_call_default); # return immediately on the first extension to accept return (shift>0); }, @_); } sub multilisthandle { &multi_module_dispatch(\&defaultlisthandle, \@m_listhandle, sub{ # skip default calls. return 0 if ($this_call_default); # return immediately on the first extension to accept return (shift>0); }, @_); } sub multihandle { &multi_module_dispatch(\&defaulthandle, \@m_handle, sub { my $rv = shift; # skip default calls. return 0 if ($this_call_default); # if not a default call, and the tweet was refused for # processing by this extension, then the tweet is now # suppressed. do not call any other extensions after this. # even if it ends in suppression, we still call the default # if it was ever called before. return 5 if ($rv==0); # if accepted in any manner, keep calling. return 0; }, @_); } sub multiheartbeat { &multi_module_dispatch(\&defaultheartbeat, \@m_heartbeat, 0, @_); } sub multiprecommand { &multi_module_dispatch(\&defaultprecommand, \@m_precommand, sub { return 2; # feed subsequent chains the result. }, @_); } sub multiprepost { &multi_module_dispatch(\&defaultprepost, \@m_prepost, sub { return 2; # feed subsequent chains the result. }, @_); } sub multipostpost { &multi_module_dispatch(\&defaultpostpost, \@m_postpost, 0, @_); } sub multitweettype { &multi_module_dispatch(\&defaulttweettype, \@m_tweettype, sub { # if this module DID NOT call default, exit now. return (!$this_call_default); }, @_); } sub flag_default_call { $this_call_default++; $did_call_default++; } # now the actual default methods sub defaultexception { (&flag_default_call, return) if ($multi_module_context); my $msg_code = shift; return if ($msg_code == 2 && $muffle_server_messages); my $message = "@_"; $message =~ s/\n*$//sg; if ($timestamp) { my ($time, $ts) = &$wraptime(scalar(localtime)); $message = "[$ts] $message"; $message =~ s/\n/\n[$ts] /sg; } &send_removereadline if ($termrl); $wrapseq = 1; print $stdout "${MAGENTA}${message}${OFF}\n"; &send_repaint if ($termrl); $laststatus = 1; } sub defaultshutdown { (&flag_default_call, return) if ($multi_module_context); } sub defaultlisthandle { (&flag_default_call, return) if ($multi_module_context); my $list_ref = shift; print $streamout "*** for future expansion ***\n"; return 1; } sub defaulthandle { (&flag_default_call, return) if ($multi_module_context); my $tweet_ref = shift; my $class = shift; my $dclass = ($verbose) ? "{$class,$tweet_ref->{'id_str'}} " : ''; my $sn = &descape($tweet_ref->{'user'}->{'screen_name'}); my $tweet = &descape($tweet_ref->{'text'}); my $stweet = &standardtweet($tweet_ref); my $menu_select = $tweet_ref->{'menu_select'}; $menu_select = (length($menu_select) && !$script) ? (($menu_select =~ /^z/) ? "${EM}${menu_select}>${OFF} " : "${menu_select}> ") : ''; print $streamout "\n" if ($doublespace); print $streamout $menu_select . $dclass . $stweet; &sendnotifies($tweet_ref, $class); return 1; } sub defaultuserhandle { (&flag_default_call, return) if ($multi_module_context); my $user_ref = shift; &userline($user_ref, $streamout); my $desc = &strim(&descape($user_ref->{'description'})); my $klen = ($wrap || 79) - 9; $klen = 10 if ($klen < 0); $desc = substr($desc, 0, $klen)."..." if (length($desc) > $klen); print $streamout (' "' . $desc . '"' . "\n") if (length($desc)); return 1; } sub userline { # used by both $userhandle and /whois my $my_json_ref = shift; my $fh = shift; my $verified = ($my_json_ref->{'verified'} eq 'true') ? "${EM}(Verified)${OFF} " : ''; my $protected = ($my_json_ref->{'protected'} eq 'true') ? "${EM}(Protected)${OFF} " : ''; print $fh <<"EOF"; ${CCprompt}@{[ &descape($my_json_ref->{'name'}) ]}${OFF} (@{[ &descape($my_json_ref->{'screen_name'}) ]}) (f:$my_json_ref->{'friends_count'}/$my_json_ref->{'followers_count'}) (u:$my_json_ref->{'statuses_count'}) ${verified}${protected} EOF return; } sub sendnotifies { # this is a default subroutine of a sort, right? my $tweet_ref = shift; my $class = shift; my $sn = &descape($tweet_ref->{'user'}->{'screen_name'}); my $tweet = &descape($tweet_ref->{'text'}); # interactive? first time? unless (length($class) || !$last_id || !length($tweet)) { $class = scalar(&$tweettype($tweet_ref, $sn, $tweet)); ¬ifytype_dispatch($class, &standardtweet($tweet_ref, 1), $tweet_ref) if ($notify_list{$class}); } } sub defaulttweettype { (&flag_default_call, return) if ($multi_module_context); my $ref = shift; my $sn = shift; my $tweet = shift; # br3nda's and smb's modified colour patch unless ($anonymous) { if (lc($sn) eq $whoami) { # if it's me speaking, colour the line yellow return 'me'; } elsif ($tweet =~ /\@$whoami(\b|$)/i) { # if I'm in the tweet, colour red return 'reply'; } } if ($ref->{'class'} eq 'search') { # anonymous allows this too # if this is a search result, colour cyan return 'search'; } if ($ref->{'tag'}->{'type'} eq 'list') { # anonymous allows this too return 'list'; } return 'default'; } sub defaultconclude { (&flag_default_call, return) if ($multi_module_context); if ($filtered && $filter_attribs{'count'}) { print $stdout "-- (filtered $filtered tweets)\n"; $filtered = 0; } print $separator . "\n" if ( $separator ); } sub defaultdmhandle { (&flag_default_call, return) if ($multi_module_context); my $dm_ref = shift; my $sns = &descape($dm_ref->{'sender'}->{'screen_name'}); print $streamout &standarddm($dm_ref); &senddmnotifies($dm_ref) if ($sns ne $whoami); return 1; } sub senddmnotifies { my $dm_ref = shift; ¬ifytype_dispatch('DM', &standarddm($dm_ref, 1), $dm_ref) if ($notify_list{'dm'} && $last_dm); } sub defaulteventhandle { (&flag_default_call, return) if ($multi_module_context); my $event_ref = shift; # in this version, we silently filter delete events, but your # extension would still get them delivered. return 1 if ($event_ref->{'delete'}); print $streamout &standardevent($event_ref); return 1; } sub defaultdmconclude { (&flag_default_call, return) if ($multi_module_context); } sub defaultheartbeat { (&flag_default_call, return) if ($multi_module_context); } # not much sense to multi-module protect these. sub defaultprecommand { return ("@_"); } sub defaultprepost { return ("@_"); } sub defaultpostpost { (&flag_default_call, return) if ($multi_module_context); my $line = shift; return if (!$termrl); # populate %readline_completion if readline is on while($line =~ s/^\@(\w+)\s+//) { $readline_completion{'@'.lc($1)}++; } if ($line =~ /^[dD]\s+(\w+)\s+/) { $readline_completion{'@'.lc($1)}++; } } sub defaultautocompletion { my ($text, $line, $start) = (@_); my $qmtext = quotemeta($text); my @proband; my @rlkeys; # handle / completion if ($start == 0 && $text =~ m#^/#) { return sort grep(/^$qmtext/i, '/history', '/print', '/quit', '/bye', '/again', '/wagain', '/whois', '/thump', '/dm', '/qdm', '/refresh', '/dmagain', '/set', '/help', '/reply', '/url', '/thread', '/retweet', '/replyall', '/replies', '/ruler', '/exit', '/me', '/vcheck', '/oretweet', '/eretweet', '/lretweet', '/liston', '/listoff', '/dmsent', '/rtsof', '/rtson', '/rtsoff', '/lists', '/withlist', '/add', '/padd', '/push', '/pop', '/followers', '/friends', '/lfollow', '/lleave', '/listfollowers', '/listfriends', '/unset', '/verbose', '/short', '/follow', '/unfollow', '/doesfollow', '/search', '/tron', '/troff', '/delete', '/deletelast', '/dump', '/track', '/trends', '/block', '/unblock', '/mute', '/unmute', '/web', '/like', '/likes', '/unlike', '/eval'); } @rlkeys = keys(%readline_completion); # handle @ completion. this works slightly weird because # readline hands us the string WITHOUT the @, so we have to # test somewhat blindly. this works even if a future readline # DOES give us the word with @. also handles D, /wa, /wagain, # /a, /again, etc. if (($line =~ m#^(D|/wa|/wagain|/a|/again) #i) || ($start == 1 && substr($line, 0, 1) eq '@') || # this code is needed to prevent inline @ from flipping out ($start >= 1 && substr($line, ($start-2), 2) eq ' @')) { @proband = grep(/^\@$qmtext/i, @rlkeys); if (scalar(@proband)) { @proband = map { s/^\@//;$_ } @proband; return @proband; } } # definites that are left over, including @ if it were included if(scalar(@proband = grep(/^$qmtext/i, @rlkeys))) { return @proband; } # heuristics # URL completion (this doesn't always work of course) if ($text =~ m#https?://#) { return (&urlshorten($text) || $text); } # "I got nothing." return (); } #### built-in notification routines #### # growl for Mac OS X sub notifier_growl { my $class = shift; my $text = shift; my $ref = shift; # not used in this version if (!defined($class) || !length($notify_tool_path)) { # we are being asked to initialize $notify_tool_path = &wherecheck("trying to find growlnotify", "growlnotify", "growlnotify must be installed to use growl notifications. check your\n" . "documentation for how to do this.\n") unless ($notify_tool_path); if (!defined($class)) { return 1 if ($script || $notifyquiet); $class = 'Growl support activated'; $text = 'You can configure notifications for oysttyer 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 'oysttyer' 'oysttyer: $class'"); binmode(GROWL, ":utf8") unless ($seven); print GROWL $text; close(GROWL); exit; } # libnotify for {Linux,whatevs} # this is EXPERIMENTAL, and requires this patch to notify-send: # http://www.floodgap.com/software/ttytter/libnotifypatch.txt # why it has not already been applied is fricking beyond me, it makes # sense. would YOU want arbitrary characters on the command line # separated only from overwriting your home directory by a quoting routine? sub notifier_libnotify { my $class = shift; my $text = shift; my $ref = shift; # not used in this version if (!defined($class) || !defined($notify_tool_path)) { # we are being asked to initialize $notify_tool_path = &wherecheck("trying to find notify-send", "notify-send", "notify-send must be installed to use libnotify, and it must be modified\n". "for standard input. see the documentation for how to do this.\n") unless ($notify_tool_path); if (!defined($class)) { return 1 if ($script || $notifyquiet); $class = 'libnotify support activated'; $text = 'Congratulations, your notify-send is correctly configured for oysttyer.'; } } # figure out the time to display based on length of tweet my $t = 1000+50*length($text); # about 150-180wpm read speed open(NOTIFYSEND, "|$notify_tool_path -t $t -f - 'oysttyer: $class'"); binmode(NOTIFYSEND, ":utf8") unless ($seven); print NOTIFYSEND $text; close(NOTIFYSEND); return 1; } #### IPC routines for communicating between the foreground + background #### # this is the central routine that takes a rolling tweet code, figures # out where that tweet is, and returns something approximating a tweet # structure (or the actual tweet structure itself if it can). sub get_tweet { my $code = lc(shift); #TODO # implement querying the id_cache here. we need IPC for it, though. # if the code is all numbers, treat it like an id_str, and try # to get it from the server. we have similar code in get_dm. # the first tweet that is of relevance is ID 20. try /dump 20 :) return &grabjson("${idurl}?id=${code}", 0, 0, 0, undef, 1) if ($code =~ /^[0-9]+$/ && (0+$code > 19)); return undef if ($code !~ /^z?[a-z][0-9]$/); my $source = ($code =~ /^z/) ? 1 : 0; my $k = ''; my $l = ''; my $w = {'user' => {}}; if ($is_background) { if ($source == 1) { # foreground only return undef; } return $store_hash{$code}; } return $store_hash{$code} if ($source); # foreground c/foreground twt print $stdout "-- querying background: $code\n" if ($verbose); kill $SIGUSR2, $child if ($child); print C "pipet $code ----------\n"; while(length($k) < $packet_length) { sysread(W, $l, $packet_length); $k .= $l; } return undef if ($k !~ /[^\s]/); $k =~ s/\s+$//; # remove trailing spaces print $stdout "-- background store fetch: $k\n" if ($verbose); # And I think any additional field extracted from the stream also has to be added here as well. # I.e quoted_status_id_str # Need to increment the count in split at the end. ($w->{'menu_select'}, $w->{'id_str'}, $w->{'in_reply_to_status_id_str'}, $w->{'quoted_status_id_str'}, $w->{'quoted_status'}->{'text'}, $w->{'quoted_status'}->{'full_text'}, $w->{'quoted_status'}->{'extended_tweet'}->{'full_text'}, $w->{'retweeted_status'}->{'id_str'}, $w->{'retweeted_status'}->{'text'}, $w->{'retweeted_status'}->{'full_text'}, $w->{'retweeted_status'}->{'extended_tweet'}->{'full_text'}, $w->{'retweeted_status'}->{'quoted_status'}->{'id_str'}, $w->{'retweeted_status'}->{'quoted_status'}->{'text'}, $w->{'retweeted_status'}->{'quoted_status'}->{'full_text'}, $w->{'retweeted_status'}->{'quoted_status'}->{'extended_tweet'}->{'full_text'}, $w->{'user'}->{'geo_enabled'}, $w->{'geo'}->{'coordinates'}->[0], $w->{'geo'}->{'coordinates'}->[1], $w->{'place'}->{'id'}, $w->{'place'}->{'country_code'}, $w->{'place'}->{'place_type'}, $w->{'place'}->{'full_name'}, $w->{'tag'}->{'type'}, $w->{'tag'}->{'payload'}, $w->{'retweet_count'}, $w->{'user'}->{'screen_name'}, $w->{'created_at'}, $w->{'source'}, $k) = split(/\0/, $k, 29); $w->{'text'} = pack("H*", $k); $w->{'place'}->{'full_name'} = pack("H*",$w->{'place'}->{'full_name'}); $w->{'tag'}->{'payload'} = pack("H*", $w->{'tag'}->{'payload'}); return undef if (!length($w->{'text'})); # unpossible $w->{'created_at'} =~ s/_/ /g; return $w; } # this is the analogous function for a rolling DM code. it is somewhat # simpler as DM codes are always rolling and have no foreground store # currently, so it always executes a background request. sub get_dm { my $code = lc(shift); my $k = ''; my $l = ''; my $w = {'sender' => {}}; my $t1 = ''; my $t2 = ''; return undef if (length($code) < 3 || $code !~ s/^d//); # this is the aforementioned "similar code" (see get_tweet). # optimization: I doubt ANY of us can get DMIDs less than 9. return &grabjson("${dmidurl}?id=$code", 0, 0, 0, undef, 1) if ($code =~ /^[0-9]+$/ && (0+$code > 9)); return undef if ($code !~ /^[a-z][0-9]$/); kill $SIGUSR2, $child if ($child); # prime pipe print C "piped $code ----------\n"; # internally two alphanum, recall while(length($k) < $packet_length) { sysread(W, $l, $packet_length); $k .= $l; } return undef if ($k !~ /[^\s]/); $k =~ s/\s+$//; # remove trailing spaces print $stdout "-- background store fetch: $k\n" if ($verbose); ($w->{'menu_select'}, $w->{'id_str'}, $w->{'sender'}->{'screen_name'}, $w->{'created_at'}, $l) = split(/\s/, $k, 5); #Truncate text if a little bit too long ($t1, $t2) = &csplit(pack("H*", $l), "word"); if (length($t2)) { $t1 .= "..."; } $w->{'text'} = $t1; return undef if (!length($w->{'text'})); # not possible $w->{'created_at'} =~ s/_/ /g; return $w; } # this function requests a $store key from the background. it only works # if foreground. sub getbackgroundkey { if ($is_background) { print $stdout "*** can't call getbackgroundkey from background\n"; return undef; } my $key = shift; my $l; my $k; print C substr("ki $key ---------------------", 0, 19)."\n"; my $ref = (length($dispatch_ref->[0])) ? ($dispatch_ref->[0]) : "DEFAULT"; print C substr(unpack("${pack_magic}H*", $ref).$space_pad, 0, $packet_length); while(length($k) < $packet_length) { sysread(W, $l, $packet_length); $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, $packet_length); return if (!length($value)); print C substr(unpack("${pack_magic}H*", $value).$space_pad, 0, $packet_length); } # hold stolen from Floodgap's Texapp sub hold { $holdhold ^= 1; print C "hold---------------\n" unless ($synch); &sync_semaphore; } sub thump { print C "update-------------\n"; &sync_semaphore; } sub dmthump { print C "dmthump------------\n"; &sync_semaphore; } # ensure_held and ensure_not_held stolen from Floodgap's Texapp sub ensure_held { return if ($holdhold || $synch); &hold; } sub ensure_not_held { return if (!$holdhold || $synch); &hold; } sub sync_n_quit { if ($child) { print $stdout "waiting for child ...\n" unless ($silent); print C "sync---------------\n"; waitpid $child, 0; $child = 0; print $stdout "exiting.\n" unless ($silent); exit ($? >> 8); } exit; } # setter for internal variables, with all the needed side effects for those # variables that are programmed to trigger internal actions when changed. sub setvariable { my $key = shift; my $value = shift; my $interactive = 0+shift; $value =~ s/^\s+//; $value =~ s/\s+$//; # mostly to avoid problems with /(p)add if ($key eq 'script') { # this can never be changed by this routine print $stdout "*** script may only be changed on init\n"; return 1; } if ($key eq 'tquery' && $value eq '0') { # undo tqueries $tquery = undef; $key = 'track'; $value = $track; # falls thru to sync &tracktags_makearray; } if ($opts_can_set{$key} || # we CAN set read-only variables during initialization ($multi_module_mode == -1 && $valid{$key})) { if (length($value) > 1023) { # can't transmit this in a packet print $stdout "*** value too long\n"; return 1; } elsif ($opts_boolean{$key} && $value ne '0' && $value ne '1') { print $stdout "*** 0|1 only (boolean): $key\n"; return 1; } elsif ($opts_urls{$key} && $value !~ m#^(http|https|gopher)://#) { print $stdout "*** must be valid URL: $key\n"; return 1; } else { KEYAGAIN: $$key = $value; print $stdout "*** changed: $key => $$key\n" if ($interactive || $verbose); # handle special values &generate_ansi if ($key eq 'ansi' || $key =~ /^colour/); &generate_shortdomain if ($key eq 'shorturl'); &tracktags_makearray if ($key eq 'track'); &filter_compile if ($key eq 'filter'); ¬ify_compile if ($key eq 'notifies'); &list_compile if ($key eq 'lists'); &filterflags_compile if ($key eq 'filterflags'); $filterrts_sub = &filteruserlist_compile( $filterrts_sub, $value) if ($key eq 'filterrts'); $filterusers_sub = &filteruserlist_compile( $filterusers_sub,$value) if ($key eq 'filterusers'); $filteratonly_sub = &filteruserlist_compile( $filteratonly_sub, $value) if ($key eq 'filteratonly'); &filterats_compile if ($key eq 'filterats'); # transmit to background process sync-ed values if ($opts_sync{$key}) { &synckey($key, $value, $interactive); } if ($key eq 'superverbose') { if ($value eq '0') { $key = 'verbose'; $value = $supreturnto; goto KEYAGAIN; } $supreturnto = $verbose; } # parse showusername if ($key eq 'showusername') { if ($value eq '1') { $showusername = 1; } } } # virtual keys } elsif ($key eq 'tquery') { my $ivalue = &tracktags_tqueryurlify($value); if (length($ivalue) >= $linelength) { print $stdout "*** custom query is too long (encoded: $ivalue)\n"; return 1; } else { $tquery = $value; &synckey($key, $ivalue, $interactive); } } elsif ($valid{$key}) { print $stdout "*** read-only, must change on command line: $key\n"; return 1; } else { print $stdout "*** not a valid option or setting: $key\n"; return 1; } return 0; } sub synckey { my $key = shift; my $value = shift; my $interactive = 0+shift; my $commchar = ($interactive) ? '=' : '+'; print $stdout "*** (transmitting to background)\n" if ($interactive || $verbose); return if (!$child); kill $SIGUSR2, $child if ($child); print C (substr("${commchar}$key ", 0, 19) . "\n"); print C (substr(($value . $space_pad), 0, $packet_length)); sleep 1; } # getter for internal variables. right now this just returns the variable by # name and a couple virtuals, but in the future this might be expanded. sub getvariable { my $key = shift; if ($valid{$key}) { return $$key; } if ($key eq 'effpause' || $key eq 'rate_limit_rate' || $key eq 'rate_limit_left') { my $value; kill $SIGUSR2, $child if ($child); print C (substr("?$key ", 0, 19) . "\n"); sysread(W, $value, $packet_length); $value =~ s/\s+$//; return $value; } return undef; } # compatibility stub for extensions calling the old wraptime sub wraptime { return &$wraptime(@_); } #### url management (/url, /short) #### sub generate_shortdomain { my $x; my $y; undef $shorturldomain; ($shorturl =~ m#^http://([^/]+)/#) && ($x = $1); # chop off any leading hostname stuff (like api., etc.) while(1) { $y = $x; $x =~ s/^[^\.]*\.//; if ($x !~ /\./) { # a cut too far $shorturldomain = "http://$y/"; last; } } print $stdout "-- warning: couldn't parse shortener service\n" if (!length($shorturldomain)); } sub openurl { my $comm = $urlopen; my $url = shift; $url = "http://gopher.floodgap.com/gopher/gw?".&url_oauth_sub($url) if ($url =~ m#^gopher://# && $comm !~ /^[^\s]*lynx/); $urlshort = $url; $comm =~ s/\%U/'$url'/g; print $stdout "($comm)\n"; system("$comm"); } sub urlshorten { my $url = shift; my $rc; my $cl; $url = "http://gopher.floodgap.com/gopher/gw?".&url_oauth_sub($url) if ($url =~ m#^gopher://#); return $url if ($url =~ /^$shorturldomain/i); # stop loops $url = &url_oauth_sub($url); $cl = "$simple_agent \"${shorturl}$url\""; print $stdout "$cl\n" if ($superverbose); chomp($rc = `$cl`); if ($rc =~ m#^https?://#) { return $rc } else { print $stdout "ERROR: " . "$rc\n"; return undef } } ##### optimizers -- these compile into an internal format ##### # utility routine for tquery support sub tracktags_tqueryurlify { my $value = shift; $value =~ s/([^ a-z0-9A-Z_])/"%".unpack("H2",$1)/eg; $value =~ s/\s/+/g; $value = "q=$value" if ($value !~ /^q=/); return $value; } # tracking subroutines # run when a string is passed sub tracktags_makearray { @tracktags = (); $track =~ s/^'//; $track =~ s/'$//; $track = lc($track); if (!length($track)) { @trackstrings = (); return; } my $k; my $l = ''; my $q = 0; my %w; my (@ptags) = split(/\s+/, $track); # filter duplicates and merge quoted strings foreach $k (@ptags) { if ($q && $k =~ /"$/) { # this has to be first $l .= " $k"; $q = 0; } elsif ($k =~ /^"/ || $q) { $l .= (length($l)) ? " $k" : $k; $q = 1; next; } else { $l = $k; } if ($w{$l}) { print $stdout "-- warning: dropping duplicate track term \"$l\"\n"; } elsif (uc($l) eq 'OR' || uc($l) eq 'AND') { print $stdout "-- warning: dropping unnecessary logical op \"$l\"\n"; } else { $w{$l} = 1; push(@tracktags, $l); } $l = ''; } print $stdout "-- warning: syntax error, missing quote?\n" if ($q); $track = join(' ', @tracktags); &tracktags_compile; } # run when array is altered (based on @kellyterryjones' code) sub tracktags_compile { @trackstrings = (); return if (!scalar(@tracktags)); my $k; my $l = ''; # need to limit track tags to a certain number of pieces TAGBAG: foreach $k (@tracktags) { if (length($k) > 130) { # I mean, really print $stdout "-- warning: track tag \"$k\" is TOO LONG\n"; next TAGBAG; } if (length($l)+length($k) > 150) { # balance of size/querytime push(@trackstrings, "q=".&url_oauth_sub($l)); $l = ''; } $l = (length($l)) ? "${l} OR ${k}" : "${k}"; } push(@trackstrings, "q=".&url_oauth_sub($l)) if (length($l)); } # notification multidispatch sub notifytype_dispatch { return if (!scalar(@notifytypes)); my $nt; foreach $nt (@notifytypes) { &$nt(@_); } } # notifications compiler sub notify_compile { if ($notifies) { my $w; undef %notify_list; foreach $w (split(/\s*,\s*/, $notifies)) { $notify_list{$w} = 1; } $notifies = join(',', keys %notify_list); } } # lists compiler # we don't check the validity of lists here; /liston and /listoff do that. sub list_compile { my @oldlistlist = @listlist; my %already; undef @listlist; if ($lists) { my $w; my $u; my $l; foreach $w (split(/\s*,\s*/, $lists)) { $w =~ s/^@//; if ($w =~ m#/#) { ($u, $l) = split(m#\s*/\s*#, $w, 2); } else { $l = $w; } if (!length($u) && $anonymous) { print $stdout "*** must use fully specified lists when anonymous\n"; @listlist = @oldlistlist; return 0; } $u ||= $whoami; if ($l =~ m#/#) { print $stdout "*** syntax error in list $u/$l\n"; @listlist = @oldlistlist; return 0; } if ($already{"$u/$l"}++) { print $stdout "*** duplicate list $u/$l ignored\n"; } else { push(@listlist, [ $u, $l ]); } } $lists = join(',', keys %already); } return 1; } # -filterflags compiler (replaces old -filter syntax) sub filterflags_compile { my $s = $filterflags; undef %filter_attribs; $s =~ s/^\s*['"]?\s*//; $s =~ s/\s*['"]?\s*$//; return if (!length($s)); %filter_attribs = map { $_ => 1 } split(/\s*,\s*/, $s); } # -filterrts and -filterusers compiler. these simply use a list of usernames, # so they are fast and the same code suffices. emit code to compile that # just is one if-expression after another. sub filteruserlist_compile { my $old = shift; my $s = shift; undef $k; $s =~ s/^\s*['"]?\s*//; $s =~ s/\s*['"]?\s*$//; return $k if (!length($s)); my @us = map { $k=lc($_); "\$sn eq '$k'" } split(/\s*,\s*/, $s); my $uus = join(' || ', @us); my $uuus = <<"EOF"; \$k = sub { my \$sn = shift; return 1 if ($uus); return 0; }; EOF # print $stdout $uuus; eval $uuus; if (!defined($k)) { print $stdout "** bogus name in user list (error = $@)\n"; return $old; } return $k; } # -filterats compiler. this takes a list of usernames and then compiles a # whole bunch of regexes. sub filterats_compile { undef $filterats_c; my $s = $filterats; $s =~ s/^\s*['"]?\s*//; $s =~ s/\s*['"]?\s*$//; return 1 if (!length($s)); # undef my @us = map { $k=lc($_); "\$x=~/\\\@$k\\b/i" } split(/\s*,\s*/, $s); my $uus = join(' || ', @us); my $uuus = <<"EOF"; \$filterats_c = sub { my \$x = shift; return 1 if ($uus); return 0; }; EOF # print $stdout $uuus; eval $uuus; if (!defined($filterats_c)) { print $stdout "** bogus name in user list (error = $@)\n"; return 0; } return 1; } # -filter compiler. this is the generic case. sub filter_compile { undef %filter_attribs unless (length($filterflags)); undef $filter_c; if (length($filter)) { my $tfilter = $filter; $tfilter =~ s/^['"]//; $tfilter =~ s/['"]$//; # note attributes (compatibility) while ($tfilter =~ s/^([a-z]+),//) { my $atkey = $1; $filter_attribs{$atkey}++; print $stdout "** $atkey filter parameter should be in -filterflags\n"; } my $b = <<"EOF"; \$filter_c = sub { local \$_ = shift; return ($tfilter); }; EOF #print $b; eval $b; if (!defined($filter_c)) { print $stdout ("** syntax error in your filter: $@\n"); return 0; } } return 1; } #### common system subroutines follow #### sub updatecheck { my $vcheck_url = "https://raw.githubusercontent.com/oysttyer/oysttyer/master/version_check.txt"; my $vrlcheck_url = "http://www.floodgap.com/software/ttytter/01readlin.txt"; my $update_url = shift; my $vs = ''; my $vvs; my $tverify; my $inversion; my $bversion; my $rcnum; my $download; my $maj; my $min; my $s1, $s2, $s3; my $update_trlt = undef; if ($termrl && $termrl->ReadLine eq 'Term::ReadLine::TTYtter') { my $trlv = $termrl->Version; print $stdout "-- checking Term::ReadLine::TTYtter version: $vrlcheck_url\n"; $vvs = `$simple_agent $vrlcheck_url`; print $stdout "-- server response: $vvs\n" if ($verbose); ($vvs, $s1, $s2, $s3) = split(/--__--\n/s, $vvs); $s1 = undef if ($s1 !~ /^\*/) ; $s2 = undef if ($s2 !~ /^\*/) ; $s3 = undef if ($s3 !~ /^\*/) ; chomp($vvs); # right now we're only using $inversion (no betas/rcs). ($tverify, $inversion, $bversion, $rcnum, $download, $bdownload) = split(/;/, $vvs, 6); if ($tverify ne 'trlt') { $vs .= "-- warning: unable to verify Term::ReadLine::TTYtter version\n"; } else { if ($trlv < 0+$inversion) { $vs .= "** NEW Term::ReadLine::TTYtter VERSION AVAILABLE: $inversion **\n" . "** GET IT: $download\n"; $update_trlt = $download; } else { $vs .= "-- your version of Term::ReadLine::TTYtter is up to date ($trlv)\n"; } } } print $stdout "-- checking oysttyer 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 'oysttyer') { $vs .= "-- warning: unable to verify oysttyer version\n"; } else { if ($my_version_string eq $bversion) { $vs .= "** REMINDER: you are using a beta version (${my_version_string}b${oysttyer_RC_NUMBER})\n"; $vs .= "** NEW oysttyer RELEASE CANDIDATE AVAILABLE: build $rcnum **\n" . "** get it: $bdownload\n$s2" if ($oysttyer_RC_NUMBER < $rcnum); $vs .= "** (this is the most current beta)\n" if ($oysttyer_RC_NUMBER == $rcnum); $vs .= "$s1$s3"; if ($oysttyer_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 && $oysttyer_RC_NUMBER) { $vs .= "** FINAL oysttyer 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+$oysttyer_VERSION < $maj || (0+$oysttyer_VERSION == $maj && $oysttyer_PATCH_VERSION < $min)) { $vs .= "** NEWER oysttyer 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+$oysttyer_VERSION > $maj || (0+$oysttyer_VERSION == $maj && $oysttyer_PATCH_VERSION > $min)) { $vs .= "** unable to identify your version of oysttyer\n$s1"; } else { $vs .= "-- your version of oysttyer is up to date ($inversion)\n$s1"; } } # if we got this far, then there is no oysttyer 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; $vs .= "-- your version of oysttyer is ($my_version_string)\n"; return $vs; } sub generate_otabcomp { if (scalar(@j = keys(%readline_completion))) { # print optimized readline. include all that we # manually specified, plus/including top @s, total 10. @keys = sort { $readline_completion{$b} <=> $readline_completion{$a} } @j; $factor = $readline_completion{$keys[0]}; foreach(keys %original_readline) { $readline_completion{$_} += $factor; } print $stdout "*** optimized readline:\n"; @keys = sort { $readline_completion{$b} <=> $readline_completion{$a} } keys %readline_completion; @keys = @keys[0..14] if (scalar(@keys) > 15); print $stdout "-readline=\"@keys\"\n"; } } sub end_me { exit; } # which falls through to, via END, ... sub killkid { # for streaming assistance if ($child) { print $stdout "\n\ncleaning up.\n"; kill $SIGHUP, $child; # warn it about shutdown if (length($track)) { print $stdout "*** you were tracking:\n"; print $stdout "-track='$track'\n"; } if (length($filter)) { print $stdout "*** your current filter expression:\n"; print $stdout "-filter='$filter'\n"; } &generate_otabcomp; sleep 2 if ($dostream); kill 9, $curlpid if ($curlpid); kill 9, $child; } &$shutdown unless (!$shutdown); } sub rmlock { return unless (($lockf) && (-f $lockf)); return unless (open(L, "<$lockf")); while () { chomp(); next unless (/^\d+$/); if ($_ == $$) { unlink($lockf); last; } } close(L); } sub generate_ansi { my $k; $BLUE = ($ansi) ? "${ESC}[34;1m" : ''; $RED = ($ansi) ? "${ESC}[31;1m" : ''; $GREEN = ($ansi) ? "${ESC}[32;1m" : ''; $YELLOW = ($ansi) ? "${ESC}[33m" : ''; $MAGENTA = ($ansi) ? "${ESC}[35m" : ''; $CYAN = ($ansi) ? "${ESC}[36m" : ''; $EM = ($ansi) ? "${ESC}[1m" : ''; $UNDER = ($ansi) ? "${ESC}[4m" : ''; $OFF = ($ansi) ? "${ESC}[0m" : ''; foreach $k (qw(prompt me dm reply warn search list default)) { ${"colour$k"} = uc(${"colour$k"}); if (!defined($${"colour$k"})) { print $stdout "-- warning: bogus colour '".${"colour$k"}."'\n"; } else { eval("\$CC$k = \$".${"colour$k"}); } } eval '$termrl->hook_use_ansi' if ($termrl); } # always POST sub postjson { my $url = shift; my $postdata = shift; # add _method=DELETE for delete my $data; # this is copied mostly verbatim from grabjson chomp($data = &backticks($baseagent, '/dev/null', undef, $url, $postdata, 0, @wend)); my $k = $? >> 8; $data =~ s/[\r\l\n\s]*$//s; $data =~ s/^[\r\l\n\s]*//s; if (!length($data) || $k == 28 || $k == 7 || $k == 35) { &$exception(1, "*** warning: timeout or no data\n"); return undef; } # old non-JSON based error reporting code still supported if ($data =~ /^\[?\]?/i || $data =~ /^<\??xml\s+/) { print $stdout $data if ($superverbose); if (&is_fail_whale($data)) { &$exception(2, "*** warning: Twitter Fail Whale\n"); } else { &$exception(2, "*** warning: Twitter error message received\n" . (($data =~ /Twitter:\s*([^<]+)</) ? "*** \"$1\"\n" : '')); } return undef; } if ($data =~ /^rate\s*limit/i) { print $stdout $data if ($superverbose); &$exception(3, "*** warning: exceeded API rate limit for this interval.\n" . "*** no updates available until interval ends.\n"); return undef; } if ($k > 0) { &$exception(4, "*** warning: unexpected error code ($k) from user agent\n"); return undef; } # handle things like 304, or other things that look like HTTP # error codes if ($data =~ m#^HTTP/\d\.\d\s+(\d+)\s+#) { $code = 0+$1; print $stdout $data if ($superverbose); # 304 is actually a cop-out code and is not usually # returned, so we should consider it a non-fatal error if ($code == 304 || $code == 200 || $code == 204) { &$exception(1, "*** warning: timeout or no data\n"); return undef; } &$exception(4, "*** warning: unexpected HTTP return code $code from server\n"); return undef; } # test for error/warning conditions with trivial case if ($data =~ /^\s*\{\s*(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1/s || $data =~ /(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1\}/s) { print $stdout $data if ($superverbose); &$exception(2, "*** warning: server $2 message received\n" . "*** \"$3\"\n"); return undef; } return &parsejson($data); } # always GET sub grabjson { my $data; my $url = shift; my $last_id = shift; my $is_anon = shift; my $count = shift; my $tag = shift; my $do_entities = shift; my $kludge_search_api_adjust = 0; my $my_json_ref = undef; # durrr hat go on foot my $i; my $tdata; my $seed; #undef $/; $data = <STDIN>; # we may need to sort our args for more flexibility here. my @xargs = (); my $i = index($url, "?"); if ($i > -1) { # throw an error if "?" is at the end. push(@xargs, split(/\&/, substr($url, ($i+1)))); $url = substr($url, 0, $i); } # Use the extended mode that doesn't count URLs, etc in the character count push(@xargs, "tweet_mode=extended") if ($extended); # count needs to be removed for the default case due to show, etc. push(@xargs, "count=$count") if ($count); # timeline control. this speeds up parsing since there's less data. # can't use skip_user: no SN push (@xargs, "since_id=${last_id}") if ($last_id); # request entities, which should be supported everywhere now push (@xargs, "include_entities=1") if ($do_entities); my $resource = (scalar(@xargs)) ? [ $url, join('&', sort @xargs) ] : $url; chomp($data = &backticks($baseagent, '/dev/null', undef, $resource, undef, $is_anon + $anonymous, @wind)); my $k = $? >> 8; $data =~ s/[\r\l\n\s]*$//s; $data =~ s/^[\r\l\n\s]*//s; if (!length($data) || $k == 28 || $k == 7 || $k == 35) { &$exception(1, "*** warning: timeout or no data\n"); return undef; } # old non-JSON based error reporting code still supported if ($data =~ /^\[?\]?<!DOCTYPE\s+html/i || $data =~ /^(Status:\s*)?50[0-9]\s/ || $data =~ /^<html>/i || $data =~ /^<\??xml\s+/) { print $stdout $data if ($superverbose); if (&is_fail_whale($data)) { &$exception(2, "*** warning: Twitter Fail Whale\n"); } else { &$exception(2, "*** warning: Twitter error message received\n" . (($data =~ /<title>Twitter:\s*([^<]+)</) ? "*** \"$1\"\n" : '')); } return undef; } if ($data =~ /^rate\s*limit/i) { print $stdout $data if ($superverbose); &$exception(3, "*** warning: exceeded API rate limit for this interval.\n" . "*** no updates available until interval ends.\n"); return undef; } if ($k > 0) { &$exception(4, "*** warning: unexpected error code ($k) from user agent\n"); return undef; } # handle things like 304, or other things that look like HTTP # error codes if ($data =~ m#^HTTP/\d\.\d\s+(\d+)\s+#) { $code = 0+$1; print $stdout $data if ($superverbose); # 304 is actually a cop-out code and is not usually # returned, so we should consider it a non-fatal error if ($code == 304 || $code == 200 || $code == 204) { &$exception(1, "*** warning: timeout or no data\n"); return undef; } &$exception(4, "*** warning: unexpected HTTP return code $code from server\n"); return undef; } # test for error/warning conditions with trivial case if ($data =~ /^\s*\{\s*(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1/s || $data =~ /(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1\}/s) { print $stdout $data if ($superverbose); &$exception(2, "*** warning: server $2 message received\n" . "*** \"$3\"\n"); return undef; } # if wrapped in statuses object, unwrap it # (and tag it to do more later) if ($data =~ s/^\s*(\{)\s*['"]statuses['"]\s*:\s*(\[.*\]).*$/$2/isg) { $kludge_search_api_adjust = 1; } $my_json_ref = &parsejson($data); # normalize the data into a standard form. # single tweets such as from statuses/show aren't arrays, so # we special-case for them. if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' && ((0+$my_json_ref->{'id'}) || length($my_json_ref->{'id_str'}))) { $my_json_ref = &normalizejson($my_json_ref); } if (defined($my_json_ref) && ref($my_json_ref) eq 'ARRAY') { foreach $i (@{ $my_json_ref }) { $i = &normalizejson($i,$kludge_search_api_adjust,$tag); } } $laststatus = 0; return $my_json_ref; } # convert t.co into actual URLs. separate from normalizejson because other # things need this. modified from /entities. sub destroy_all_tco { my $hash = shift; return $hash if ($notco); my $v; my $type; # Twitter puts entities in multiple fields. # TODO: For old-style retweets should manipulate and revert back to t.co links # Note: The search api does not include extended_entities # Do extended first to get video urls, otherwise we'll just get a thumbnail my (@entities_fields) = ($hash->{extended_entities}, $hash->{entities}); if ($extended && exists $hash->{extended_tweet}) { push @entities_fields, $hash->{extended_tweet}->{entities}; push @entities_fields, $hash->{extended_tweet}->{extended_entities}; } foreach my $entities_field (@entities_fields) { foreach $type (qw(media urls)) { my $urls; my $u1; my $array = $entities_field->{$type}; next if (!defined($array) || ref($array) ne 'ARRAY'); foreach $entry (@{ $array }) { next if (!defined($entry) || ref($entry) ne 'HASH'); next if (!length($entry->{'url'}) || (!length($entry->{'expanded_url'}) && !length($entry->{'media_url'}))); # There is one canonical url even for multiple media (picture) entries $u1 = $u1 || quotemeta($entry->{'url'}); if (defined($entry->{'video_info'})) { # Need to look for content_type, prefer mp4 since that's more # broadly viewable, but accept m3u8 because that's where # Twitter is going with videos. my $videourl = ''; #foreach $variant (@{ $entry->{'video_info'}->{'variants'} }) { # if ($variant->{'content_type'} =~ /mp4/) { # $videourl = $variant->{'url'}; # last; # } elsif (($variant->{'content_type'} =~ /x-mpegURL/) || (! $videourl)) { # $videourl = $variant->{'url'}; # } #} my %mp4_variants = (); my %m3u8_variants = (); my @videos = (); foreach $variant (@{ $entry->{'video_info'}->{'variants'} }) { $mp4_variants{$variant->{'url'}} = $variant if ($variant->{'content_type'} =~ /mp4/ ); $m3u8_variants{$variant->{'url'}} = $variant if ($variant->{'content_type'} =~ /x-mpegURL/ ); } if ( %mp4_variants ) { @videos = sort { $mp4_variants{$a}->{bitrate} <=> $mp4_variants{$b}->{bitrate} } keys %mp4_variants; } else { @videos = sort { $m3u8_variants{$a}->{bitrate} <=> $m3u8_variants{$b}->{bitrate} } keys %m3u8_variants; } if ( $video_bitrate eq 'highest' ) { $videourl = $videos[-1]; } else { $videourl = $videos[0]; } $urls = $urls . " " . $videourl; $urls = strim($urls); } else { my $tempurls = $entry->{'media_url_https'} || $entry->{'media_url'} || $entry->{'expanded_url'}; $urls = $urls . " " . $tempurls; $urls = strim($urls); } if ($type eq 'urls') { # Need to replace now and reset urls if ($urls ne "") { # Let's play safe and only replace the tco if we have something to replace it with $hash->{'text'} =~ s/$u1/$urls/; } $urls = ""; $u1 = ""; } } if ($type eq 'media') { # Then we need to replace outside of the above loop since one tco for all media entries if ($urls ne "") { # Let's play safe and only replace the tco if we have something to replace it with $hash->{'text'} =~ s/$u1/$urls/; } } } } return $hash; } # takes a tweet structure and normalizes it according to settings. # what this currently does is the following gyrations: # - if there is no id_str, see if we can convert id into one. if # there is loss of precision, warn the user. same for # in_reply_to_status_id_str. # - if the source of this JSON data source is the Search API, translate # its fields into the standard API. # - if the calling function has specified a tag, tag the tweets, since # we're iterating through them anyway. the tag should be a hashref payload. # - if the tweet is an newRT, unwrap it so that the full tweet text is # revealed (unless -nonewrts). # - if this appears to be a tweet, put in a stub geo hash if one does # not yet exist. # - if coordinates are flat string 'null', turn into a real null. # - if $extended is on and the tweet has an extended_tweet field, promote # full_text from extended_tweet to the top level # one day I would like this code to go the hell away. sub normalizejson { my $i = shift; my $kludge_search_api_adjust = shift; my $tag = shift; my $rt; # tag the tweet $i->{'tag'} = $tag if (defined($tag)); # id -> id_str if needed if (!length($i->{'id_str'})) { my $k = "" + (0 + $i->{'id'}); if ($k !~ /[eE][+-]/) { $i->{'id_str'} = $k; } else { # desperately try to convert $k =~ s/[eE][+-]\d+$//; $k =~ s/\.//g; # this is a hack, so we warn. &$exception(13, "*** impending doom: ID overflows Perl precision; stubbed to $k\n"); $i->{'id_str'} = $k; } } # irtsid -> irtsid_str (if there is one) if (!length($i->{'in_reply_to_status_id_str'}) && $i->{'in_reply_to_status_id'}) { my $k = "" + (0+$i->{'in_reply_to_status_id'}); if ($k !~ /[eE][+-]/) { $i->{'in_reply_to_status_id_str'} = $k; } else { # desperately try to convert $k =~ s/[eE][+-]\d+$//; $k =~ s/\.//g; # this is a hack, so we warn. &$exception(13, "*** impending doom: IRT-ID overflows Perl precision; stubbed to $k\n"); $i->{'in_reply_to_status_id_str'} = $k; } } # normalize geo. if this has a source and it has a # favorited, then it is probably a tweet and we will # add a stub geo hash if one doesn't exist yet. if ($kludge_search_api_adjust || ($i->{'liked'} && $i->{'source'})){ $i = &fix_geo_api_data($i); } # hooray! this just tags it if ($kludge_search_api_adjust) { $i->{'class'} = "search"; } # normalize extended tweets # We probably ought to handle the other fields in extended_tweet, # but this will also all go away once compatibility mode does if ($extended) { if (exists $i->{'extended_tweet'}) { $i->{'text'} = $i->{'extended_tweet'}->{'full_text'}; } elsif (exists $i->{'full_text'}) { $i->{'text'} = $i->{'full_text'}; } } # normalize newRTs # if we get newRTs with -nonewrts, oh well if (!$nonewrts && ($rt = $i->{'retweeted_status'})) { # reconstruct the RT in a "canonical" format # without truncation, but detco it first if ($extended) { if (exists $rt->{'extended_tweet'}) { $rt->{'text'} = $rt->{'extended_tweet'}->{'full_text'}; } elsif (exists $rt->{'full_text'}) { $rt->{'text'} = $rt->{'full_text'}; } } $rt = &destroy_all_tco($rt); $rt = &fix_geo_api_data($rt); $i->{'retweeted_status'} = $rt; $i->{'text'} = "RT \@$rt->{'user'}->{'screen_name'}" . ': ' . $rt->{'text'}; #Nested quote tweets, since displaying those if ($qt = $i->{'retweeted_status'}->{'quoted_status'}) { if ($extended) { if (exists $qt->{'extended_tweet'}) { $qt->{'text'} = $qt->{'extended_tweet'}->{'full_text'}; } elsif (exists $qt->{'full_text'}) { $qt->{'text'} = $qt->{'full_text'}; } } $qt = &destroy_all_tco($qt); $qt = &fix_geo_api_data($qt); $i->{'retweeted_status'}->{'quoted_status'} = $qt; } } # normalize quote tweets if ($qt = $i->{'quoted_status'}) { if ($extended) { if (exists $qt->{'extended_tweet'}) { $qt->{'text'} = $qt->{'extended_tweet'}->{'full_text'}; } elsif (exists $qt->{'full_text'}) { $qt->{'text'} = $qt->{'full_text'}; } } $qt = &destroy_all_tco($qt); $qt = &fix_geo_api_data($qt); $i->{'quoted_status'} = $qt; } return &destroy_all_tco($i); } # process the JSON data ... simplemindedly, because I just write utter crap, # am not a professional programmer, and don't give a flying fig whether # kludges suck or no. this used to be part of grabjson, but I split it out. sub parsejson { my $data = shift; my $my_json_ref = undef; # durrr hat go on foot my $i; my $tdata; my $seed; my $bbqqmask; my $ddqqmask; my $ssqqmask; # test for single logicals return { 'ok' => 1, 'result' => (($1 eq 'true') ? 1 : 0), 'literal' => $1, } if ($data =~ /^['"]?(true|false)['"]?$/); # first isolate escaped backslashes with a unique sequence. $bbqqmask = "BBQQ"; $seed = 0; $seed++ while ($data =~ /$bbqqmask$seed/); $bbqqmask .= $seed; $data =~ s/\\\\/$bbqqmask/g; # next isolate escaped quotes with another unique sequence. $ddqqmask = "DDQQ"; $seed = 0; $seed++ while ($data =~ /$ddqqmask$seed/); $ddqqmask .= $seed; $data =~ s/\\\"/$ddqqmask/g; # then turn literal ' into another unique sequence. you'll see # why momentarily. $ssqqmask = "SSQQ"; $seed = 0; $seed++ while ($data =~ /$ssqqmask$seed/); $ssqqmask .= $seed; $data =~ s/\'/$ssqqmask/g; # here's why: we're going to turn doublequoted strings into single # quoted strings to avoid nastiness like variable interpolation. $data =~ s/\"/\'/g; # and then we're going to turn the inline ones all back except # ssqq, which we'll do last so that our syntax checker still works. $data =~ s/$bbqqmask/\\\\/g; $data =~ s/$ddqqmask/"/g; print $stdout "$data\n" if ($superverbose); # trust, but verify. I'm sure twitter wouldn't send us malicious # or bogus JSON, but one day this might talk to something that would. # in particular, need to make sure nothing in this will eval badly or # run arbitrary code. that would really suck! # first, generate a syntax tree. $tdata = $data; 1 while $tdata =~ s/'[^']*'//; # empty strings are valid too ... $tdata =~ s/-?[0-9]+\.?[0-9]*([eE][+-][0-9]+)?//g; # have to handle floats *and* their exponents $tdata =~ s/(true|false|null)//g; $tdata =~ s/\s//g; print $stdout "$tdata\n" if ($superverbose); # now verify the syntax tree. # the remaining stuff should just be enclosed in [ ], and only {}:, # for example, imagine if a bare semicolon were in this ... if ($tdata !~ s/^\[// || $tdata !~ s/\]$// || $tdata =~ /[^{}:,]/) { $tdata =~ s/'[^']*$//; # cut trailing strings if (($tdata =~ /^\[/ && $tdata !~ /\]$/) || ($tdata =~ /^\{/ && $tdata !~ /\}$/)) { # incomplete transmission &$exception(10, "*** JSON warning: connection cut\n"); return undef; } # it seems that :[], or :[]} should be accepted as valid in the syntax tree # since identica uses this as possible for null properties # ,[], shouldn't be, etc. if ($tdata =~ /(^|[^:])\[\]($|[^},])/) { # oddity &$exception(11, "*** JSON warning: null list\n"); return undef; } # at this point all we should have are structural elements. # if something other than JSON structure is visible, then # the syntax tree is mangled. don't try to run it, it # might be unsafe. this exception was formerly uniformly # fatal. it is now non-fatal as of 2.1. if ($tdata =~ /[^\[\]\{\}:,]/) { &$exception(99, "*** JSON syntax error\n"); print $stdout <<"EOF" if ($verbose); --- data received --- $data --- syntax tree --- $tdata --- JSON PARSING ABORTED DUE TO SYNTAX TREE FAILURE -- EOF return undef; } } # syntax tree passed, so let's turn it into a Perl reference. # have to turn colons into ,s or Perl will gripe. but INTELLIGENTLY! 1 while ($data =~ s/([^'])'\s*:\s*(true|false|null|\'|\{|\[|-?[0-9])/\1\',\2/); # finally, single quotes, just before interpretation. $data =~ s/$ssqqmask/\\'/g; # now somewhat validated, so safe (?) to eval() into a Perl struct eval "\$my_json_ref = $data;"; print $stdout "$data => $my_json_ref $@\n" if ($superverbose); # do a sanity check if (!defined($my_json_ref)) { &$exception(99, "*** JSON syntax error\n"); print $stdout <<"EOF" if ($verbose); --- data received --- $data --- syntax tree --- $tdata --- JSON PARSING FAILED -- $@ --- JSON PARSING FAILED -- EOF } return $my_json_ref; } sub fix_geo_api_data { my $ref = shift; $ref->{'geo'}->{'coordinates'} = undef if ($ref->{'geo'}->{'coordinates'} eq 'null' || $ref->{'geo'}->{'coordinates'}->[0] eq '' || $ref->{'geo'}->{'coordinates'}->[1] eq ''); $ref->{'geo'}->{'coordinates'} ||= [ "undef", "undef" ]; return $ref; } sub is_fail_whale { # is this actually the dump from a fail whale? my $data = shift; return ($data =~ m#<title>Twitter.+Over.+capacity.*#i || $data =~ m#[\r\l\n\s]*DB_DataObject Error: Connect failed#s); } # {'errors':[{'message':'Rate limit exceeded','code':88}]} sub is_json_error { # is this actually a JSON error message? if so, extract it my $data = shift; if ($data =~ /(['"])(warning|errors?)\1\s*:\s*/s) { if ($data =~ /^\s*\{/s) { # JSON object? my $dref = &parsejson($data); print $stdout "*** is_json_error returning true\n" if ($verbose); # support 1.0 and 1.1 error objects return $dref->{'error'} if (length($dref->{'error'})); return $dref->{'errors'}->[0]->{'message'} if (length($dref->{'errors'}->[0]->{'message'})); return (split(/\\n/, $dref->{'errors'}))[0] if(length($dref->{'errors'})); } return $data; } return undef; } sub backticks { # more efficient/flexible backticks system my $comm = shift; my $rerr = shift; my $rout = shift; my $resource = shift; my $data = shift; my $dont_do_auth = shift; my $buf = ''; my $undersave = $_; my $pid; my $args; ($comm, $args, $data) = &$stringify_args($comm, $resource, $data, $dont_do_auth, @_); print $stdout "$comm\n$args\n$data\n" if ($superverbose); if(open(BACTIX, '-|')) { while() { $buf .= $_; } close(BACTIX); $_ = $undersave; return $buf; # and $? is still in $? } else { $in_backticks = 1; &sigify(sub { die( "** user agent not honouring timeout (caught by sigalarm)\n"); }, qw(ALRM)); alarm 120; # this should be sufficient if (length($rerr)) { close(STDERR); open(STDERR, ">$rerr"); } if (length($rout)) { close(STDOUT); open(STDOUT, ">$rout"); } if(open(FRONTIX, "|$comm")) { print FRONTIX "$args\n"; print FRONTIX "$data" if (length($data)); close(FRONTIX); } else { die( "backticks() failure for $comm $rerr $rout @_: $!\n"); } $rv = $? >> 8; exit $rv; } } sub wherecheck { my ($prompt, $filename, $fatal) = (@_); my (@paths) = split(/\:/, $ENV{'PATH'}); my $setv = ''; push(@paths, '/usr/bin'); # the usual place @paths = ('') if ($filename =~ m#^/#); # for absolute paths print $stdout "$prompt ... " unless ($silent); foreach(@paths) { if (-r "$_/$filename") { $setv = "$_/$filename"; 1 while $setv =~ s#//#/#; print $stdout "$setv\n" unless ($silent); last; } } if (!length($setv)) { print $stdout "not found.\n"; if ($fatal) { print $stdout $fatal; exit(1); } } return $setv; } sub screech { print $stdout "\n\n${BEL}${BEL}@_"; if ($is_background) { kill 9, $parent; kill 9, $$; } elsif ($child) { kill 9, $child; kill 9, $$; } die("death not achieved conventionally"); } # &in($x, @y) returns true if $x is a member of @y sub in { my $key = shift; my %mat = map { $_ => 1 } @_; return $mat{$key}; } sub descape { my $x = shift; my $mode = shift; $x =~ s#\\/#/#g; # try to do something sensible with unicode if ($mode) { # this probably needs to be revised $x =~ s/\\u([0-9a-fA-F]{4})/"&#" . hex($1) . ";"/eg; } else { # intermediate form if HTML entities get in $x =~ s/\&\#([0-9]+);/'\u' . sprintf("%04x", $1)/eg; $x =~ s/\\u202[89]/\\n/g; # canonicalize Unicode whitespace 1 while ($x =~ s/\\u(00[aA]0)/ /g); 1 while ($x =~ s/\\u(200[0-9aA])/ /g); 1 while ($x =~ s/\\u(20[25][fF])/ /g); if ($seven) { # known UTF-8 entities (char for char only) $x =~ s/\\u201[89]/\'/g; $x =~ s/\\u201[cCdD]/\"/g; # 7-bit entities (32-126) also ok $x =~ s/\\u00([2-7][0-9a-fA-F])/chr(((hex($1)==127)?46:hex($1)))/eg; # dot out the rest $x =~ s/\\u([0-9a-fA-F]{4})/./g; $x =~ s/[\x80-\xff]/./g; } else { # try to promote to UTF-8 &$utf8_decode($x); # Twitter uses UTF-16 for high code points, which # Perl's UTF-8 support does not like as surrogates. # try to decode these here; they are always back-to- # back surrogates of the form \uDxxx\uDxxx $x =~ s/\\u([dD][890abAB][0-9a-fA-F]{2})\\u([dD][cdefCDEF][0-9a-fA-F]{2})/&deutf16($1,$2)/eg; # decode the rest $x =~ s/\\u([0-9a-fA-F]{4})/chr(hex($1))/eg; $x = &uforcemulti($x); } $x =~ s/\"/"/g; $x =~ s/\'/'/g; $x =~ s/\</\/g; $x =~ s/\&/\&/g; } # TODO: Here it doesn't seem possible for us to distinguish between real newlines and the literal "\"s followed by "n"s that may have been sent and both will get replaced. But it would be nice to investigate this further. if ($newline eq "replace") { $x =~ s/\\n/$replacement_newline/sg; $x =~ s/\\r/$replacement_carriagereturn/sg; } elsif ($newline) { $x =~ s/\\n/\n/sg; $x =~ s/\\r//sg; } return $x; } # used by descape: turn UTF-16 surrogates into a Unicode character sub deutf16 { my $one = hex(shift); my $two = hex(shift); # subtract 55296 from $one to yield top ten bits $one -= 55296; # $d800 # subtract 56320 from $two to yield bottom ten bits $two -= 56320; # $dc00 # experimentally, Twitter uses this endianness below (we have no BOM) # see RFC 2781 4.3 return chr(($one << 10) + $two + 65536); } sub max { return ($_[0] > $_[1]) ? $_[0] : $_[1]; } sub min { return ($_[0] < $_[1]) ? $_[0] : $_[1]; } sub prolog { my $k = shift; return "" if (!scalar(@_)); my $l = shift; return (&$k($l) . &$k(@_)); } # this is mostly a utility function for /eval. it is a recursive descent # pretty printer. sub a { my $w; my $x; return '' if(scalar(@_) < 1); if(scalar(@_) > 1) { $x = "("; foreach $w (@_) { $x .= &a($w); } return $x."), "; } $w = shift; if(ref($w) eq 'SCALAR') { return "\\\"". $$w . "\", "; } if(ref($w) eq 'HASH') { my %m = %{ $w }; return "\n\t{".&prolog(\&a, %m)."}, "; } if(ref($w) eq 'ARRAY') { return "\n\t[".&prolog(\&a, @{ $w })."], "; } return "\"$w\", "; } sub ssa { return (scalar(@_) ? ("('" . join("', '", @_) . "')") : "NULL"); } sub strim { my $x=shift; $x=~ s/^\s+//; $x=~ s/\s+$//; return $x; } sub wwrap { return shift if (!$wrap); my $k; my $klop = ($wrap > 1) ? $wrap : ($ENV{'COLUMNS'} || 79); $klop--; # don't ask me why my $lop; my $buf = ''; my $string = shift; my $indent = shift; # for very first time with the prompt my $needspad = 0; my $stringpad = " " x 3; $indent += 4; # for the menu select string $lop = $klop - $indent; $lop -= $indent; W: while($k = length($string)) { $lop += $indent if ($lop < $klop); ($buf .= $string, last W) if ($k <= $lop && $string !~ /\n/); ($string =~ s/^\s*\n//) && ($buf .= "\n", $needspad = 1, next W); if ($needspad) { $string = " $string"; $needspad = 0; } # I don't know if people will want this, so it's commented out. #($string =~ s#^(http://[^\s]+)# #) && ($buf .= "$1\n", # next W); ($string =~ s/^(.{4,$lop})\s/ /) && ($buf .= "$1\n", next W); # i.e., at least one char, plus 3 space indent ($string =~ s/^(.{$lop})/ /) && ($buf .= "$1\n", next W); warn "-- pathologic string somehow failed wordwrap! \"$string\"\n"; return $buf; } 1 while ($buf =~ s/\n\n\n/\n\n/s); # mostly paranoia $buf =~ s/[ \t]+$//; return $buf; } # these subs look weird, but they're encoding-independent and run anywhere sub uforcemulti { # forces multi-byte interpretation by abusing Perl my $x = shift; return $x if ($seven); $x = "\x{263A}".$x; return pack("${pack_magic}H*", substr(unpack("${pack_magic}H*",$x),6)); } sub ulength { my @k; return (scalar(@k = unpack("${pack_magic}C*", shift))); } sub uhex { # URL-encode an arbitrary string, even UTF-8 # more versatile than the miniature one in &updatest my $k = ''; my $s = shift; &$utf8_encode($s); foreach(split(//, $s)) { my $j = unpack("H256", $_); while(length($j)) { $k .= '%' . substr($j, 0, 2); $j = substr($j, 2); } } return $k; } # for t.co # adapted from github.com/twitter/twitter-text-js/blob/master/twitter-text.js # this is very hard to get right, and I know there are edge cases. this first # one is designed to be quick and dirty because it needs to be fast more than # it needs to be accurate, since T:RL:T calls it a LOT. however, it can be # fooled, see below. sub fastturntotco { my $s = shift; my $w; # turn domain names into http urls. this should look at .com, .net, # .etc., but things like you.suck.too probably *should* hit this # filter. this uses the heuristic that a domain name over some limit # is probably not actually a domain name. ($s =~ s#\b(([a-zA-Z0-9-_]\.)+([a-zA-Z]){2,})\b#((length($w="$1")>45)?$w:"http://$w")#eg); # now turn all http and https URLs into t.co strings my $tco_string = 'X' x ( $tco_length - 13 ); ($s =~ s#\b(https?)://[a-zA-Z0-9-_]+[^\s]*?('|\\|\s|[\.;:,!\?]\s+|[\.;:,!\?]$|$)#https://t.co/${tco_string}\2#gi); return $s; } # slow t.co converter. this is for future expansion. sub turntotco { return &fastturntotco(shift); } sub ulength_tco { my $w = shift; return &ulength(($notco) ? $w : &turntotco($w)); } sub length_tco { my $w = shift; return length_newline(($notco) ? $w : &turntotco($w)); } sub length_newline { # Count length of a string, adjusting for sending newlines my $s = shift; my @count_of_newlines; my @count_of_liternal_newlines; # Count number of \n and \\n @count_of_newlines = ($s =~ /\\n/g); @count_of_literal_newlines = ($s =~ /\\\\n/g); # \n only count as one character so subtract one for each count # \\n only counts as two characters so subtract one for each count return length($s)-scalar(@count_of_newlines)-scalar(@count_of_literal_newlines); } # take a string and return up to $maxchars CHARS plus the rest. sub csplit { my ($orig_k, $autosplit, $maxchars) = @_; return &cosplit($orig_k, $autosplit, $maxchars, sub { return &length_tco(shift); }); } # take a string and return up to $linelength BYTES plus the rest. # usplit isn't used, but best change it as well sub usplit { my ($orig_k, $autosplit, $maxchars) = @_; return &cosplit($orig_k, $autosplit, $maxchars, sub { return &ulength_tco(shift); }); } sub cosplit { # this is the common code for &csplit and &usplit. # this is tricky because we don't want to split up UTF-8 sequences, so # we let Perl do the work since it internally knows where they end. my $orig_k = shift; my $autosplit = shift; my $maxchars = shift; my $lengthsub = shift; my $z; my @m; my $q; my $r; unless ($maxchars) { $maxchars = $linelength; } my $mode = ($autosplit eq 'char' || $autosplit eq 'cut') ? 1 : 0; $k = $orig_k; # optimize whitespace $k =~ s/^\s+//; $k =~ s/\s+$//; $k =~ s/\s+/ /g; $z = &$lengthsub($k); return ($k) if ($z <= $maxchars); # also handles the trivial case # this needs to be reply-aware, so we put @'s at the beginning of # the second half too (and also Ds for DMs) $r .= $1 while ($k =~ s/^(\@[^\s]+\s)\s*// || $k =~ s/^(D\s+[^\s]+\s)\s*//); # we have r/a, so while $k = "$r$k"; my $i = $maxchars; $i-- while(($z = &$lengthsub($q = substr($k, 0, $i))) > $maxchars); $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, "cut", $lengthsub)) #Don't need to use length_newline here becausen only checking for whether zero length is true if (!length($q) && !$mode); # it totally failed. fall back on charsplit. if (&$lengthsub($q) < $maxchars) { $m =~ s/^\s+//; return($q, "$r$m") } } ($q =~ s/\s+([^\s]+)$//) && ($m = "$1$m"); #Don't need to use length_newline here because only checking for whether zero length is true return (&cosplit($orig_k, "cut", $lengthsub)) if (!length($q) && !$mode); # it totally failed. fall back on charsplit. return ($q, "$r$m"); } ### OAuth methods, including our own homegrown SHA-1 and HMAC ### ### no Digest:* required! ### ### these routines are not byte-safe and need a use bytes; before you call ### # this is a modified, deciphered and deobfuscated version of the famous Perl # one-liner SHA-1 written by John Allen. hope he doesn't mind. sub sha1 { my $string = shift; print $stdout "string length: @{[ length($string) ]}\n" if ($showwork); my $constant = "D9T4C`>_-JXF8NMS^\$#)4=L/2X?!:\@GF9;MGKH8\\;O-S*8L'6"; my @A = unpack('N*', unpack('u', $constant)); my @K = splice(@A, 5, 4); my $M = sub { # 64-bit warning my $x; my $m; ($x = pop @_) - ($m=4294967296) * int($x / $m); }; my $L = sub { # 64-bit warning my $n = pop @_; my $x; ((($x = pop @_) << $n) | ((2 ** $n - 1) & ($x >> 32 - $n))) & 4294967295; }; my $l = ''; my $r; my $a; my $b; my $c; my $d; my $e; my $us; my @nuA; my $p = 0; $string = unpack("H*", $string); do { my $i; $us = substr($string, 0, 128); $string = substr($string, 128); $l += $r = (length($us) / 2); print $stdout "pad length: $r\n" if ($showwork); ($r++, $us .= "80") if ($r < 64 && !$p++); my @W = unpack('N16', pack("H*", $us) . "\000" x 7); $W[15] = $l * 8 if ($r < 57); foreach $i (16 .. 79) { push(@W, &$L($W[$i - 3] ^ $W[$i - 8] ^ $W[$i - 14] ^ $W[$i - 16], 1)); } ($a, $b, $c, $d, $e) = @A; foreach $i (0 .. 79) { my $qq = ($i < 20) ? ($b & ($c ^ $d) ^ $d) : ($i < 40) ? ($b ^ $c ^ $d) : ($i < 60) ? (($b | $c) & $d | $b & $c) : ($b ^ $c ^ $d); $t = &$M($qq + $e + $W[$i] + $K[$i / 20] + &$L($a, 5)); $e = $d; $d = $c; $c = &$L($b, 30); $b = $a; $a = $t; } @nuA = ($a, $b, $c, $d, $e); print $stdout "$a $b $c $d $e\n" if ($showwork); $i = 0; @A = map({ &$M($_ + $nuA[$i++]); } @A); } while ($r > 56); my $x = sprintf('%.8x' x 5, @A); @A = unpack("C*", pack("H*", $x)); return($x, @A); } # heavily modified from MIME::Base64 sub simple_encode_base64 { my $result = ''; my $input = shift; pos($input) = 0; while($input =~ /(.{1,45})/gs) { $result .= substr(pack("u", $1), 1); chop($result); } $result =~ tr|` -_|AA-Za-z0-9+/|; my $padding = (3 - length($input) % 3) % 3; $result =~ s/.{$padding}$/("=" x $padding)/e if ($padding); return $result; } # from RFC 2104/RFC 2202 sub hmac_sha1 { my $message = shift; my @key = (@_); my $opad; my $ipad; my $i; my @j; # sha1 blocksize is 512, so key should be 64 bytes print $stdout " KEY HASH \n" if ($showwork); ($i, @key) = &sha1(pack("C*", @key)) while (scalar(@key) > 64); push(@key, 0) while(scalar(@key) < 64); $opad = pack("C*", map { ($_ ^ 92) } @key); $ipad = pack("C*", map { ($_ ^ 54) } @key); print $stdout " MESSAGE HASH \n" if ($showwork); ($i, @j) = &sha1($ipad . $message); print $stdout " FINAL HASH \n" if ($showwork); $i = pack("C*", @j); # output hash is 160 bits ($i, @j) = &sha1($opad . $i); $i = &simple_encode_base64(pack("C20", @j)); return $i; } # simple encoder for OAuth modified URL encoding (used for lots of things, # actually) # this is NOT UTF-8 safe sub url_oauth_sub { my $x = shift; $x =~ s/([^-0-9a-zA-Z._~])/"%".uc(unpack("H*",$1))/eg; return $x; } # default method of getting password: ask for it. only relevant for Basic Auth, # which is no longer the default. sub defaultgetpassword { # original idea by @jcscoobyrs, heavily modified my $k; my $l; my $pass; $l = "no termios; password WILL"; if ($termios) { $termios->getattr(fileno($stdin)); $k = $termios->getlflag; $termios->setlflag($k ^ &POSIX::ECHO); $termios->setattr(fileno($stdin)); $l = "password WILL NOT"; } print $stdout "enter password for $whoami ($l be echoed): "; chomp($pass = <$stdin>); if ($termios) { print $stdout "\n"; $termios->setlflag($k); $termios->setattr(fileno($stdin)); } return $pass; } # this returns an immutable token corresponding to the current authenticated # session. in the case of Basic Auth, it is simply the user:password pair. # it does not handle OAuth -- that is run by a separate wizard. # the function then returns (token,secret) which for Basic Auth is token,undef. # most of the time we will be using tokens in a keyfile, however, so this # function runs in that case as a stub. sub authtoken { my @foo; my $pass; my $sig; my $return; my $tries = ($hold > 3) ? $hold : 3; # give up on token if we don't get one return (undef,undef) if ($anonymous); return ($tokenkey,$tokensecret) if (length($tokenkey) && length($tokensecret)); @foo = split(/:/, $user, 2); $whoami = $foo[0]; die("choose -user=username[:password], or -anonymous.\n") if (!length($whoami) || $whoami eq '1'); $pass = length($foo[1]) ? $foo[1] : &$getpassword; die("a password must be specified.\n") if (!length($pass)); return ($whoami, $pass); } # this is a sucky nonce generator. I was looking for an awesome nonce # generator, and then I realized it would only be used once, so who cares? # *rimshot* sub generate_nonce { unpack("H9000", pack("u", rand($$).$$.time())); } # this signs a request with the token and token secret. the result is undef if # Basic Auth. payload should already be URL encoded and *sorted*. # this is typically called by stringify_args to get authentication information. sub signrequest { # this horrible kludge is needed to account for both 5.005, or for # 5.6+ installs with no stdlibs and just a bare Perl, both of which # we support. I hope Larry Wall will forgive me for messing with # compiler internals next time I see him at church. BEGIN { $^H |= 0x00000008 unless ($] < 5.006); } my $resource = shift; my $payload = shift; # when we sign the initial request for an token, we obviously # don't have one yet, so mytoken/mytokensecret can be null. my $nonce = &generate_nonce; my @keybytes; my $sig_base; my $timestamp = time(); return undef if ($authtype eq 'basic'); # stub for oAuth 2.0 return undef if (!length($oauthkey) || !length($oauthsecret)); (@keybytes) = map { ord($_) } split(//, $oauthsecret.'&'.$mytokensecret); if (ref($resource) eq 'ARRAY' || length($payload)) { # split into _a and _b payloads lexically my $payload_a = ''; my $payload_b = ''; my $payload_c = ''; # this is for a special case my $w; my $aorb = 0; my $verifier = ''; my $method = "GET"; my $url; if (length($payload)) { $method = "POST"; # this is a bit problematic since it won't be # sorted. we'll deal with this as we need to. if (ref($resource) eq 'ARRAY') { $url = &url_oauth_sub($resource->[0]); $payload .= "&" . $resource->[1]; } else { $url = &url_oauth_sub($resource); } } elsif (ref($resource) eq 'ARRAY') { $url = &url_oauth_sub($resource->[0]); $payload = $resource->[1]; } else { $url = &url_oauth_sub($resource); } # this is pretty simplistic but it's really all we need. # the exception is oauth_verifier: that has to be wormed # into the middle, and we assume it's just that. if ($payload !~ /^oauth_verifier/) { foreach $w (split(/\&/, $payload)) { $aorb = 1 if ($w =~ /^[p-z]/ || $w =~ /^o[b-z]/); $w = &url_oauth_sub("${w}&"); if ($aorb) { $payload_b .= $w; } else { $payload_a .= $w; } } } else { $payload_c = &url_oauth_sub($payload) . "%26"; $payload_a = $payload_b = ''; $payload =~ s/^oauth_verifier=//; $verifier = ' oauth_verifier=\\"' . $payload . '\\",'; } $payload_b =~ s/%26$//; $sig_base = $method . "&" . $url . "&" . (length($payload_a) ? $payload_a : ''). "oauth_consumer_key%3D" . $oauthkey . "%26" . "oauth_nonce%3D" . $nonce . "%26" . "oauth_signature_method%3DHMAC-SHA1%26" . "oauth_timestamp%3D" . $timestamp . "%26" . (length($mytoken) ? ("oauth_token%3D" . $mytoken . "%26") : '') . $payload_c . "oauth_version%3D1.0" . (length($payload_b) ? ("%26" . $payload_b) : ''); } else { $sig_base = "GET&" . &url_oauth_sub($resource) . "&" . "oauth_consumer_key%3D" . $oauthkey . "%26" . "oauth_nonce%3D" . $nonce . "%26" . "oauth_signature_method%3DHMAC-SHA1%26" . "oauth_timestamp%3D" . $timestamp . "%26" . (length($mytoken) ? ("oauth_token%3D" . $mytoken . "%26") : '') . $payload_c . # could be part of it "oauth_version%3D1.0" ; } print $stdout "token-secret: $mytokensecret\nconsumer-secret: $oauthsecret\nsig-base: $sig_base\n" if ($superverbose); return ($timestamp, $nonce, &url_oauth_sub(&hmac_sha1($sig_base, @keybytes)), $verifier); } # this takes a token request and "tries hard" to get it. sub tryhardfortoken { my $url = shift; my $body = shift; my $tries = shift; my $rawtoken; $tries ||= 3; while($tries) { my $i; $rawtoken = &backticks($baseagent, '/dev/null', undef, $url, $body, 0, @wend); print $stdout ("token = $rawtoken\n") if ($superverbose); my (@keyarr) = split(/\&/, $rawtoken); my $got_token = ''; my $got_secret = ''; foreach $i (@keyarr) { my $key; my $value; ($key, $value) = split(/\=/, $i); $got_token = $value if ($key eq 'oauth_token'); $got_secret = $value if ($key eq 'oauth_token_secret'); } if (length($got_token) && length($got_secret)) { print $stdout " SUCCEEDED!\n"; return ($got_token, $got_secret); } print $stdout "."; $tries--; } print $stdout " FAILED!: \"$rawtoken\"\n"; die("unable to fetch token. here are some possible reasons:\n". " - root certificates are not updated (see documentation)\n". " - you entered your authentication information wrong\n". " - your computer's clock is not set correctly\n" . " - Twitter farted\n" . "fix these possible problems, or try again later.\n"); exit; } oysttyer-2.10.0/version_check.txt000066400000000000000000000001571335541774700171020ustar00rootroot00000000000000oysttyer;2.10.0;;;https://raw.githubusercontent.com/oysttyer/oysttyer/2.10.0/oysttyer.pl; --__-- --__-- --__--