ttytter-2.1.0+1/0000755000175000017500000000000012424530307012411 5ustar thijsthijsttytter-2.1.0+1/Makefile.PL0000644000175000017500000000066211463337364014401 0ustar thijsthijsuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( DISTNAME => 'Term-ReadLine-TTYtter', NAME => 'Term::ReadLine', VERSION_FROM => 'ReadLine/readline_ttytter.pm', linkext => {LINKTYPE => '' }, # dist => {COMPRESS=>'gzip -9f', SUFFIX=>'gz', # DIST_DEFAULT => 'all uutardist'}, ); ttytter-2.1.0+1/META.yml0000644000175000017500000000127012021201565013654 0ustar thijsthijs--- #YAML:1.0 name: Term-ReadLine-TTYtter version: 1.4 abstract: A Term::ReadLine driver based on Term::ReadLine::Perl, with special features for microblogging and the TTYtter client (q.v). author: - Cameron Kaiser license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: perl: 5.006 no_index: directory: - t - inc generated_by: your-mother resources: homepage: http://www.floodgap.com/software/ttytter/ meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 ttytter-2.1.0+1/CHANGES0000644000175000017500000002455312021201624013403 0ustar thijsthijs-- as Term::ReadLine:TTYtter -- 1.0: initial release 1.1: rl_hook_use_ansi to sync with $main::ansi and use/don't use ANSI (done to avoid changes to readline's calling convention) rl_hook_no_counter to sync with $main::dont_use_counter (ditto) (done to avoid changes to readline's calling convention) lots of UTF-8 fixes (tested on Mac OS X 10.4, 10.5 and Ubuntu 10.04) repaired test.pl to be UTF-8 compliant, fix various warnings Perl 5.6 set as minimum! 1.2: DEL at position zero no longer aborts the line fixed WINCH for changing window sizes (thanks Frank Doepper for patch); now background safe 1.3: asks POSIX.pm if available for SIGUSR1 signal (uses 30 if not) to fix problems with Linux 3.x kernels ^D maps to /quit 1.4: changes counter computation to support t.co, adds rl_hook_no_tco -- as Term::ReadLine::Perl -- 0.2: Test added. 0.3: Filehandles changed to \* from *, MinLine works, works with debugger. 0.4: Some bugs with $| corrected. Application name is set. Works under OS/2 without ReadKey. Should work under DOS with minimal changes (see $inDOS in ReadLine/readline.pl). 0.5: Code to support ReadLine'less debugger moved to debugger. One user reported that having .inputrc triggers the same bug that buggered earlier versions of the package. Request for a second readline is tried to be executed first, dying only if should work on a different terminal. 0.6: The above bug was due to missing vi keymap. Dirty workaround added. 0.7: We made ReadMode on term_OUT ;-( Better workaround for return of globs from a sub. Word break chars more suitable for Perl. 0.8: Insert, Operate, HistorySearch added. Rudimental support for tk being active during ReadLine. Should work better if ReadKey is present, but did not bootstrap. SelfLoader (and AutoLoader) supported (uncomment the lines with SelfLoader, ISA, and __DATA__). 0.9: tkRunning corrected. New attributes in Features: getHistory, setHistory, and new methods: GetHistory and SetHistory. After 0.9: Optional second argument to ->readline; [sg]etHistory, tkRunning features documented; Operate overwriting parameter fixed; AddHistory copied to addhistory in T::R::Perl; [SG]etHistory documented; tkRunning feature documented. eval "" => eval {} local => my After 0.91: Couple of bugs with my $var = @_; use SelfLoader; moved to DATA. Works in XTERM on OS/2. 0.93: Updates to Operate, couple of keybindings added. $rl_completer_terminator_character, $rl_correct_sw added. Reload-init-file moved to C-x C-x. C-x ? and C-x * list/insert possible completions (similar to tcsh globbing). For a second ReadLine interface ReadLine::Stub is used (unsuccessfully)? C-x * moves cursor correctly. 0.94: Should work everywhere where stty works (possibly with a warning). Warning says where to find TRK, switchable off. ReadLine.pm removed from distribution. 0.95: (from Jim Meyering): * readline.pm (preinit): Recognize bash's `input-meta' as a valid variable name. (F_ReReadInitFile): Recognize key binding directives in which the double-quoted RHS contains white space. (rl_set): Treat bash's `visible-stats' as a synonym of CompleteAddsuffix. Workaround against Term::ReadKey::ReadMode returning undef (thanks to Helmut Jarausch). 0.96: tkRunning support unrolled, now needs newer Term/ReadLine.pm to use it. Warnings from inputrc come only if -w. 0.97: Wrong version of Perl.pm was included, did not work with older Perls. 0.98: newTTY added. ornaments added. no longer installs into PERL dirs. Name of interface is now Term::ReadLine::Perl. Meta-flag tolerated (thanks to Honza Pazdziora). Bindings to \C-letter work again. 0.99: Buglet with -w corrected. 0.9901: Support for ornaments busted editing of long lines. 0.9902: Do not test TRL::Gnu in test.pl! Allow control-? in assignments. \M-\C- should work, as well as \x7F. (Thanks to Neil Bird!) 0.9903: Enable ornaments by default. Disable explicit ornaments in the test.pl. 0.9904: (thanks to Alexander Kourakos ) gave warnings for blank lines in my .inputrc showed underlined spaces in prompts (in xterm) which look ugly. 0.9905: (thanks to Wilson P. Snyder II wsnyder@maker.com) Fix reverse search. 0.9906: $readline::rl_getc added with the default value \&readline::rl_getc 0.9907: remove defined() noise. 0.9908: support $ENV{INPUTRC}. Advice users to look into *this* file for features... Joe.Petolino@Eng.Sun.COM added vi support (untested). Remove .gz-ness from Makefile.PL. 1.00: Ignore $/, $\, $,. Handle $include in RC file (by Roland Walker and Alexander Kourakos). Support "unsupported ioctl()". $rl_vi_replace_default_on_insert (by Russ Southern). Now we closely match the new syntax of .inputrc (by David Wollmann). Allow setenv PERL_RL_USE_TRK=0 to disable usage of Term::ReadKey. With $inDOS vicmd_map had conflicting definitions for #27. Removed spurious warnings from failing ioctl and stty. 1.01: Allow unset TERM. Wrong display and warnings if UP/DOWN reach a short line from a scrolled line Highlight the h-scroll indicators "<" ">" same as the prompt. Draw h-scroll indicator "<" even if a part of the prompt is shown. Scroll right if more than $rl_margin empty space is on the right. 1.02: Move reread-init to C-x C-r. Make C-x u and C-x C-u do undo. Set-mark: C-@, Control-Space on PC. Exchange-point-and-mark: C-x C-x. Kill-region: C-x C-w (as in lynx). Copy-region-as-kill: C-x w (kinda similar to Emacs). On PC, the last 2 and yank also available on Shift-Del, Control-Insert, Shift-Insert. Kill buffer is prepended or appended in natural manner. Disable detection of Japanese multibyte characters - conflicts with single-byte scripts. Reenable by $readline::_rl_japanese_mb = 1. 1.0201: Warnings due to a misprint fixed (thanks to Tatsuhiko Miyagawa). 1.0202: Warnings on highlight of the right scroll mark '<' fixed (thanks to Slaven Rezic). 1.0203: Unconditional titlecasing of .inputrc "values" broke settings with values such as 'vi' etc (thanks to Russ Southern for a report). 1.0204: Applied patches from Gurusamy and Slaven for vi mode: Logic to move insertion point one char back was wrong; Disable (YES!) choice of vi-mode based on $ENV{EDITOR}. Just in case: generate proper warning if an old $ket-bug resurrects. If readkey() returns undef, behave as on EOF. New option --no-print to test.pl. Try to move prompt to the next line if something is already on the current line (controlled by $rl_scroll_nextline, $rl_last_pos_can_backspace); Wrong setting of $rl_last_pos_can_backspace will result: a) 1 and wrong: empty line before the prompt; b) 0 and wrong: if the line contains 1 char only, (and no NL), the prompt will overwrite it; test with `perl -Mblib test.pl --no-print', type `print 1'. [This is not the same as termcap/am!]. New variable $readline::rl_default_selected; if true, default string is removed if the first keystroke is self-insert or BackSpace; test.pl modified to test this too; uses mr,me capabilities to highlight the default string. New command: SaveLine (on M-#). New command: PrintHistory (on M-h), PreviousHistory and NextHistory take count. The edited line is saved when one moves to history. 1.0205: Do not touch $ENV{HOME} unless defined. $ENV{AUTOMATED_TESTING} to skip interactive tests. 1.0206: Shift-Ins, Control-Ins, Shift-Del operate on clipboard (if available) (currently native on OS/2 only, otherwise uses commands $ENV{RL_PASTE_CMD}, $ENV{RL_CLCOPY_CMD}, or file $ENV{HOME}/.rl_cutandpaste). In absense of mark, CopyRegionAsKillClipboard operates on the whole line Completely ignore unknown variables in .inputrc. Moving cursor should remove the highlight of initial string too. Change some local() to my(). Region between point and mark is highlighted. Commands SelfInsert, Yank*, *DeleteChar remove this region if $rl_delete_selection is TRUE (default). (Set mark again to insert without removing.) 1.0207: If mark was active, redraw could be performed after Enter. Untested Win32 support for cut&paste. Alias $var_DeleteSelection for $rl_delete_selection (thus accessible via .inputrc). 1.0208: Allow 2-arg form for test.pl Open CONIN$ on Win (if asked for CON), and open RW (bug in Win devdriver). Allow non-first Digit-Arguments to be escaped too. Allow Alt-char translation to \M-char on DOSISH. Apparently, self-loaded empty subroutines crash 5.8.2; 5.8.7 OK. Work-around: put "1;" into non-implemented stuff. 1.03: Support for numeric arguments missed setting $lastcommand. MinLine would not return the old value etc. On MSWin32 without ReadKey, but with cygwin stty.exe: do binmode (since Enter sends \r in these settings) (XXXX we don't undo binmode; is it needed?) (Only Control-Key work; do "Control-[ key" for Meta) When optimizing "cursor" movement, take into account ornaments. Optimize "cursor" movement even if we redraw the line. Would display the string twice, even if cursor was at the end of the line. Add key binding for Control-Movement keys in xterm; and some OSX xterm. Do not prefer HPUX xterm bindings to "normal" XTerm bindings. New functions F_BeginUndoGroup F_EndUndoGroup F_DoNothing F_MemorizeDigitArgument F_ForceMemorizeDigitArgument F_UnmemorizeDigitArgument F_ResetDigitArgument F_MergeInserts F_MemorizePos (for better mouse support; untested) Undo list merges together states where the only change is position 1.0301: F_TransposeWords implemented Enable binmode() on MSWin32 if ReadMode succeeds. Since "normal" getc() returns 0 on "special keys" (as opposed to behaviour with reasonable CRT library, which would return a pair of keypresses 0 "keynumber"), to access special keys one needs something like C-[ for Esc, and C-[ c for Alt-c. Support \key with key in "abfnrtvd" in init files (\b/\d as C-?/C-d) and \ooo for octal. Allow single quotes in macro specifications, and backwacked quotes. Support macros (propagate numeric arguments). New functions F_BeginPasteGroup; F_EndPasteGroup; F_BeginEditGroup; F_EndEditGroup; bound to XTerm mouse editing Support ~/ in INPUTRC name and $include; $ENV{TRP_INPUTRC} overrides $ENV{INPUTRC}. New functions F_DoMetaVersion; F_DoControlVersion; bound as in Emacs: C-x Esc m and C-x Esc c. 1.0302: C-@ was incorrectly bound to a missing function SetPoint. C-x Esc c @ and C-x Esc c Space are now bound to SetMark, so do this if $inDOS too. Bind C-x @ c and C-x @ m too (as in Emacs). ttytter-2.1.0+1/MANIFEST0000644000175000017500000000013511463337364013553 0ustar thijsthijsCHANGES MANIFEST Makefile.PL ReadLine/TTYtter.pm ReadLine/readline_ttytter.pm README test.pl ttytter-2.1.0+1/README0000644000175000017500000001042012021243630013257 0ustar thijsthijsTTYtter intro tackon: This is Term::ReadLine::TTYtter. It is a modified version of T::RL::Perl with several new nonstandard features specific to TTYtter, but may be useful for other applications. It also allows UTF-8 characters to be entered without crashing, and adds a counter so you can see how many characters you've entered (which is a big deal for Twitter and other microblogging platforms). These methods are additionally defined, which are non-standard: removereadline method: erases the current prompt from the screen redisplay method: repaints the current prompt on the screen hook_background_control method: connects the interactive readline prompt to a PID specified by $main::child. The PID is then sent signal SIGUSR1 when a character is beginning processing (i.e., the process needs to NOT write to the screen), and SIGUSR2 when done (i.e., the process can write again). hook_use_ansi: same, but connects to $main::ansi (1 = use ANSI, 0 = don't). thus, unlike T:RL:Perl, T:RL:TTYtter defaults to ANSI *off*. hook_no_counter: same, but connects to $main::dont_use_counter (1 = disable counter). Useful for prompts where this is irrelevant. hook_no_tco: this is Twitter specific. See code. (The use of hooks into $main:: was so that the calling convention of &readline would not have to be disturbed to pass additional options.) Like T::RL::Perl, this is free software offered under the Perl Artistic License (see below). Because of dueling licenses, it must be distributed separately from TTYtter (which is Floodgap Free Software License), and it can be used 100% separately from TTYtter as an entirely independent driver. Changes for T::RL::TTYtter (C)2012 Cameron Kaiser and Contributors. All rights reserved. Send me your comments at ckaiser@floodgap.com LEGALESE ~~~~~~~~ Copyright (c) 1995 Ilya Zakharevich. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. You should have received a copy of the Perl license along with Perl; see the file README in Perl distribution. You should have received a copy of the GNU General Public License along with Perl; see the file Copying. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. You should have received a copy of the Artistic License along with Perl; see the file Artistic. Author of this software makes no claim whatsoever about suitability, reliability, edability, editability or usability of this product, and should not be kept liable for any damage resulting from the use of it. If you can use it, you are in luck, if not, I should not be kept responsible. Keep a handy copy of your backup tape at hand. WHAT ~~~~ This is a quick implementation of the minimal interface to Readline libraries. The implementation is made in Perl (mostly) by Jeffrey Friedl. The only thing this library does is to make it conformant (and add some minimal changes, like using Term::ReadKey if present, and correct work under xterm). (In fact this is an understatement now, a lot of additions are made, see CHANGES...) INSTALL ~~~~~~~ To install this module type perl Makefile.PL make make test or (with newer makemaker) make test_dynamic (Check whether you are satisfied with the results. Try to redirect stdin and/or stdout.) make install You may need to install Term::ReadKey first if your system is new (Solaris is ;-(). (Available in standard places, checked with 1.98.) If you see something like Can't ioctl TIOCGETP: Invalid argument at ... this means you need ReadKey. Note that as of 0.95 Term/ReadLine.pm is unbundled to make CPAN.pm happier. On the other hand, if you get newer Term/ReadLine.pm (say, by installing newer Perl) you may get more features enabled. For most features of T::R::P one needs to look in the CHANGES file, and the comments at the start of of readline/readline.pm. Volunteers to make the corresponding OO interface into POD are welcome (wrappers are available in Term::ReadLine::Perl; see perl5db.pl for a sample usage of hairier features, such as accessing Readline variables and methods). AUTHOR BUGS ~~~~~~~~~~~ Ilya Zakharevich cpan@ilyaz.org Std dstribution site: http://www.ilyaz.org/software/perl/modules ttytter-2.1.0+1/2.1.00.txt0000644000175000017500000072136012265415257013712 0ustar thijsthijs#!/usr/bin/perl -s ######################################################################### # # TTYtter v2.1 (c)2007-2012 cameron kaiser (and contributors). # all rights reserved. # http://www.floodgap.com/software/ttytter/ # # distributed under the floodgap free software license # http://www.floodgap.com/software/ffsl/ # # After all, we're flesh and blood. -- Oingo Boingo # If someone writes an app and no one uses it, does his code run? -- me # ######################################################################### require 5.005; BEGIN { # ONLY STUFF THAT MUST RUN BEFORE INITIALIZATION GOES HERE! # THIS FUNCTION HAS GOTTEN TOO DAMN CLUTTERED! # @INC = (); # wreck intentionally for testing # dynamically changing PERL_SIGNALS doesn't work in Perl 5.14+ (bug # 92246). we deal with this by forcing -signals_use_posix if the # environment variable wasn't already set. if ($] >= 5.014000 && $ENV{'PERL_SIGNALS'} ne 'unsafe') { $signals_use_posix = 1; } else { $ENV{'PERL_SIGNALS'} = 'unsafe'; } $command_line = $0; $0 = "TTYtter"; $TTYtter_VERSION = "2.1"; $TTYtter_PATCH_VERSION = 0; $TTYtter_RC_NUMBER = 0; # non-zero for release candidate # this is kludgy, yes. $LANG = $ENV{'LANG'} || $ENV{'GDM_LANG'} || $ENV{'LC_CTYPE'} || $ENV{'ALL'}; $my_version_string = "${TTYtter_VERSION}.${TTYtter_PATCH_VERSION}"; (warn ("$my_version_string\n"), exit) if ($version); $space_pad = " " x 1024; $background_is_ready = 0; # for multi-module extension handling $multi_module_mode = 0; $multi_module_context = 0; $muffle_server_messages = 0; undef $master_store; undef %push_stack; $padded_patch_version = substr($TTYtter_PATCH_VERSION . " ", 0, 2); %opts_boolean = map { $_ => 1 } qw( ansi noansi verbose superverbose ttytteristas noprompt seven silent hold daemon script anonymous readline ssl newline vcheck verify noratelimit notrack nonewrts notimeline synch exception_is_maskable mentions simplestart location readlinerepaint nocounter notifyquiet signals_use_posix dostream nostreamreplies streamallreplies nofilter ); %opts_sync = map { $_ => 1 } qw( ansi pause dmpause ttytteristas verbose superverbose url rlurl dmurl newline wrap notimeline lists dmidurl queryurl track colourprompt colourme notrack colourdm colourreply colourwarn coloursearch colourlist idurl notifies filter colourdefault backload searchhits dmsenturl nostreamreplies mentions wtrendurl atrendurl filterusers filterats filterrts filteratonly filterflags nofilter ); %opts_urls = map {$_ => 1} qw( url dmurl uurl rurl wurl frurl rlurl update shorturl apibase queryurl idurl delurl dmdelurl favsurl favurl favdelurl followurl leaveurl dmupdate credurl blockurl blockdelurl friendsurl modifyliurl adduliurl delliurl getliurl getlisurl getfliurl creliurl delliurl deluliurl crefliurl delfliurl getuliurl getufliurl dmsenturl rturl rtsbyurl dmidurl statusliurl followliurl leaveliurl followersurl oauthurl oauthauthurl oauthaccurl oauthbase wtrendurl atrendurl frupdurl lookupidurl rtsofmeurl ); %opts_secret = map { $_ => 1} qw( superverbose ttytteristas ); %opts_comma_delimit = map { $_ => 1 } qw( lists notifytype notifies filterflags filterrts filterats filterusers filteratonly ); %opts_space_delimit = map { $_ => 1 } qw( track ); %opts_can_set = map { $_ => 1 } qw( url pause dmurl dmpause superverbose ansi verbose update uurl rurl wurl avatar ttytteristas frurl track rlurl noprompt shorturl newline wrap verify autosplit notimeline queryurl colourprompt colourme colourdm colourreply colourwarn coloursearch colourlist idurl urlopen delurl notrack dmdelurl favsurl favurl favdelurl slowpost notifies filter colourdefault followurl leaveurl dmupdate mentions backload lat long location searchhits blockurl blockdelurl woeid nocounter linelength friendsurl followersurl lists modifyliurl adduliurl delliurl getliurl getlisurl getfliurl creliurl delliurl deluliurl crefliurl delfliurl atrendurl getuliurl getufliurl dmsenturl rturl rtsbyurl wtrendurl statusliurl followliurl leaveliurl dmidurl nostreamreplies frupdurl filterusers filterats filterrts filterflags filteratonly nofilter rtsofmeurl ); %opts_others = map { $_ => 1 } qw( lynx curl seven silent maxhist noansi hold status daemon timestamp twarg user anonymous script readline leader ssl rc norc vcheck apibase notifytype exts nonewrts synch runcommand authtype oauthkey oauthsecret tokenkey tokensecret credurl keyf readlinerepaint simplestart exception_is_maskable oldperl notco notify_tool_path oauthurl oauthauthurl oauthaccurl oauthbase signals_use_posix dostream eventbuf streamallreplies ); %valid = (%opts_can_set, %opts_others); $rc = (defined($rc) && length($rc)) ? $rc : ""; unless ($norc) { my $rcf = ($rc =~ m#^/#) ? $rc : "$ENV{'HOME'}/.ttytterrc${rc}"; if (open(W, $rcf)) { # 5.14 sets this lazily, so this gives us a way out eval 'binmode(W, ":utf8")' unless ($seven); while() { chomp; next if (/^\s*$/ || /^#/); s/^-//; ($key, $value) = split(/\=/, $_, 2); if ($key eq 'rc') { warn "** that's stupid, setting rc in an rc file\n"; } elsif ($key eq 'norc') { warn "** that's dumb, using norc in an rc file\n"; } elsif (length $$key) { ; # carry on } elsif ($valid{$key} && !length($$key)) { $$key = $value; } elsif ($key =~ /^extpref_/) { $$key = $value; } elsif (!$valid{$key}) { warn "** setting $key not supported in this version\n"; } } close(W); } elsif (length($rc)) { die("couldn't access rc file $rcf: $!\n". "to use defaults, use -norc or don't specify the -rc option.\n\n"); } } warn "** -twarg is deprecated\n" if (length($twarg)); $seven ||= 0; $oldperl ||= 0; $parent = $$; $script = 1 if (length($runcommand)); $supreturnto = $verbose + 0; $postbreak_time = 0; $postbreak_count = 0; # our minimum official support is now 5.8.6. if ($] < 5.008006 && !$oldperl) { die(<<"EOF"); *** you are using a version of Perl in "extended" support: $] *** the minimum tested version of Perl now required by TTYtter is 5.8.6. Perl 5.005 thru 5.8.5 probably can still run TTYtter, but they are not tested with it. if you want to suppress this warning, specify -oldperl on the command line, or put oldperl=1 in your .ttytterrc. bug patches will still be accepted for older Perls; see the TTYtter home page for info. for Perl 5.005, remember to also specify -seven. EOF } # defaults that our extensions can override $last_id = 0; $last_dm = 0; # a correct fix for -daemon would make this unlimited, but this # is good enough for now. $print_max ||= ($daemon) ? 999999 : 250; # shiver $suspend_output = -1; # try to find an OAuth keyfile if we haven't specified key+secret # no worries if this fails; we could be Basic Auth, after all $whine = (length($keyf)) ? 1 : 0; $keyf ||= "$ENV{'HOME'}/.ttytterkey"; $keyf = "$ENV{'HOME'}/.ttytterkey${keyf}" if ($keyf !~ m#/#); $attempted_keyf = $keyf; if (!length($oauthkey) && !length($oauthsecret) # set later && !length($tokenkey) && !length($tokensecret) && !$oauthwizard) { my $keybuf = ''; if(open(W, $keyf)) { while() { chomp; s/\s+//g; $keybuf .= $_; } close(W); my (@pairs) = split(/\&/, $keybuf); foreach(@pairs) { my (@pair) = split(/\=/, $_, 2); $oauthkey = $pair[1] if ($pair[0] eq 'ck'); $oauthsecret = $pair[1] if ($pair[0] eq 'cs'); $tokenkey = $pair[1] if ($pair[0] eq 'at'); $tokensecret = $pair[1] if ($pair[0] eq 'ats'); } die("** tried to load OAuth tokens from $keyf\n". " but it seems corrupt or incomplete. please see the documentation,\n". " or delete the file so that we can try making your keyfile again.\n") if ((!length($oauthkey) || !length($oauthsecret) || !length($tokenkey) || !length($tokensecret))); } else { die("** couldn't open keyfile $keyf: $!\n". "if you want to run the OAuth wizard to create this file, add ". "-oauthwizard\n") if ($whine); $keyf = ''; # i.e., we loaded nothing from a key file } } # try to init Term::ReadLine if it was requested # (shakes fist at @br3nda, it's all her fault) %readline_completion = (); if ($readline && !$silent && !$script) { $ENV{"PERL_RL"} = "TTYtter" if (!length($ENV{'PERL_RL'})); eval 'use Term::ReadLine; $termrl = new Term::ReadLine ("TTYtter", \*STDIN, \*STDOUT)' || die( "$@\nthis perl doesn't have ReadLine. don't use -readline.\n"); $stdout = $termrl->OUT || \*STDOUT; $stdin = $termrl->IN || \*STDIN; $readline = '' if ($readline eq '1'); $readline =~ s/^"//; # for optimizer $readline =~ s/"$//; #$termrl->Attribs()->{'autohistory'} = undef; # not yet (%readline_completion) = map {$_ => 1} split(/\s+/, $readline); %original_readline = %readline_completion; # readline repaint can't be tested here. we cache our # result later. } else { $stdout = \*STDOUT; $stdin = \*STDIN; } $wrapseq = 0; $lastlinelength = -1; print $stdout "$leader\n" if (length($leader)); # state information $lasttwit = ''; $lastpostid = 0; # stub namespace for multimodules and (eventually) state saving undef %store; $store = \%store; $pack_magic = ($] < 5.006) ? '' : "U0"; $utf8_encode = sub { ; }; $utf8_decode = sub { ; }; unless ($seven) { eval 'use utf8;binmode($stdin,":utf8");binmode($stdout,":utf8");return 1' || die("$@\nthis perl doesn't fully support UTF-8. use -seven.\n"); # this is for the prinput utf8 validator. # adapted from http://mail.nl.linux.org/linux-utf8/2003-03/msg00087.html # eventually this will be removed when 5.6.x support is removed, # and Perl will do the UTF-8 validation for us. $badutf8='[\x00-\x7f][\x80-\xbf]+|^[\x80-\xbf]+|'. '[\xc0-\xdf][\x00-\x7f\xc0-\xff]|'. '[\xc0-\xdf][\x80-\xbf]{2}|'. '[\xe0-\xef][\x80-\xbf]{0,1}[\x00-\x7f\xc0-\xff]|'. '[\xe0-\xef][\x80-\xbf]{3}|'. '[\xf0-\xf7][\x80-\xbf]{0,2}[\x00-\x7f\xc0-\xff]|'. '[\xf0-\xf7][\x80-\xbf]{4}|'. '[\xf8-\xfb][\x80-\xbf]{0,3}[\x00-\x7f\xc0-\xff]|'. '[\xf8-\xfb][\x80-\xbf]{5}|'. '[\xfc-\xfd][\x80-\xbf]{0,4}[\x00-\x7f\xc0-\xff]|'. '\xed[\xa0-\xbf][\x80-\xbf]|'. '\xef\xbf[\xbe-\xbf]|'. '[\xf0-\xf7][\x8f,\x9f,\xaf,\xbf]\xbf[\xbe-\xbf]|'. '\xfe|\xff|'. '[\xc0-\xc1][\x80-\xbf]|'. '\xe0[\x80-\x9f][\x80-\xbf]|'. '\xf0[\x80-\x8f][\x80-\xbf]{2}|'. '\xf8[\x80-\x87][\x80-\xbf]{3}|'. '\xfc[\x80-\x83][\x80-\xbf]{4}'; # gah! eval <<'EOF'; $utf8_encode = sub { utf8::encode(shift); }; $utf8_decode = sub { utf8::decode(shift); }; EOF } $wraptime = sub { my $x = shift; return ($x, $x); }; if ($timestamp) { my $fail = "-- can't use custom timestamps.\nspecify -timestamp by itself to use Twitter's without module.\n"; if (length($timestamp) > 1) { # pattern specified eval 'use Date::Parse;return 1' || die("$@\nno Date::Parse $fail"); eval 'use Date::Format;return 1' || die("$@\nno Date::Format $fail"); $timestamp = "%Y-%m-%d %k:%M:%S" if ($timestamp eq "default" || $timestamp eq "def"); $wraptime = sub { my $time = str2time(shift); my $stime = time2str($timestamp, $time); return ($time, $stime); }; } } } END { &killkid unless ($in_backticks || $in_buffer); # this is disgusting } #### COMMON STARTUP #### # if we requested POSIX signals, or we NEED posix signals (5.14+), we # must check if we have POSIX signals actually if ($signals_use_posix) { eval 'use POSIX'; # God help the system that doesn't have SIGTERM $j = eval 'return POSIX::SIGTERM' ; die(<<"EOF") if (!(0+$j)); *** death permeates me *** your configuration requires using POSIX signalling (either Perl 5.14+ or you specifically asked with -signals_use_posix). however, either you don't have POSIX.pm, or it doesn't work. TTYtter requires 'unsafe' Perl signals (which are of course for its purposes perfectly safe). unfortunately, due to Perl bug 92246 5.14+ must use POSIX.pm, or have the switch set before starting TTYtter. run one of export PERL_SIGNALS=unsafe # sh, bash, ksh, etc. setenv PERL_SIGNALS unsafe # csh, tcsh, etc. and restart TTYtter, or use Perl 5.12 or earlier (without specifying -signals_use_posix). EOF } # do we have POSIX::Termios? (usually we do) eval 'use POSIX; $termios = new POSIX::Termios;'; print $stdout "-- termios test: $termios\n" if ($verbose); # check the TRLT version. versions < 1.3 won't work with 2.0. if ($termrl && $termrl->ReadLine eq 'Term::ReadLine::TTYtter') { eval '$trlv = $termrl->Version;'; die (<<"EOF") if (length($trlv) && 0+$trlv < 1.3); *** death permeates me *** you need to upgrade your Term::ReadLine::TTYtter to at least version 1.3 to use TTYtter 2.x, or bad things will happen such as signal mismatches, unexpected quits, and dogs and cats living peacefully in the same house. EOF print $stdout "** t.co support needs Term::ReadLine:TTYtter 1.4+ (-notco to ignore)\n" if (length($trlv) && !$notco && 0+$trlv < 1.4); } # try to get signal numbers for SIG* from POSIX. use internals if failed. eval 'use POSIX; $SIGUSR1 = POSIX::SIGUSR1; $SIGUSR2 = POSIX::SIGUSR2; $SIGHUP = POSIX::SIGHUP; $SIGTERM = POSIX::SIGTERM'; # from $SIGHUP ||= 1; $SIGTERM ||= 15; $SIGUSR1 ||= 30; $SIGUSR2 ||= 31; # wrap warning die( "** dude, what the hell kind of terminal can't handle a 5 character line?\n") if ($wrap > 1 && $wrap < 5); print $stdout "** warning: prompts not wrapped for wrap < 70\n" if ($wrap > 1 && $wrap < 70); # reject stupid combinations die("you can't use automatic ratelimits with -noratelimit.\nuse -pause=#sec\n") if ($noratelimit && $pause eq 'auto'); die("you can't use -synch with -script or -daemon.\n") if ($synch && ($script || $daemon)); die("-script and -daemon cannot be used together.\n") if ($script && $daemon); # set up menu codes and caches $is_background = 0; $alphabet = "abcdefghijkLmnopqrstuvwxyz"; %store_hash = (); $mini_split = 250; # i.e., 10 tweets for the mini-menu (/th) # leaving 50 tweets for the foreground temporary menus $tweet_counter = 0; %dm_store_hash = (); $dm_counter = 0; %id_cache = (); %filter_next = (); # set up threading management $in_reply_to = 0; $expected_tweet_ref = undef; # interpret -script at this level if ($script) { $noansi = $noprompt = 1; $silent = ($verbose) ? 0 : 1; $pause = $vcheck = $slowpost = $verify = 0; } ### now instantiate the TTYtter dynamic API ### ### based off the defaults later in script. #### # first we need to load any extensions specified by -exts. if (length($exts) && $exts ne '0') { $multi_module_mode = -1; # mark as loader stage print "** attempting to load extensions\n" unless ($silent); # unescape \, $j=0; $xstring = "ESCAPED_STRING"; while($exts =~ /$xstring$j/) { $j++; } $xstring .= $j; $exts =~ s/\\,/$xstring/g; foreach $file (split(/,/, $exts)) { #TODO # wildcards? $file =~ s/$xstring/,/g; print "** loading $file\n" unless ($silent); die("** sorry, you cannot load the same extension twice.\n") if ($master_store->{$file}->{'loaded'}); # prepare its working space in $store and load the module $master_store->{$file} = { 'loaded' => 1 }; $store = \%{ $master_store->{$file} }; $EM_DONT_CARE = 0; $EM_SCRIPT_ON = 1; $EM_SCRIPT_OFF = -1; $extension_mode = $EM_DONT_CARE; die("** $file not found: $!\n") if (! -r "$file"); require $file; # and die if bad die("** $file failed to load: $@\n") if ($@); die("** consistency failure: reference failure on $file\n") if (!$store->{'loaded'}); # check type of extension (interactive or non-interactive). if # we are in the wrong mode, bail out. if ($extension_mode) { die( "** this extension requires -script. this may conflict with other extensions\n". " you are loading, which may have their own requirements.\n") if ($extension_mode == $EM_SCRIPT_ON && !$script); die( "** this extension cannot work with -script. this may conflict with other\n". " extensions you are loading, which may have their own requirements.\n") if ($extension_mode == $EM_SCRIPT_OFF && $script); } # pick off all the subroutine references it makes for storage # in an array to iterate and chain over later. # these methods are multi-module safe foreach $arry (qw( handle exception tweettype conclude dmhandle dmconclude heartbeat precommand prepost postpost addaction eventhandle listhandle userhandle shutdown)) { if (defined($$arry)) { $aarry = "m_$arry"; push(@$aarry, [ $file, $$arry ]); undef $$arry; } } # these methods are NOT multi-module safe # if a extension already hooked one of # these and another extension tries to hook it, fatal error. foreach $arry (qw( getpassword prompt main autocompletion)) { if (defined($$arry)) { $sarry = "l_$arry"; if (defined($$sarry)) { die( "** double hook of unsafe method \"$arry\" -- you cannot use this extension\n". " with the other extensions you are loading. see the documentation.\n"); } $$sarry = $$arry; undef $$arry; } } } # success! enable multi-module support in the TTYtter API and then # dispatch calls through the multi-module system instead. $multi_module_mode = 1; # mark as completed loader $handle = \&multihandle; $exception = \&multiexception; $tweettype = \&multitweettype; $conclude = \&multiconclude; $dmhandle = \&multidmhandle; $dmconclude = \&multidmconclude; $heartbeat = \&multiheartbeat; $precommand = \&multiprecommand; $prepost = \&multiprepost; $postpost = \&multipostpost; $addaction = \&multiaddaction; $shutdown = \&multishutdown; $userhandle = \&multiuserhandle; $listhandle = \&multilisthandle; $eventhandle = \&multieventhandle; } else { # the old API single-end-point system $multi_module_mode = 0; # not executing multi module endpoints $handle = \&defaulthandle; $exception = \&defaultexception; $tweettype = \&defaulttweettype; $conclude = \&defaultconclude; $dmhandle = \&defaultdmhandle; $dmconclude = \&defaultdmconclude; $heartbeat = \&defaultheartbeat; $precommand = \&defaultprecommand; $prepost = \&defaultprepost; $postpost = \&defaultpostpost; $addaction = \&defaultaddaction; $shutdown = \&defaultshutdown; $userhandle = \&defaultuserhandle; $listhandle = \&defaultlisthandle; $eventhandle = \&defaulteventhandle; } # unsafe methods use the single-end-point $prompt = $l_prompt || \&defaultprompt; $main = $l_main || \&defaultmain; $getpassword = $l_getpassword || \&defaultgetpassword; # $autocompletion is special: if ($termrl) { $termrl->Attribs()->{'completion_function'} = $l_autocompletion || \&defaultautocompletion; } # fetch_id is based off last_id, if an extension set it $fetch_id = $last_id || 0; # validate the notify method the user chose, if any. # we can't do this in BEGIN, because it may not be instantiated yet, # and we have to do it after loading modules because it might be in one. @notifytypes = (); if (length($notifytype) && $notifytype ne '0' && $notifytype ne '1' && !$status) { # NOT $script! scripts have a use case for notifiers! %dupenet = (); foreach $nt (split(/\s*,\s*/, $notifytype)) { $fnt="notifier_${nt}"; (warn("** duplicate notification $nt was ignored\n"), next) if ($dupenet{$fnt}); eval 'return &$fnt(undef)' || die("** invalid notification framework $nt: $@\n"); $dupenet{$fnt}=1; } @notifytypes = keys %dupenet; $notifytype = join(',', @notifytypes); # warning if someone didn't tell us what notifies they wanted. warn "-- warning: you specified -notifytype, but no -notifies\n" if (!$silent && !length($notifies)); } # set up track tags if (length($tquery) && $tquery ne '0') { my $xtquery = &tracktags_tqueryurlify($tquery); die("** custom tquery is over 140 length: $xtquery\n") if (length($xtquery) > 139); @trackstrings = ($xtquery); } else { &tracktags_makearray; } # compile filterflags &filterflags_compile; # compile filters exit(1) if (!&filter_compile); $filterusers_sub = &filteruserlist_compile(undef, $filterusers); $filterrts_sub = &filteruserlist_compile(undef, $filterrts); $filteratonly_sub = &filteruserlist_compile(undef, $filteratonly); exit(1) if (!&filterats_compile); # compile lists exit(1) if (!&list_compile); # finally, compile notifies. we do this regardless of notifytype, so that # an extension can look at it if it wants to. ¬ify_compile; # check that we are using a sensible authtype, based on our guessed user agent $authtype ||= "oauth"; die("** supported authtypes are basic or oauth only.\n") if ($authtype ne 'basic' && $authtype ne 'oauth'); if ($termrl) { $streamout = $stdout; # this is just simpler instead of dupping warn(<<"EOF") if ($] < 5.006); *********************************************************** ** -readline may not function correctly on Perls < 5.6.0 ** *********************************************************** EOF print $stdout "-- readline using ".$termrl->ReadLine."\n"; } else { # dup $stdout for benefit of various other scripts open(DUPSTDOUT, ">&STDOUT") || warn("** warning: could not dup $stdout: $!\n"); binmode(DUPSTDOUT, ":utf8") unless ($seven); $streamout = \*DUPSTDOUT; } if ($silent) { close($stdout); open($stdout, ">>/dev/null"); # KLUUUUUUUDGE } # after this point, die() may cause problems # initialize our route back out so background can talk to foreground pipe(W, P) || die("pipe() error [or your Perl doesn't support it]: $!\n"); select(P); $|++; binmode(P, ":utf8") unless ($seven); binmode(W, ":utf8") unless ($seven); # default command line options $anonymous ||= 0; $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 ||= 140; $oauthbase ||= $apibase || "${http_proto}://api.twitter.com"; # this needs to be AFTER oauthbase so that apibase can set oauthbase. $apibase ||= "${http_proto}://api.twitter.com/1.1"; $nonewrts ||= 0; # special case: if we explicitly refuse backload, don't load initially. $backload = 30 if (!defined($backload)); # zero is valid! $dont_refresh_first_time = 1 if (!$backload); $searchhits ||= 20; $url ||= "${apibase}/statuses/home_timeline.json"; $oauthurl ||= "${oauthbase}/oauth/request_token"; $oauthauthurl ||= "${oauthbase}/oauth/authorize"; $oauthaccurl ||= "${oauthbase}/oauth/access_token"; $credurl ||= "${apibase}/account/verify_credentials.json"; $update ||= "${apibase}/statuses/update.json"; $rurl ||= "${apibase}/statuses/mentions_timeline.json"; $uurl ||= "${apibase}/statuses/user_timeline.json"; $idurl ||= "${apibase}/statuses/show.json"; $delurl ||= "${apibase}/statuses/destroy/%I.json"; $rturl ||= "${apibase}/statuses/retweet"; $rtsbyurl ||= "${apibase}/statuses/retweets/%I.json"; $rtsofmeurl ||= "${apibase}/statuses/retweets_of_me.json"; $wurl ||= "${apibase}/users/show.json"; $frurl ||= "${apibase}/friendships/show.json"; $followurl ||= "${apibase}/friendships/create.json"; $leaveurl ||= "${apibase}/friendships/destroy.json"; $blockurl ||= "${apibase}/blocks/create.json"; $blockdelurl ||= "${apibase}/blocks/destroy.json"; $friendsurl ||= "${apibase}/friends/ids.json"; $followersurl ||= "${apibase}/followers/ids.json"; $frupdurl ||= "${apibase}/friendships/update.json"; $lookupidurl ||= "${apibase}/users/lookup.json"; $rlurl ||= "${apibase}/application/rate_limit_status.json"; $dmurl ||= "${apibase}/direct_messages.json"; $dmsenturl ||= "${apibase}/direct_messages/sent.json"; $dmupdate ||= "${apibase}/direct_messages/new.json"; $dmdelurl ||= "${apibase}/direct_messages/destroy.json"; $dmidurl ||= "${apibase}/direct_messages/show.json"; $favsurl ||= "${apibase}/favorites/list.json"; $favurl ||= "${apibase}/favorites/create.json"; $favdelurl ||= "${apibase}/favorites/destroy.json"; $getlisurl ||= "${apibase}/lists/list.json"; $creliurl ||= "${apibase}/lists/create.json"; $delliurl ||= "${apibase}/lists/destroy.json"; $modifyliurl ||= "${apibase}/lists/update.json"; $deluliurl ||= "${apibase}/lists/members/destroy_all.json"; $adduliurl ||= "${apibase}/lists/members/create_all.json"; $getuliurl ||= "${apibase}/lists/memberships.json"; $getufliurl ||= "${apibase}/lists/subscriptions.json"; $delfliurl ||= "${apibase}/lists/subscribers/destroy.json"; $crefliurl ||= "${apibase}/lists/subscribers/create.json"; $getfliurl ||= "${apibase}/lists/subscribers.json"; $getliurl ||= "${apibase}/lists/members.json"; $statusliurl ||= "${apibase}/lists/statuses.json"; $streamurl ||= "https://userstream.twitter.com/2/user.json"; $dostream ||= 0; $eventbuf ||= 0; $queryurl ||= "${apibase}/search/tweets.json"; # no more $trendurl in 2.1. $wtrendurl ||= "${apibase}/trends/place.json"; $atrendurl ||= "${apibase}/trends/closest.json"; # pick ONE! #$shorturl ||= "http://api.tr.im/v1/trim_simple?url="; $shorturl ||= "http://is.gd/api.php?longurl="; # figure out the domain to stop shortener loops &generate_shortdomain; $pause = (($anonymous) ? 120 : "auto") if (!defined $pause); # NOT ||= ... zero is a VALID value! $superverbose ||= 0; $avatar ||= ""; $urlopen ||= 'echo %U'; $hold ||= 0; $daemon ||= 0; $maxhist ||= 19; undef $shadow_history; $timestamp ||= 0; $noprompt ||= 0; $slowpost ||= 0; $twarg ||= undef; $verbose ||= $superverbose; $dmpause = 4 if (!defined $dmpause); # NOT ||= ... zero is a VALID value! $dmpause = 0 if ($anonymous); $dmpause = 0 if ($pause eq '0'); $ansi = ($noansi) ? 0 : (($ansi || $ENV{'TERM'} eq 'ansi' || $ENV{'TERM'} eq 'xterm-color') ? 1 : 0); # synch overrides these options. if ($synch) { $pause = 0; $dmpause = ($dmpause) ? 1 : 0; } $dmcount = $dmpause; $lastshort = undef; # ANSI sequences $colourprompt ||= "CYAN"; $colourme ||= "YELLOW"; $colourdm ||= "GREEN"; $colourreply ||= "RED"; $colourwarn ||= "MAGENTA"; $coloursearch ||= "CYAN"; $colourlist ||= "OFF"; $colourdefault ||= "OFF"; $ESC = pack("C", 27); $BEL = pack("C", 7); &generate_ansi; # to force unambiguous bareword interpretation $true = 'true'; sub true { return 'true'; } $false = 'false'; sub false { return 'false'; } $null = undef; sub null { return undef; } select($stdout); $|++; # figure out what our user agent should be if ($lynx) { if (length($lynx) > 1 && -x "/$lynx") { $wend = $lynx; print $stdout "Lynx forced to $wend\n"; } else { $wend = &wherecheck("trying to find Lynx", "lynx", "specify -curl to use curl instead, or just let TTYtter autodetect stuff.\n"); } } else { if (length($curl) > 1 && -x "/$curl") { $wend = $curl; print $stdout "cURL forced to $wend\n"; } else { $wend = (($curl) ? &wherecheck("trying to find cURL", "curl", "specify -lynx to use Lynx instead, or just let TTYtter autodetect stuff.\n") : &wherecheck("trying to find cURL", "curl")); if (!$curl && !length($wend)) { $wend = &wherecheck("failed. trying to find Lynx", "lynx", "you must have either Lynx or cURL installed to use TTYtter.\n") if (!length($wend)); $lynx = 1; } else { $curl = 1; } } } $baseagent = $wend; # whoops, no Lynx here if we are not using Basic Auth die( "sorry, OAuth is not currently supported with Lynx.\n". "you must use SSL cURL, or specify -authtype=basic.\n") if ($lynx && $authtype ne 'basic' && !$anonymous); # streaming API has multiple prereqs. not fatal; we just fall back on the # REST API if not there. unless($status) { if (!$dostream || $authtype eq 'basic' || !$ssl || $script || $anonymous || $synch) { $reason = (!$dostream) ? "(no -dostream)" : ($script) ? "(-script)" : (!$ssl) ? "(no SSL)" : ($anonymous) ? "(-anonymous)" : ($synch) ? "(-synch)" : ($authtype eq 'basic') ? "(no OAuth)" : "(it's funkatron's fault)"; print $stdout "-- Streaming API disabled $reason (TTYtter will use REST API only)\n"; $dostream = 0; } else { print $stdout "-- Streaming API enabled\n"; # streams change mentions behaviour; we get them automatically. # warn the user if the current settings are suboptimal. if ($mentions) { if ($nostreamreplies) { print $stdout "** warning: -mentions and -nostreamreplies are very inefficient together\n"; } else { print $stdout "** warning: -mentions not generally needed in Streaming mode\n"; } } } } else { $dostream = 0; } # -status suppresses streaming if (!$dostream && $streamallreplies) { print $stdout "** warning: -streamallreplies only works in Streaming mode\n"; } # create and cache the logic for our selected user agent if ($lynx) { $simple_agent = "$baseagent -nostatus -source"; @wend = ('-nostatus'); @wind = (@wend, '-source'); # GET agent @wend = (@wend, '-post_data'); # POST agent # we don't need to have the request signed by Lynx right now; # it doesn't know how to pass custom headers. so this is simpler. $stringify_args = sub { my $basecom = shift; my $resource = shift; my $data = shift; my $dont_do_auth = shift; my $k = join("\n", @_); # if resource is an arrayref, then it's a GET with URL # and args (mostly generated by &grabjson) $resource = join('?', @{ $resource }) if (ref($resource) eq 'ARRAY'); die("wow, we have a bug: Lynx only works with Basic Auth\n") if ($authtype ne 'basic' && !$dont_do_auth); $k = "-auth=".$mytoken.':'.$mytokensecret."\n".$k unless ($dont_do_auth); $k .= "\n"; $basecom = "$basecom \"$resource\" -"; return ($basecom, $k, $data); }; } else { $simple_agent = "$baseagent -s -m 20"; @wend = ('-s', '-m', '20', '-A', "TTYtter/$TTYtter_VERSION", '-H', 'Expect:'); @wind = @wend; $stringify_args = sub { my $basecom = shift; my $resource = shift; my $data = shift; my $dont_do_auth = shift; my $p; my $l = ''; foreach $p (@_) { if ($p =~ /^-/) { $l .= "\n" if (length($l)); $l .= "$p "; next; } $l .= $p; } $l .= "\n"; # sign our request (Basic Auth or oAuth) unless ($dont_do_auth) { if ($authtype eq 'basic') { $l .= "-u ".$mytoken.":".$mytokensecret."\n"; } else { my $nonce; my $timestamp; my $sig; my $verifier = ''; my $header; my $ttoken = (length($mytoken) ? (' oauth_token=\\"'.$mytoken.'\\",') : ''); ($timestamp, $nonce, $sig, $verifier) = &signrequest($resource, $data); $header = <<"EOF"; -H "Authorization: OAuth oauth_nonce=\\"$nonce\\", oauth_signature_method=\\"HMAC-SHA1\\", oauth_timestamp=\\"$timestamp\\", oauth_consumer_key=\\"$oauthkey\\", oauth_signature=\\"$sig\\",${ttoken}${verifier} oauth_version=\\"1.0\\"" EOF print $stdout $header if ($superverbose); $l .= $header; } } # if resource is an arrayref, then it's a GET with URL # and args (mostly generated by &grabjson) $resource = join('?', @{ $resource }) if (ref($resource) eq 'ARRAY'); $l .= "url = \"$resource\"\n"; $l .= "data = \"$data\"\n" if length($data); return ("$basecom -K -", $l, undef); }; } # update check if ($vcheck && !length($status)) { $vs = &updatecheck(0); } else { $vs = "-- no version check performed (use /vcheck, or -vcheck to check on startup)\n" unless ($script || $status); } print $stdout $vs; # and then again when client starts up ## make sure we have all the authentication pieces we need for the ## chosen method (authtoken handles this for Basic Auth; ## this is where we validate OAuth) # if we use OAuth, then don't use any Basic Auth credentials we gave # unless we specifically say -authtype=basic if ($authtype eq 'oauth' && length($user)) { print "** warning: -user is ignored when -authtype=oauth (default)\n"; $user = undef; } $whoami = (split(/\:/, $user, 2))[0] unless ($anonymous || !length($user)); # yes, this is plaintext. obfuscation would be ludicrously easy to crack, # and there is no way to hide them effectively or fully in a Perl script. # so be a good neighbour and leave this the fark alone, okay? stealing # credentials is mean and inconvenient to users. this is blessed by # arrangement with Twitter. don't be a d*ck. thanks for your cooperation. $oauthkey = (!length($oauthkey) || $oauthkey eq 'X') ? "XtbRXaQpPdfssFwdUmeYw" : $oauthkey; $oauthsecret = (!length($oauthsecret) || $oauthsecret eq 'X') ? "csmjfTQPE8ZZ5wWuzgPJPOBR9dyvOBEtHT5cJeVVmAA" : $oauthsecret; unless ($anonymous) { # if we are using Basic Auth, ignore any user token we may have in # our keyfile if ($authtype eq 'basic') { $tokenkey = undef; $tokensecret = undef; } # but if we are using OAuth, we can request one, unless we are in script elsif ($authtype eq 'oauth' && (!length($keyf) || $oauthwizard)) { if (length($oauthkey) && length($oauthsecret) && !length($tokenkey) && !length($tokensecret)) { # we have a key, we don't have the user token # but we can't get that with -script if ($script) { print $streamout <<"EOF"; AUTHENTICATION FAILURE YOU NEED TO GET AN OAuth KEY, or use -authtype=basic (run TTYtter without -script or -runcommand for help) EOF exit; } # run the wizard, which writes a keyfile for us $keyf ||= $attempted_keyf; print $stdout <<"EOF"; +----------------------------------------------------------------------------+ || WELCOME TO TTYtter: Authorize TTYtter by signing into Twitter with OAuth || +----------------------------------------------------------------------------+ Looks like you're starting TTYtter for the first time, and/or creating a keyfile. Welcome to the most user-hostile, highly obfuscated, spaghetti code infested and obscenely obscure Twitter client that's out there. You'll love it. TTYtter generates a keyfile that contains credentials for you, including your access tokens. This needs to be done JUST ONCE. You can take this keyfile with you to other systems. If you revoke TTYtter's access, you must remove the keyfile and start again with a new token. You need to do this once per account you use with TTYtter; only one account token can be stored per keyfile. If you have multiple accounts, use -keyf=... to specify different keyfiles. KEEP THESE FILES SECRET. ** This wizard will overwrite $keyf Press RETURN/ENTER to continue or CTRL-C NOW! to abort. EOF $j = ; print $stdout "\nRequest from $oauthurl ..."; ($tokenkey, $tokensecret) = &tryhardfortoken($oauthurl, "oauth_callback=oob"); $mytoken = $tokenkey; $mytokensecret = $tokensecret; # needs to be in both places # kludge in case user does not specify SSL and this is # Twitter: we know Twitter supports SSL ($oauthauthurl =~ /twitter/) && ($oauthauthurl =~ s/^http:/https:/); print $stdout <<"EOF"; 1. Visit, in your browser, ALL ON ONE LINE, ${oauthauthurl}?oauth_token=$mytoken 2. If you are not already signed in, fill in your username and password. 3. Verify that TTYtter is the requesting application, and that its permissions are as you expect (read your timeline, see who you follow and follow new people, update your profile, post tweets on your behalf and access your direct messages). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW! 4. Click Authorize app. 5. A PIN will appear. Enter it below. EOF $j = ''; while(!(0+$j)) { print $stdout "Enter PIN> "; chomp($j = ); } print $stdout "\nRequest from $oauthaccurl ..."; ($tokenkey, $tokensecret) = &tryhardfortoken($oauthaccurl, "oauth_verifier=$j"); $oauthkey = "X"; $oauthsecret = "X"; open(W, ">$keyf") || die("Failed to write keyfile $keyf: $!\n"); print W <<"EOF"; ck=${oauthkey}&cs=${oauthsecret}&at=${tokenkey}&ats=${tokensecret} EOF close(W); chmod(0600, $keyf) || print $stdout "Warning: could not change permissions on $keyf : $!\n"; print $stdout <<"EOF"; Written keyfile $keyf Now, restart TTYtter to use this keyfile. (To choose between multiple keyfiles other than the default .ttytterkey, tell TTYtter where the key is using -keyf=... .) EOF exit; } # if we get three of the four, this must have been command line if (length($oauthkey) && length($oauthsecret) && (!length($tokenkey) || !length($tokensecret))) { my $error = undef; my $k; foreach $k (qw(oauthkey oauthsecret tokenkey tokensecret)) { $error .= "** you need to specify -$k\n" if (!length($$k)); } if (length($error)) { print $streamout <<"EOF"; you are missing portions of the OAuth sequence. either create a keyfile and point to it with -keyf=... or add these missing pieces: $error then restart TTYtter, or use -authtype=basic. EOF exit; } } } elsif ($retoke && length($keyf)) { # start the "re-toke" wizard to convert DM-less cloned app keys. # dup STDIN for systems that can only "close" it once open(STDIN2, "<&STDIN") || die("couldn't dup STDIN: $!\n"); print $stdout <<"EOF"; +-------------------------------------------------------------------------+ || The Re-Toke Wizard: Generate a new TTYtter keyfile for your app/token || +-------------------------------------------------------------------------+ Twitter is requiring tokens to now have specific permissions to READ direct messages. This will be enforced by 1 July 2011. If you find you are unable to READ direct messages, you will need this wizard. DO NOT use this wizard if you are NOT using a cloned app key (1.2 and on) -- use -oauthwizard. This wizard will create a new keyfile for you from your app/user keys/tokens. You do NOT need this wizard if you are using TTYtter for a purpose that does not require direct message access. For example, if TTYtter is acting as your command line posting agent, or you are only using it to read your timeline, you do NOT need a new token. You also do not need a new token to SEND a direct message, only to READ ones this account has received. You SHOULD NOT need this wizard if your app key was cloned after 1 June 2011. However, you can still use it if you experience this specific issue with DMs, or need to rebuild your keyfile for any other reason. ** This wizard will overwrite the key at $keyf ** To change this, restart TTYtter with -retoke -keyf=/path/to/keyfile Press RETURN/ENTER to continue, or CTRL-C NOW! to abort. EOF $j = ; print $stdout <<"EOF"; First: let's get your API key, consumer key and consumer secret. Start your browser. 1. Log into https://twitter.com/ with your desired account. 2. Go to this URL. You must be logged into Twitter FIRST! https://dev.twitter.com/apps 3. Click the TTYtter cloned app key you need to regenerate or upgrade. 4. Click Edit Application Settings. 5. Make sure Read, Write & Private Message is selected, and click the "Save application" button. 6. Select All (CTRL/Command-A) on the next screen, copy (CTRL/Command-C) it, and paste (CTRL/Command-V) it into this window. (You can also cut and paste a smaller section if I can't understand your browser's layout.) 7. Press ENTER/RETURN and CTRL-D when you have pasted the window contents. EOF $q = $/; PASTE1LOOP: for(;;) { print $stdout <<"EOF"; -- Press ENTER and CTRL-D AFTER you have pasted the window contents! --------- Go ahead: EOF undef $/; $j = ; print $stdout <<"EOF"; -- EOF ----------------------------------------------------------------------- Processing ... EOF $j =~ s/[\r\n]/ /sg; # process this. as a checksum, API key should == consumer key. $ck = ''; $cs = ''; ($j =~ /Consumer key\s+([-a-zA-Z0-9_]{10,})\s+/) && ($ck = $1); ($j =~ /Consumer secret\s+([-a-zA-Z0-9_]{10,})\s+/) && ($cs = $1); if (!length($ck) || !length($cs)) { # escape hatch print $stdout <<"EOF"; Something's wrong: I could not find your consumer key or consumer secret in that text. If this was a misfired paste, please restart the wizard. Otherwise, bug me at \@ttytter or ckaiser\@floodgap.com. Please don't send keys or secrets to either address. EOF exit; } last PASTE1LOOP; } # this part is similar to the retoke. $oauthkey = $ck; $oauthsecret = $cs; print $stdout "\nI'm testing this key to see if it works.\n"; print $stdout "Request from $oauthurl ..."; ($tokenkey, $tokensecret) = &tryhardfortoken($oauthurl, "oauth_callback=oob"); $mytoken = $tokenkey; $mytokensecret = $tokensecret; # kludge in case user does not specify SSL and this is # Twitter: we know Twitter supports SSL ($oauthauthurl =~ /twitter/) && ($oauthauthurl =~ s/^http:/https:/); $/ = $q; print $stdout <<"EOF"; Okay, your consumer key is ==> $ck and your consumer secret ==> $cs IF THIS IS WRONG, PRESS CTRL-C NOW AND RESTART THE WIZARD! Now we will verify your Imperial battle station is fully operational by signing in with OAuth. 1. Visit, in your browser, ALL ON ONE LINE (you should still be logged in), ${oauthauthurl}?oauth_token=$mytoken 2. Verify that your app is the requesting application, and that its permissions are as you expect (read your timeline, see who you follow and follow new people, update your profile, post tweets on your behalf and access your direct messages). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW! 3. Click Authorize app. 4. A PIN will appear. Enter it below. EOF print $stdout "Enter PIN> "; chomp($j = ); print $stdout "\nRequest from $oauthaccurl ..."; ($at, $ats) = &tryhardfortoken($oauthaccurl, "oauth_verifier=$j"); print $stdout <<"EOF"; Consumer key =========> $ck Consumer secret ======> $cs Access token =========> $at Access token secret ==> $ats EOF open(W, ">$keyf") || (print $stdout ("Unable to write to $keyf: $!\n"), exit); print W "ck=$ck&cs=$cs&at=$at&ats=$ats\n"; close(W); chmod(0600, $keyf) || print $stdout "Warning: could not change permissions on $keyf : $!\n"; print $stdout "Keys written to regenerated keyfile $keyf\n"; print $stdout "Now restart TTYtter.\n"; exit; } # now, get a token (either from Basic Auth, the keyfile or OAuth) ($mytoken, $mytokensecret) = &authtoken; } # unless anonymous # if we are testing the stream, this is where we split if ($streamtest) { print $stdout ">>> STREAMING CONNECT TEST <<< (kill process to end)\n"; &start_streaming; } # this never returns in this mode # initial login tests and command line controls if ($statusurl) { $shorstatusturl = &urlshorten($statusurl); $status = ((length($status)) ? "$status " : "") . $shorstatusturl; } $phase = 0; $didhold = $hold; $hold = -1 if ($hold == 1 && !$script); $credentials = ''; $status = pack("U0C*", unpack("C*", $status)) unless ($seven || !length($status) || $LANG =~ /8859/); # kludgy also if ($status eq '-') { chomp(@status = ); $status = join("\n", @status); } for(;;) { $rv = 0; die( "sorry, you can't tweet anonymously. use an authenticated username.\n") if ($anonymous && length($status)); die( "sorry, status too long: reduce by @{[ &length_tco($status)-$linelength ]} chars, ". "or use -autosplit={word,char,cut}.\n") if (&length_tco($status) > $linelength && !$autosplit); ($status, $next) = &csplit($status, ($autosplit eq 'char' || $autosplit eq 'cut') ? 1 : 0) if (!length($next)); if ($autosplit eq 'cut' && length($next)) { print "-- warning: input autotrimmed to $linelength bytes\n"; $next = ""; } if (!$anonymous && !length($whoami) && !length($status)) { # we must be using OAuth tokens. we'll need # to get our screen name from Twitter. we DON'T need this # if we're just posting with -status. print "(checking credentials) "; $data = $credentials = &backticks($baseagent, '/dev/null', undef, $credurl, undef, $anonymous, @wind); $rv = $? || &is_fail_whale($data) || &is_json_error($data); } if (!$rv && length($status) && $phase) { print "post attempt "; $rv = &updatest($status, 0); } else { # no longer a way to test anonymous logins unless ($rv || $anonymous) { print "test-login "; $data = &backticks($baseagent, '/dev/null', undef, $url, undef, $anonymous, @wind); $rv = $?; } } if ($rv || &is_fail_whale($data) || &is_json_error($data)) { if (&is_fail_whale($data)) { print "FAILED -- Fail Whale detected\n"; } elsif ($x = &is_json_error($data)) { print "FAILED!\n*** server reports: \"$x\"\n"; print "check your password or configuration.\n"; } else { $x = $rv >> 8; print "FAILED. ($x) bad password, login or URL? server down?\n"; } print "access failure on: "; print (($phase) ? $update : $url); print "\n"; print "--- data received ($hold) ---\n$data\n--- data received ($hold) ---\n" if ($superverbose); if ($hold && --$hold) { print "trying again in 1 minute, or kill process now.\n\n"; sleep 60; next; } if ($didhold) { print "giving up after $didhold tries.\n"; } else { print "to automatically wait for a connect, use -hold.\n"; } exit(1); } if ($status && !$phase) { print "SUCCEEDED!\n"; $phase++; next; } if (length($next)) { print "SUCCEEDED!\n(autosplit) "; $status = $next; $next = ""; next; } last; } print "SUCCEEDED!\n"; exit(0) if (length($status)); &sigify(sub { ; }, qw(USR1 PWR XCPU)); &sigify(sub { $background_is_ready++ }, qw(USR2 SYS UNUSED XFSZ)); if (length($credentials)) { print "-- processing credentials: "; $my_json_ref = &parsejson($credentials); $whoami = lc($my_json_ref->{'screen_name'}); if (!length($whoami)) { print "FAILED!\nis your account suspended, or wrong token?\n"; exit; } print "logged in as $whoami\n"; $credlog = "-- you are logged in as $whoami\n"; } #### BOT/DAEMON MODE STARTUP #### $last_rate_limit = undef; $rate_limit_left = undef; $rate_limit_rate = undef; $rate_limit_next = 0; $effpause = 0; # for both daemon and background if ($daemon) { if (!$pause) { print $stdout "*** kind of stupid to run daemon with pause=0\n"; exit 1; } if ($child = fork()) { print $stdout "*** detached daemon released. pid = $child\n"; kill 15, $$; exit 0; } elsif (!defined($child)) { print $stdout "*** fork() failed: $!\n"; exit 1; } else { $bufferpid = 0; if ($dostream) { &sigify(sub { kill $SIGHUP, $nursepid if ($nursepid); kill $SIGHUP, $bufferpid if ($bufferpid); kill 9, $curlpid if ($curlpid); sleep 1; # send myself a shutdown kill 9, $nursepid if ($nursepid); kill 9, $bufferpid if ($bufferpid); kill 9, $curlpid if ($curlpid); kill 9, $$; }, qw(TERM HUP PIPE)); &sigify("IGNORE", qw(INT)); $bufferpid = &start_streaming; $rin = ''; vec($rin, fileno(STBUF), 1) = 1; } $parent = 0; $dmcount = 1 if ($dmpause); # force fetch $is_background = 1; DAEMONLOOP: for(;;) { my $snooze; my $nfound; my $wake; &$heartbeat; &update_effpause; &refresh(0); $dont_refresh_first_time = 0; if ($dmpause) { if (!--$dmcount) { &dmrefresh(0); $dmcount = $dmpause; } } # service events on the streaming socket, if # we have one. $snooze = ($effpause || 0+$pause || 60); $wake = time() + $snooze; if (!$bufferpid) { sleep $snooze; } else { my $read_failure = 0; SLEEP_AGAIN: for(;;) { $nfound = select($rout = $rin, undef, undef, $snooze); if ($nfound && vec($rout, fileno(STBUF), 1)==1) { my $buf = ''; my $rbuf = ''; my $len; sysread(STBUF, $buf, 1); if (!length($buf)) { $read_failure++; # a stuck ready FH says # our buffer is dead; # see MONITOR: below. if ($read_failure>100){ print $stdout "*** unrecoverable failure of buffer process, aborting\n"; exit; } next SLEEP_AGAIN; } $read_failure = 0; if ($buf !~ /^[0-9a-fA-F]+$/) { print $stdout "-- warning: bogus character(s) ".unpack("H*", $buf)."\n" if ($superverbose); next SLEEP_AGAIN; } while (length($buf) < 8) { # don't read 8 -- read 1. that means we can # skip trailing garbage without a window. sysread(STBUF,$rbuf,1); if ($rbuf =~ /[0-9a-fA-F]/) { $buf .= $rbuf; } else { print $stdout "-- warning: bogus character(s) ".unpack("H*", $rbuf)."\n" if ($superverbose); $buf = '' if(length($rbuf)); } } print $stdout "-- length packet: $buf\n" if ($superverbose); $len = hex($buf); $buf = ''; while (length($buf) < $len) { sysread(STBUF, $rbuf, ($len-length($buf))); $buf .= $rbuf; } &streamevents( &parsejson($buf) ); $snooze = $wake - time(); next SLEEP_AGAIN if ($snooze > 0); } last SLEEP_AGAIN; } } } } die("uncaught fork() exception\n"); } #### INTERACTIVE MODE and CONSOLE STARTUP #### unless ($simplestart) { print <<"EOF"; ###################################################### +oo=========oo+ ${EM}TTYtter ${TTYtter_VERSION}.${padded_patch_version} (c)2012 cameron kaiser${OFF} @ @ EOF $e = <<'EOF'; ${EM}all rights reserved.${OFF} +oo= =====oo+ ${EM}http://www.floodgap.com/software/ttytter/${OFF} ${GREEN}a==:${OFF} ooo ${GREEN}.++o++.${OFF} ${GREEN}..o**O${OFF} freeware under the floodgap free software license. ${GREEN}+++${OFF} :O${GREEN}:::::${OFF} http://www.floodgap.com/software/ffsl/ ${GREEN}+**O++${OFF} # ${GREEN}:ooa${OFF} #+$$AB=. ${EM}tweet me: http://twitter.com/ttytter${OFF} #;;${YELLOW}ooo${OFF};; ${EM}tell me: ckaiser@floodgap.com${OFF} #+a;+++;O ###################################################### ,$B.${RED}*o***${OFF} O$, # a=o${RED}$*O*O*$${OFF}o=a # when ready, hit RETURN/ENTER for a prompt. @${RED}$$$$$${OFF}@ # type /help for commands or /quit to quit. @${RED}o${OFF}@o@${RED}o${OFF}@ # starting background monitoring process. @=@ @=@ # EOF $e =~ s/\$\{([A-Z]+)\}/${$1}/eg; print $stdout $e; } else { print <<"EOF"; TTYtter ${TTYtter_VERSION}.${padded_patch_version} (c)2012 cameron kaiser all rights reserved. freeware under the floodgap free software license. http://www.floodgap.com/software/ffsl/ tweet me: http://twitter.com/ttytter * tell me: ckaiser\@floodgap.com type /help for commands or /quit to quit. starting background monitoring process. EOF } if ($superverbose) { print $stdout "-- OMGSUPERVERBOSITYSPAM enabled.\n\n"; } else { print $stdout "-- verbosity enabled.\n\n" if ($verbose); } sleep 3 unless ($silent); # these three functions are outside of the usual API assertions for clarity. # they represent the main loop, which by default is the interactive console. # the main loop can be redefined. sub defaultprompt { my $rv = ($noprompt) ? "" : "TTYtter> "; my $rvl = ($noprompt) ? 0 : 9; return ($rv, $rvl) if (shift); $wrapseq = 0; print $stdout "${CCprompt}$rv${OFF}" unless ($termrl); } sub defaultaddaction { return 0; } sub defaultmain { if (length($runcommand)) { &prinput($runcommand); &sync_n_quit; } @history = (); print C "rsga---------------\n"; $dont_use_counter = $nocounter; eval '$termrl->hook_no_counter'; $tco_sub = sub { return &main::fastturntotco(shift); }; eval '$termrl->hook_no_tco'; if ($termrl) { while(defined ($_ = $termrl->readline((&$prompt(1))[0]))) { kill $SIGUSR1, $child; # suppress output $rv = &prinput($_); kill $SIGUSR2, $child; # resume output last if ($rv < 0); &sync_console unless (!$rv || !$synch); if ($dont_use_counter ne $nocounter) { # only if we have to -- this is expensive $dont_use_counter = $nocounter; eval '$termrl->hook_no_counter' } } } else { &$prompt; while(<>) { #not stdin so we can read from script files kill $SIGUSR1, $child; # suppress output $rv = &prinput(&uforcemulti($_)); kill $SIGUSR2, $child; # resume output last if ($rv < 0); &sync_console unless (!$rv || !$synch); &$prompt; } &sync_n_quit if ($script); } } # SIGPIPE in particular must be trapped in case someone kills the background # or, in streaming mode, buffer processes. we can't recover from that. # the streamer MUST have been initialized before we start these signal # handlers, or the streamer will try to run them too. eeek! # # DO NOT trap SIGCHLD: we generate child processes that die normally. &sigify(\&end_me, qw(PIPE INT)); &sigify(\&repaint, qw(USR1 PWR XCPU)); sub sigify { # this routine abstracts setting signals to a subroutine reference. # check and see if we have to use POSIX.pm (Perl 5.14+) or we can # still use $SIG for proper signalling. We prefer the latter, but # must support the former. my $subref = shift; my $k; if ($signals_use_posix) { my @w; my $sigaction = POSIX::SigAction->new($subref); while ($k = shift) { my $e = &posix_signal_of($k); # some signals may not exist on all systems. next if (!(0+$e)); POSIX::sigaction($e, $sigaction) || die("sigaction failure: $! $@\n"); } } else { while ($k = shift) { $SIG{$k} = $subref; } } } sub posix_signal_of { die("never call posix_signal_of if signals_use_posix is false\n") if (!$signals_use_posix); # this assumes that POSIX::SIG* returns a scalar int value. # not all signals exist on all systems. this ensures zeroes are # returned for locally bogus ones. return 0+(eval("return POSIX::SIG".shift)); } sub send_repaint { unless ($wrapseq){ return; } $wrapseq = 0; return if ($daemon); if ($child) { # we are the parent, call our repaint &repaint; } else { # we are not the parent, call the parent to repaint itself kill $SIGUSR1, $parent; # send SIGUSR1 } } sub repaint { # try to speed this up, since we do it a lot. $wrapseq = 0; return &$repaintcache if ($repaintcache) ; # cache our repaint function (no-op or redisplay) $repaintcache = sub { ; }; # no-op return unless ($termrl && ($termrl->Features()->{'canRepaint'} || $readlinerepaint)); return if ($daemon); $termrl->redisplay; $repaintcache = sub { $termrl->redisplay; }; } sub send_removereadline { # this just stubs into its own removereadline return &$removereadlinecache if ($removereadlinecache); $removereadlinecache = sub { ; }; return unless ($termrl && $termrl->Features()->{'canRemoveReadline'}); return if ($daemon); $termrl->removereadline; $removereadlinecache = sub { $termrl->removereadline; }; } # start the background process # this has to be last or the background process can't see the full API if ($child = open(C, "|-")) { close(P); binmode(C, ":utf8") unless ($seven); } else { close(W); goto MONITOR; } eval'$termrl->hook_background_control' if ($termrl); select(C); $|++; select($stdout); # handshake for synchronicity mode, if we want it. if ($synch) { # we will get two replies for this. print C "synm---------------\n"; &thump; # the second will be cleared by the console } # wait for background to become ready sleep 1 while (!$background_is_ready); # start the &$main; # loop until we quit and then we'll &sync_n_quit if ($script); # else exit; #### command processor #### sub prinput { my $i; local($_) = shift; # bleh # validate this string if we are in UTF-8 mode unless ($seven) { $probe = $_; &$utf8_encode($probe); die("utf8 doesn't work right in this perl. run with -seven.\n") if (&ulength($probe) < length($_)); # should be at least as big if ($probe =~ /($badutf8)/) { print $stdout "*** invalid UTF-8: partial delete of a wide character?\n"; print $stdout "*** ignoring this string\n"; return 0; } } $in_reply_to = 0; chomp; $_ = &$precommand($_); s/^\s+//; s/\s+$//; my $cfc = 0; $cfc++ while (s/\033\[[0-9]?[ABCD]// || s/.[\177]// || s/.[\010]// || s/[\000-\037\177]//); if ($cfc) { $history[0] = $_; print $stdout "*** filtered control characters; now \"$_\"\n"; print $stdout "*** use %% for truncated version, or append to %%.\n"; return 0; } if (/^$/) { return 1; } if (!$slowpost && !$verify && # we assume you know what you're doing! ($_ eq 'h' || $_ eq 'help' || $_ eq 'quit' || $_ eq 'q' || /^TTYtter>/ || $_ eq 'ls' || $_ eq '?' || m#^help /# || $_ eq 'exit')) { &add_history($_); unless ($_ eq 'exit' || /^TTYtter>/ || $_ eq 'ls') { print $stdout "*** did you mean /$_ ?\n"; print $stdout "*** to send this as a command, type /%%\n"; } else { print $stdout "*** did you really mean to tweet \"$_\"?\n"; } print $stdout "*** to tweet it anyway, type %%\n"; return 0; } if (/^\%(\%|-\d+):p$/) { my $x = $1; if ($x eq '%') { print $stdout "=> \"$history[0]\"\n"; } else { $x += 0; if (!$x || $x < -(scalar(@history))) { print $stdout "*** illegal index\n"; } else { print $stdout "=> \"$history[-($x + 1)]\"\n"; } } return 0; } # handle history substitution (including /%%, %%--, %%*, etc.) $i = 0; # flag if (/^\%(\%|-\d+)(--|-\d+|\*)?/) { ($i, $proband, $r, $s) = &sub_helper($1, $2, $_); return 0 if (!$i); $s = quotemeta($s); s/^\%${r}${s}/$proband/; } if (/[^\\]\%(\%|-\d+)(--|-\d+|\*)?$/) { ($i, $proband, $r, $s) = &sub_helper($1, $2, $_); return 0 if (!$i); $s = quotemeta($s); s/\%${r}${s}$/$proband/; } # handle variables second, in case they got in history somehow ... $i = 1 if (s/^\%URL\%/$urlshort/ || s/\%URL\%$/$urlshort/); $i = 1 if (s/^\%RT\%/$retweet/ || s/\%RT\%$/$retweet/); # and escaped history s/^\\\%/%/; if ($i) { print $stdout "(expanded to \"$_\")\n" ; $in_reply_to = $expected_tweet_ref->{'id_str'} || 0 if (defined $expected_tweet_ref && ref($expected_tweet_ref) eq 'HASH'); } else { $expected_tweet_ref = undef; } return 0 unless length; # actually possible to happen # with control char filters and history. &add_history($_); $shadow_history = $_; # handle history display if ($_ eq '/history' || $_ eq '/h') { for ($i = scalar(@history); $i >= 1; $i--) { print $stdout "\t$i\t$history[($i-1)]\n"; } return 0; } my $slash_first = ($_ =~ m#^/#); return -1 if ($_ eq '/quit' || $_ eq '/q' || $_ eq '/bye' || $_ eq '/exit'); return 0 if (scalar(&$addaction($_))); # add commands here # dumper if (m#^/du(mp)? ([zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($2); unless ($code =~ /^d[0-9][0-9]+$/) { # this is a DM. my $tweet = &get_tweet($code); my $k; my $sn; my $id; my @superfields = ( [ "user", "screen_name" ], # must always be first [ "retweeted_status", "id_str" ], [ "user", "geo_enabled" ], [ "place", "id" ], [ "place", "country_code" ], [ "place", "full_name" ], [ "place", "place_type" ], [ "tag", "type" ], [ "tag", "payload" ], ); my $superfield; if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } foreach $superfield (@superfields) { my $sfn = join('->', @{ $superfield }); my $sfk = "{'" . join("'}->{'", @{ $superfield }) . "'}"; my $sfv; eval "\$sfv = &descape(\$tweet->$sfk);"; print $stdout substr("$sfn ", 0, 25). " $sfv\n"; $sn = $sfv if (!length($sn) && length($sfv)); } # geo is special print $stdout "geo->coordinates (" . join(', ', @{ $tweet->{'geo'}->{'coordinates'} }) . ")\n"; foreach $k (sort keys %{ $tweet }) { next if (ref($tweet->{$k})); print $stdout substr("$k ", 0, 25) . " " . &descape($tweet->{$k}) . "\n"; } # include a URL to the tweet per @augmentedfourth $urlshort = "${http_proto}://twitter.com/$sn/statuses/$tweet->{'id_str'}"; print $stdout "-- %URL% is now $urlshort (/short to shorten)\n"; return 0; } # if dxxxx, fall through to the below. } if (m#^/du(mp)? ([dD][a-zA-Z]?[0-9]+)$#) { my $code = lc($2); my $dm = &get_dm($code); my $k; my $sn; my $id; my @superfields = ( [ "sender", "screen_name" ], # must always be first ); if (!defined($dm)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } foreach $superfield (@superfields) { my $sfn = join('->', @{ $superfield }); my $sfk = "{'" . join("'}->{'", @{ $superfield }) . "'}"; my $sfv; eval "\$sfv = &descape(\$dm->$sfk);"; print $stdout substr("$sfn ", 0, 25). " $sfv\n"; $sn = $sfv if (!length($sn) && length($sfv)); } foreach $k (sort keys %{ $dm }) { next if (ref($dm->{$k})); print $stdout substr("$k ", 0, 25) . " " . &descape($dm->{$k}) . "\n"; } return 0; } # evaluator if (m#^/ev(al)? (.+)$#) { $k = eval $2; print $stdout "==> "; print $streamout "$k $@\n"; return 0; } # version check if (m#^/v(ersion)?check$# || m#^/u(pdate)?check$#) { print $stdout &updatecheck(1); return 0; } # url shortener routine if (($_ eq '/sh' || $_ eq '/short') && length($urlshort)) { $_ = "/short $urlshort"; print $stdout "*** assuming you meant %URL%: $_\n"; # and fall through to ... } if (m#^/sh(ort)? (https?|gopher)(://[^ ]+)#) { my $url = $2 . $3; my $answer = (&urlshorten($url) || 'FAILED -- %% to retry'); print $stdout "*** shortened to: "; print $streamout ($answer . "\n"); return 0; } # getter for internal value settings if (/^\/r(ate)?l(imit)?$/) { $_ = '/print rate_limit_rate'; # and fall through to ... } if ($_ eq '/p' || $_ eq '/print') { foreach $key (sort keys %opts_can_set) { print $stdout "*** $key => $$key\n" if (!$opts_secret{$key}); } return 0; } if (/^\/p(rint)?\s+([^ ]+)/) { my $key = $2; if ($valid{$key} || $key eq 'effpause' || $key eq 'rate_limit_rate' || $key eq 'rate_limit_left') { my $value = &getvariable($key); print $stdout "*** "; print $stdout "(read-only value) " if (!$opts_can_set{$key}); print $stdout "$key => $value\n"; # I don't see a need for these in &getvariable, so they are # not currently supported. whine if you disagree. } elsif ($key eq 'tabcomp') { if ($termrl) { &generate_otabcomp; } else { print $stdout "*** readline isn't on\n"; } } elsif ($key eq 'ntabcomp') { # sigh if ($termrl) { print $stdout "*** new TAB-comp entries: "; $did_print = 0; foreach(keys %readline_completion) { next if ($original_readline{$_}); $did_print = 1; print $stdout "$_ "; } print $stdout "(none)" if (!$did_print); print $stdout "\n"; } else { print $stdout "*** readline isn't on\n"; } } else { print "*** not a valid option or setting: $key\n"; } return 0; } if ($_ eq '/verbose' || $_ eq '/ve') { $verbose ^= 1; $_ = "/set verbose $verbose"; print $stdout "-- verbosity.\n" if ($verbose); # and fall through to set } # search api integration (originally based on @kellyterryjones', # @vielmetti's and @br3nda's patches) if (/^\/se(arch)?\s+(\+\d+\s+)?(.+)\s*$/) { my $countmaybe = $2; my $kw = $3; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $countmaybe ||= $searchhits; $kw = &url_oauth_sub($kw); $kw = "q=$kw" if ($kw !~ /^q=/); my $r = &grabjson("$queryurl?$kw", 0, 0, $countmaybe, { "type" => "search", "payload" => $k }, 1); if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })) { &dt_tdisplay($r, 'search'); } else { print $stdout "-- sorry, no results were found.\n"; } &$conclude; return 0; } if ($_ eq '/notrack') { # special case print $stdout "*** all tracking keywords cancelled\n"; $track = ''; &setvariable('track', $track, 1); return 0; } if (s/^\/troff\s+// && s/\s*// && length) { # remove it from array, regenerate $track, call tracktags_makearray # and then sync my $k; my $l = ''; my $q = 0; my %w; $_ = lc($_); my (@ptags) = split(/\s+/, $_); # filter duplicates and merge quoted strings (again) # but this time we're building up a hash for fast searches foreach $k (@ptags) { if ($q && $k =~ /"$/) { # this has to be first $l .= " $k"; $q = 0; } elsif ($k =~ /^"/ || $q) { $l .= (length($l)) ? " $k" : $k; $q = 1; next; } else { $l = $k; } next if ($w{$l}); # ignore silently here $w{$l} = 1; $l = ''; } print $stdout "-- warning: syntax error, missing quote?\n" if ($q); # now filter out of @tracktags @ptags = (); foreach $k (@tracktags) { push (@ptags, $k) unless ($w{$k}); } unless (scalar(@ptags) < scalar(@tracktags)) { print $stdout "-- sorry, no track terms matched.\n"; print $stdout (length($track) ? "-- you are tracking: $track\n" : "-- (maybe because you're not tracking anything?)\n"); return 0; } print $stdout "*** ok, filtered @{[ keys(%w) ]}\n"; $track = join(' ', @ptags); &setvariable('track', $track, 1); return 0; } if (s#^/tre(nds)?\s*##) { my $t = undef; my $wwoeid = (length) ? $_ : $woeid; $wwoeid ||= "1"; my $r = &grabjson("${wtrendurl}?id=${wwoeid}", 0, 0, 0, undef, 1); my $fr = ($wwoeid && $wwoeid ne '1') ? " FOR WOEID $wwoeid" : ' GLOBALLY'; if (defined($r) && ref ($r) eq 'ARRAY') { $t = $r->[0]->{'trends'}; } if (defined($t) && ref($t) eq 'ARRAY') { my $i; my $j; print $stdout "${EM}<<< TRENDING TOPICS${fr} >>>${OFF}\n"; foreach $j (@{ $t }) { my $k = &descape($j->{'name'}); my $l = ($k =~ /\sOR\s/) ? $k : ($k =~ /^"/) ? $k : ('"' . $k . '"'); print $streamout "/search $l\n"; $k =~ s/\sOR\s/ /g; $k = '"' . $k . '"' if ($k =~ /\s/ && $k !~ /^"/); print $streamout "/tron $k\n"; } print $stdout "${EM}<<< TRENDING TOPICS >>>${OFF}\n"; } else { print $stdout "-- sorry, trends not available for WOEID $wwoeid.\n"; } return 0; } # woeid finder based on lat/long if ($_ eq '/woeids') { my $max = 10; if (!$lat && !$long) { print $stdout "-- set your location with lat/long first.\n"; return 0; } my $r = &grabjson("$atrendurl?lat=$lat&long=$long", 0, 0, 0, undef, 1); if (defined($r) && ref($r) eq 'ARRAY') { my $i; foreach $i (@{ $r }) { my $woeid = &descape($i->{'woeid'}); my $nm = &descape($i->{'name'}) . ' (' . &descape($i->{'countryCode'}) .')'; print $streamout "$nm\n/set woeid $woeid\n"; last unless ($max--); } } else { print $stdout "-- sorry, couldn't get a supported WOEID for your location.\n"; } return 0; } 1 if (s/^\/#([^\s]+)/\/tron #\1/); # /# command falls through to tron if (s/^\/tron\s+// && s/\s*$// && length) { $_ = lc($_); $track .= " " if (length($track)); $_ = "/set track ${track}$_"; # fall through to set } if (/^\/track ([^ ]+)/) { s#^/#/set #; # and fall through to set } # /listoff if (s/^\/list?off\s+// && s/\s*$// && length) { if (/,/ || /\s+/) { print $stdout "-- one list at a time please\n"; return 0; } if (!scalar(@listlist)) { print $stdout "-- ok! that was easy! (you don't have any lists in your timeline)\n"; return 0; } my $w; my $newlists = ''; my $didfilter = 0; foreach $w (@listlist) { my $x = join('/', @{ $w }); if ($x eq $_ || "$whoami$_" eq $x || "$whoami/$_" eq $x) { print $stdout "*** ok, filtered $x\n"; $didfilter = 1; } else { $newlists .= (length($newlists)) ? ",$x" : $x; } } if ($didfilter) { &setvariable('lists', $newlists, 1); } else { print $stdout "*** hmm, no such list? current value:\n"; print $stdout "*** lists => ", &getvariable('lists'), "\n"; } return 0; } # /liston if (s/^\/list?on\s+// && s/\s*$// && length) { if (/,/ || /\s+/) { print $stdout "-- one list at a time please\n"; return 0; } my $uname; my $lname; if (m#/#) { ($uname, $lname) = split(m#/#, $_, 2); } else { $lname = $_; $uname = ''; } if (!length($uname) && $anonymous) { print $stdout "-- you must specify a username for a list when anonymous.\n"; return 0; } $uname ||= $whoami; # check the list validity my $my_json_ref = &grabjson( "${statusliurl}?owner_screen_name=${uname}&slug=${lname}", 0, 0, 0, undef, 1); if (!$my_json_ref || ref($my_json_ref) ne 'ARRAY') { print $stdout "*** list $uname/$lname seems bogus; not added\n"; return 0; } $_ = "/add lists $uname/$lname"; # fall through to add } if (s/^\/a(uto)?lists?\s+// && s/\s*$// && length) { s/\s+/,/g if (!/,/); print $stdout "--- warning: lists aren't checked en masse; make sure they exist\n"; $_ = "/set lists $_"; # and fall through to set } # setter for internal value settings # shortcut for boolean settings if (/^\/s(et)? ([^ ]+)\s*$/) { my $key = $2; $_ = "/set $key 1" if($opts_boolean{$key} && $opts_can_set{$key}); # fall through to three argument version } if (/^\/uns(et)? ([^ ]+)\s*$/) { my $key = $2; if ($opts_can_set{$key} && $opts_boolean{$key}) { &setvariable($key, 0, 1); return 0; } &setvariable($key, undef, 1); return 0; } # stubs out to set variable if (/^\/s(et)? ([^ ]+) (.+)\s*$/) { my $key = $2; my $value = $3; &setvariable($key, $value, 1); return 0; } # append to a variable (if not boolean) if (/^\/ad(d)? ([^ ]+) (.+)\s*$/) { my $key = $2; my $value = $3; if ($opts_boolean{$key}) { print $stdout "*** why are you appending to a boolean?\n"; return 0; } if (length(&getvariable($key))) { $value = " $value" if ($opts_space_delimit{$key}); $value = ",$value" if ($opts_comma_delimit{$key}); } &setvariable($key, &getvariable($key).$value, 1); return 0; } # delete from a variable (if not boolean) if (/^\/del ([^ ]+) (.+)\s*$/) { my $key = $1; my $value = $2; my $old; if ($opts_boolean{$key}) { print $stdout "*** why are you deleting from a boolean?\n"; return 0; } if (!length($old = &getvariable($key))) { print $stdout "*** $key is already empty\n"; return 0; } my $del = ($opts_space_delimit{$key}) ? '\s+' : ($opts_comma_delimit{$key}) ? '\s*,\s*' : undef; if (!defined($del)) { # simple substitution 1 while ($old =~ s/$value//g); } else { 1 while ($old =~ s/$del$value($del)/\1/g); 1 while ($old =~ s/^$value$del//); 1 while ($old =~ s/$del$value//); } &setvariable($key, $old, 1); return 0; } # I thought about implementing a /pdel but besides being ugly # I don't think most people will push a truncated setting. tell me # if I'm wrong. # stackable settings if (/^\/pu(sh)? ([^ ]+)\s*$/) { my $key = $2; if ($opts_can_set{$key}) { if ($opts_boolean{$key}) { $_ = "/push $key 1"; # fall through to three argument version } else { if (!$opts_can_set{$key}) { print $stdout "*** setting is not stackable: $key\n"; return 0; } my $old = &getvariable($key); push(@{ $push_stack{$key} }, $old); print $stdout "--- saved on stack for $key: $old\n"; return 0; } } } # common code for set and append if (/^\/(pu|push|pad|padd) ([^ ]+) (.+)\s*$/) { my $comm = $1; my $key = $2; my $value = $3; $comm = ($comm =~ /^pu/) ? "push" : "padd"; if ($opts_boolean{$key} && $comm eq 'padd') { print $stdout "*** why are you appending to a boolean?\n"; return 0; } if (!$opts_can_set{$key}) { print $stdout "*** setting is not stackable: $key\n"; return 0; } my $old = &getvariable($key); $old += 0 if ($opts_boolean{$key}); push(@{ $push_stack{$key} }, $old); print $stdout "--- saved on stack for $key: $old\n"; if ($comm eq 'padd' && length($old)) { $value = " $value" if ($opts_space_delimit{$key}); $value = ",$value" if ($opts_comma_delimit{$key}); $old .= $value; } else { $old = $value; } &setvariable($key, $old, 1); return 0; } # we assume that if the setting is in the push stack, it's valid if (/^\/pop ([^ ]+)\s*$/) { my $key = $1; if (!scalar(@{ $push_stack{$key} })) { print $stdout "*** setting is not stacked: $key\n"; return 0; } &setvariable($key, pop(@{ $push_stack{$key} }), 1); return 0; } # shell escape if (s/^\/\!// && s/\s*$// && length) { system("$_"); $x = $? >> 8; print $stdout "*** exited with $x\n" if ($x); return 0; } if ($_ eq '/help' || $_ eq '/?') { print <<'EOF'; *** BASIC COMMANDS: :a$AAOOOOOOOOOOOOOOOOOAA$a, ================== +@A:. .:B@+ ANYTHING WITHOUT /refresh =@B HELP!!! HELP!!! B@= A LEADING / IS grabs the newest :a$Ao oA$a, SENT AS A TWEET! tweets right ;AAA$a; :a$AAAAAAAAAAA; ================== away (or tells :AOaaao:, .:oA*:. JUST TYPE TO TALK! you if there .;=$$$OBO***+ .+aaaa$: is nothing new) :*; :***O@Aaaa*o, ============ by thumping .+++++: o#o REMEMBER!! the background :OOOOOOA*:::, =@o ,:::::. ============ process. .+++++++++: =@*.....=a$OOOB#; MANY COMMANDS, AND =@OoO@BAAA#@$o, ALL TWEETS ARE /again =@o .+aaaaa: --ASYNCHRONOUS-- displays most recent =@Aaaaaaaaaa*o*a;, and might not always tweets, both old and =@$++=++++++:,;+aA: respond new. ,+$@*.=O+ ...oO; oAo+. immediately! ,+o$OO=.+aA#####Oa;.*OO$o+. /dm and /dmagain for DMs. +Ba::;oaa*$Aa=aA$*aa=;::$B: ,===O@BOOOOOOOOO#@$===, /replies o@BOOOOOOOOO#@+ ================== shows replies and mentions. o@BOB@B$B@BO#@+ USE + FOR A COUNT: o@*.a@o a@o.$@+ /re +30 => last 30 replies /quit resumes your boring life. o@B$B@o a@A$#@+ ========================== EOF &linein("PRESS RETURN/ENTER>"); print <<"EOF"; +- MORE COMMANDS -+ -=-=- USER STUFF -=-=- | | /whois username displays info about username | See the TTYtter | /again username views their most recent tweets | home page for | /wagain username combines them all | complete list | /follow username follow a username | | /leave username stop following a username +-----------------+ /dm username message send a username a DM +--- TWEET AND DM SELECTION -------------------------------------------------+ | all DMs and tweets have menu codes (letters + number, d for DMs). example: | | a5> Send me Dr Pepper http://www.floodgap.com/TTYtter | | [DM da0][ttytter/Sun Jan 32 1969] I think you are cute | | /reply a5 message replies to tweet a5 | | example: /reply a5 I also like Dr Pepper | | becomes \@ttytter I also like Dr Pepper (and is threaded) | | /thread a5 if a5 is part of a thread (the username | | has a \@) then show all posts up to that | | /url a5 opens all URLs in tweet a5 | | Mac OS X users, do first: /set urlopen open %U | | Dummy terminal users, try /set urlopen lynx -dump %U | more | | /delete a5 deletes tweet a5, if it's your tweet | | /rt a5 retweets tweet a5: RT \@tytter: Send me...| +-- Abbreviations: /re, /th, /url, /del --- menu codes wrap around at end ---+ =====> /reply, /delete and /url work for direct message menu codes too! <===== EOF &linein("PRESS RETURN/ENTER>"); print <<"EOF"; Use /set to turn on options or set them at runtime. There is a BIG LIST! >> EXAMPLE: WANT ANSI? /set ansi 1 or use the -ansi command line option. WANT TO VERIFY YOUR TWEETS BEFORE POSTING? /set verify 1 or use the -verify command line option. For more, like readline support, UTF-8, SSL, proxies, etc., see the docs. ** READ THE COMPLETE DOCUMENTATION: http://www.floodgap.com/software/ttytter/ TTYtter $TTYtter_VERSION is (c)2012 cameron kaiser + contributors. all rights reserved. this software is offered AS IS, with no guarantees. it is not endorsed by Obvious or the executives and developers of Twitter. *** subscribe to updates at http://twitter.com/ttytter or http://twitter.com/floodgap send your suggestions to me at ckaiser\@floodgap.com or http://twitter.com/doctorlinguist EOF return 0; } if ($_ eq '/ruler' || $_ eq '/ru') { my ($prompt, $prolen) = (&$prompt(1)); $prolen = " " x $prolen; print $stdout <<"EOF"; ${prolen} 1 2 3 4 5 6 7 8 9 0 1 2 3 XX ${prompt}1...5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5....0....5...XX EOF return 0; } if ($_ eq '/cls' || $_ eq '/clear') { if ($ansi) { print $stdout "${ESC}[H${ESC}[2J\n"; } else { print $stdout ("\n" x ($ENV{'ROWS'} || 50)); } return 0; } if ($_ eq '/refresh' || $_ eq '/thump' || $_ eq '/r') { print $stdout "-- /refresh in streaming mode is pretty impatient\n" if ($dostream); &thump; return 0; } if (m#^/a(gain)?(\s+\+\d+)?$#) { # the asynchronous form my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if ($countmaybe > 999) { print $stdout "-- greedy bastard, try +fewer.\n"; return 0; } $countmaybe = sprintf("%03i", $countmaybe); print $stdout "-- background request sent\n" unless ($synch); print C "reset${countmaybe}-----------\n"; &sync_semaphore; return 0; } # this is for users -- list form is below if ($_ =~ m#^/(w)?a(gain)?\s+(\+\d+\s+)?([^\s/]+)$#) { #synchronous form my $mode = $1; my $uname = lc($4); my $countmaybe = $3; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $uname =~ s/^\@//; $readline_completion{'@'.$uname}++ if ($termrl); print $stdout "-- synchronous /again command for $uname ($countmaybe)\n" if ($verbose); my $my_json_ref = &grabjson("${uurl}?screen_name=${uname}&include_rts=true", 0, 0, $countmaybe, undef, 1); &dt_tdisplay($my_json_ref, 'again'); unless ($mode eq 'w' || $mode eq 'wf') { return 0; } # else fallthrough } if ($_ =~ m#^/w(hois|a|again)?\s+(\+\d+\s+)?\@?([^\s]+)#) { my $uname = lc($3); $uname =~ s/^\@//; $readline_completion{'@'.$uname}++ if ($termrl); print $stdout "-- synchronous /whois command for $uname\n" if ($verbose); my $my_json_ref = &grabjson("${wurl}?screen_name=${uname}", 0, 0, 0, undef, 1); if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' && length($my_json_ref->{'screen_name'})) { my $sturl = undef; my $purl = &descape($my_json_ref->{'profile_image_url'}); if ($avatar && length($purl) && $purl !~ m#^http://[^.]+\.(twimg\.com|twitter\.com).+/images/default_profile_\d+_normal.png#) { my $exec = $avatar; my $fext; ($purl =~ /\.([a-z0-9A-Z]+)$/) && ($fext = $1); if ($purl !~ /['\\]/) { # careful! $exec =~ s/\%U/'$purl'/g; $exec =~ s/\%N/$uname/g; $exec =~ s/\%E/$fext/g; print $stdout "\n"; print $stdout "($exec)\n" if ($verbose); system($exec); } } print $streamout "\n"; &userline($my_json_ref, $streamout); print $streamout &wwrap( "\"@{[ &strim(&descape($my_json_ref->{'description'})) ]}\"\n") if (length(&strim($my_json_ref->{'description'}))); if (length($my_json_ref->{'url'})) { $sturl = $urlshort = &descape($my_json_ref->{'url'}); $urlshort =~ s/^\s+//; $urlshort =~ s/\s+$//; print $streamout "${EM}URL:${OFF}\t\t$urlshort\n"; } print $streamout &wwrap( "${EM}Location:${OFF}\t@{[ &descape($my_json_ref->{'location'}) ]}\n") if (length($my_json_ref->{'location'})); print $streamout <<"EOF"; ${EM}Picture:${OFF}\t@{[ &descape($my_json_ref->{'profile_image_url'}) ]} EOF unless ($anonymous || $whoami eq $uname) { my $g = &grabjson( "$frurl?source_screen_name=$whoami&target_screen_name=$uname", 0, 0, 0, undef, 1); print $streamout &wwrap( "${EM}Do you follow${OFF} this user? ... ${EM}$g->{'relationship'}->{'target'}->{'followed_by'}${OFF}\n") if (ref($g) eq 'HASH'); my $g = &grabjson( "$frurl?source_screen_name=$uname&target_screen_name=$whoami", 0, 0, 0, undef, 1); print $streamout &wwrap( "${EM}Does this user follow${OFF} you? ... ${EM}$g->{'relationship'}->{'target'}->{'followed_by'}${OFF}\n") if (ref($g) eq 'HASH'); print $streamout "\n"; } print $stdout &wwrap( "-- %URL% is now $urlshort (/short shortens, /url opens)\n") if (defined($sturl)); } return 0; } if (m#^/(df|doesfollow)\s+\@?([^\s]+)$#) { if ($anonymous) { print $stdout "-- who follows anonymous anyway?\n"; return 0; } $_ = "/doesfollow $2 $whoami"; print $stdout "*** assuming you meant: $_\n"; # fall through to ... } if (m#^/(df|doesfollow)\s+\@?([^\s]+)\s+\@?([^\s]+)$#) { my $user_a = $2; my $user_b = $3; if ($user_a =~ m#/# || $user_b =~ m#/#) { print $stdout "--- sorry, this won't work on lists.\n"; return 0; } my $g = &grabjson( "${frurl}?source_screen_name=${user_a}&target_screen_name=${user_b}", 0, 0, 0, undef, 1); if ($msg = &is_json_error($g)) { print $stdout <<"EOF"; ${MAGENTA}*** warning: server error message received *** "$ec"${OFF} EOF } elsif ($g->{'relationship'}->{'target'}) { print $stdout "--- does $user_a follow ${user_b}? => "; print $streamout "$g->{'relationship'}->{'target'}->{'followed_by'}\n" } else { print $stdout "-- sorry, bogus server response, try again later.\n"; } return 0; } # this is dual-headed and supports both lists and regular followers. if(s#^/(frs|friends|fos|followers)(\s+\+\d+)?\s*##) { my $countmaybe = $2; my $mode = $1; my $arg = lc($_); my $lname = ''; my $user = ''; my $what = ''; $arg =~ s/^@//; $who = $arg; ($who, $lname) = split(m#/#, $arg, 2) if (m#/#); if (length($lname) && !length($user) && $anonymous) { print $stdout "-- you must specify a username for a list when anonymous.\n"; return 0; } $who ||= $whoami; if (!length($lname)) { $what = ($mode eq 'frs' || $mode eq 'friends') ? "friends" : "followers"; $mode = ($mode eq 'frs' || $mode eq 'friends') ? $friendsurl : $followersurl; } else { $what = ($mode eq 'frs' || $mode eq 'friends') ? "friends/members" : "followers/subscribers"; $mode = ($mode eq 'frs' || $mode eq 'friends') ? $getliurl : $getfliurl; $user = "&owner_screen_name=${who}&slug=${lname}"; $who = "list $who/$lname"; } $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $countmaybe ||= 20; # we use the undocumented count= support to, by default, # reduce the JSON parsing overhead. if we always had to take # all 100, we really eat it on parsing. the downside is that, # per @episod, the stuff we get is "less" fresh. my $countper = ($countmaybe < 100) ? $countmaybe : 100; if (!length($lname)) { # we need to get IDs, then call lookup. right now it's # limited to 5000 because that is the limit for API 1.1 # without having to do pagination here too. sorry. if ($countmaybe >= 5000) { print $stdout "-- who do you think you are? Scoble? currently limited to 4999 or less\n"; return 0; } # grab all the IDs my $ids_ref = &grabjson( "$mode?count=${countmaybe}&screen_name=${who}&stringify_ids=true", 0, 0, 0, undef, 1); return 0 if (!$ids_ref || ref($ids_ref) ne 'HASH' || !$ids_ref->{'ids'}); $ids_ref = $ids_ref->{'ids'}; return 0 if (ref($ids_ref) ne 'ARRAY'); my @ids = @{ $ids_ref }; @ids = sort { 0+$a <=> 0+$b } @ids; # make it somewhat deterministic my $dount = &min($countmaybe, scalar(@ids)); my $swallow = &min(100, $dount); my @usarray = undef; shift(@usarray); # force underflow my $l_ref = undef; # for each block of $countper, emit my $printed = 0; FFABIO: while ($dount--) { if (!scalar(@usarray)) { my @next_ids; last FFABIO if (!scalar(@ids)); # if we asked for less than 100, get # that. otherwise, # get the top 100 off that list (or # the list itself, if 100 or less) if (scalar(@ids) <= $swallow) { @next_ids = @ids; @ids = (); } else { @next_ids = @ids[0..($swallow-1)]; @ids = @ids[$swallow..$#ids]; } # turn it into a list to pass to # lookupidurl and get the list $l_ref = &postjson($lookupidurl, "user_id=".&url_oauth_sub(join(',', @next_ids))); last FFABIO if(ref($l_ref) ne 'ARRAY'); @usarray = sort { 0+($a->{'id'}) <=> 0+($b->{'id'}) } @{ $l_ref }; last if (!scalar(@usarray)); } &$userhandle(shift(@usarray)); $printed++; } print $stdout "-- sorry, no $what found for $who.\n" if (!$printed); return 0; } # lists # loop through using the cursor until desired number. my $cursor = -1; # initial value my $printed = 0; my $nofetch = 0; my $json_ref = undef; my @usarray = undef; shift(@usarray); # force underflow # this is a simpler version of the above. FABIO: while($countmaybe--) { if(!scalar(@usarray)) { last FABIO if ($nofetch); $json_ref = &grabjson( "${mode}?count=${countper}&cursor=${cursor}${user}", 0, 0, 0, undef, 1); @usarray = @{ $json_ref->{'users'} }; last FABIO if (!scalar(@usarray)); $cursor = $json_ref->{'next_cursor_str'} || $json_ref->{'next_cursor'} || -1; $nofetch = ($cursor < 1) ? 1 : 0; } &$userhandle(shift(@usarray)); $printed++; } print $stdout "-- sorry, no $what found for $who.\n" if (!$printed); return 0; } # threading if (m#^/th(read)?\s+(\+\d+\s+)?([zZ]?[a-zA-Z]?[0-9]+)$#) { my $countmaybe = $2; if (length($countmaybe)) { print $stdout "-- /thread does not (yet) support +count\n"; return 0; } my $code = lc($3); my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } my $limit = 9; my $id = $tweet->{'retweeted_status'}->{'id_str'} || $tweet->{'in_reply_to_status_id_str'}; my $thread_ref = [ $tweet ]; while ($id && $limit) { print $stdout "-- thread: fetching $id\n" if ($verbose); my $next = &grabjson("${idurl}?id=${id}", 0, 0, 0, undef, 1); $id = 0; $limit--; if (defined($next) && ref($next) eq 'HASH') { push(@{ $thread_ref }, &fix_geo_api_data($next)); $id = $next->{'retweeted_status'}->{'id_str'} || $next->{'in_reply_to_status_id_str'} || 0; } } &tdisplay($thread_ref, 'thread', 0, 1); # use the mini-menu return 0; } # pull out entities. this works for DMs and tweets. # btw: T.CO IS WACK. if (m#^/ent?(ities)? ([dDzZ]?[a-zA-Z]?[0-9]+)$#) { my $v; my $w; my $thing; my $genurl; my $code = lc($2); my $hash; if ($code !~ /[a-z]/) { # this is an optimization: we don't need to get # the old tweet since we're going to fetch it anyway. $hash = { "id_str" => $code }; $thing = "tweet"; $genurl = $idurl; } elsif ($code =~ /^d.[0-9]+$/) { $hash = &get_dm($code); $thing = "DM"; $genurl = $dmidurl; } else { $hash = &get_tweet($code); $thing = "tweet"; $genurl = $idurl; } if (!defined($hash)) { print $stdout "-- no such $thing (yet?): $code\n"; return 0; } my $id = $hash->{'id_str'}; $hash = &grabjson("${genurl}?id=${id}", 0, 0, 0, undef, 1); if (!defined($hash) || ref($hash) ne 'HASH') { print $stdout "-- failed to get entities from server, sorry\n"; return 0; } # if a retweeted status, get the status. $hash = $hash->{'retweeted_status'} if (defined($hash->{'retweeted_status'}) && ref($hash->{'retweeted_status'}) eq 'HASH'); my $didprint = 0; # Twitter puts entities in multiple fields. foreach $w (qw(media urls)) { my $p = $hash->{'entities'}->{$w}; next if (!defined($p) || ref($p) ne 'ARRAY'); foreach $v (@{ $p }) { next if (!defined($v) || ref($v) ne 'HASH'); next if (!length($v->{'url'}) || (!length($v->{'expanded_url'}) && !length($v->{'media_url'}))); my $u1 = &descape($v->{'url'}); my $u2 = &descape($v->{'expanded_url'}); my $u3 = &descape($v->{'media_url'}); my $u4 = &descape($v->{'media_url_https'}); $u2 = $u4 || $u3 || $u2; print $stdout "$u1 => $u2\n"; $urlshort = $u4 || $u3 || $u1; $didprint++; } } if ($didprint) { print $stdout &wwrap( "-- %URL% is now $urlshort (/url opens)\n"); } else { print $stdout "-- no entities or URLs found\n"; } return 0; } if (($_ eq '/url' || $_ eq '/open') && length($urlshort)) { $_ = "/url $urlshort"; print $stdout "*** assuming you meant %URL%: $_\n"; # and fall through to ... } if (m#^/(url|open)\s+(http|gopher|https|ftp)://.+# && s#^/(url|open)\s+##) { &openurl($_); return 0; } if (m#^/(url|open) ([dDzZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($2); my $tweet; my $genurl = undef; $urlshort = undef; if ($code =~ /^d/ && length($code) > 2) { $tweet = &get_dm($code); # USO! if (!defined($tweet)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } $genurl = $dmidurl; } else { $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } $genurl = $idurl; } # to be TOS-compliant, we must try entities first to use # t.co wrapped links. this is a tiny version of /entities. unless ($notco) { my $id = $tweet->{'retweeted_status'}->{'id_str'} || $tweet->{'id_str'}; my $hash; # only fetch if we have to. if we already fetched # because we were given a direct id_str instead of a # menu code, then we already have the entities. if ($code !~ /^[0-9]+$/) { $hash = &grabjson("${genurl}?id=${id}", 0, 0, 0, undef, 1); } else { # MAKE MONEY FAST WITH OUR QUICK CACHE PLAN $hash = $tweet; } if (defined($hash) && ref($hash) eq 'HASH') { my $w; my $v; my $didprint = 0; # Twitter puts entities in multiple fields. foreach $w (qw(media urls)) { my $p = $hash->{'entities'}->{$w}; next if (!defined($p) || ref($p) ne 'ARRAY'); foreach $v (@{ $p }) { next if (!defined($v) || ref($v) ne 'HASH'); next if (!length($v->{'url'}) || (!length($v->{'expanded_url'}) && !length($v->{'media_url'}))); my $u1 = &descape($v->{'url'}); &openurl($u1); $didprint++; } } print $stdout "-- sorry, couldn't find any URL.\n" if (!$didprint); return 0; } print $stdout "-- unable to use t.co URLs, using fallback\n"; } # that failed, so fall back on the old method. my $text = &descape($tweet->{'text'}); # findallurls while ($text =~ s#(h?ttp|h?ttps|ftp|gopher)://([a-zA-Z0-9_~/:%\-\+\.\=\&\?\#,]+)##){ # sigh. I HATE YOU TINYARRO.WS #TODO # eventually we will have to put a punycode implementation into openurl # to handle things like Mac OS X's open which don't understand UTF-8 URLs. # when we do, uncomment this again # =~ s#(http|https|ftp|gopher)://([^'\\]+?)('|\\|\s|$)##) { my $url = $1 . "://$2"; $url = "h$url" if ($url =~ /^ttps?:/); $url =~ s/[\.\?]$//; &openurl($url); } print $stdout "-- sorry, couldn't find any URL.\n" if (!defined($urlshort)); return 0; } #TODO if (s/^\/(favourites|favorites|faves|favs|fl)(\s+\+\d+)?\s*//) { my $my_json_ref; my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if (length) { $my_json_ref = &grabjson("${favsurl}?screen_name=$_", 0, 0, $countmaybe, undef, 1); } else { if ($anonymous) { print $stdout "-- sorry, you can't haz favourites if you're anonymous.\n"; } else { print $stdout "-- synchronous /favourites user command\n" if ($verbose); $my_json_ref = &grabjson($favsurl, 0, 0, $countmaybe, undef, 1); } } if (defined($my_json_ref) && ref($my_json_ref) eq 'ARRAY') { if (scalar(@{ $my_json_ref })) { my $w = "-==- favourites " x 10; $w = $EM . substr($w, 0, $wrap || 79) . $OFF; print $stdout "$w\n"; &tdisplay($my_json_ref, "favourites"); print $stdout "$w\n"; } else { print $stdout "-- no favourites found, boring impartiality concluded.\n"; } } &$conclude; return 0; } if ( m#^/(un)?f(rt|retweet|a|av|ave|avorite|avourite)? ([zZ]?[a-zA-Z]?[0-9]+)$#) { my $mode = $1; my $secondmode = $2; my $code = lc($3); $secondmode = ($secondmode eq 'retweet') ? 'rt' : $secondmode; if ($mode eq 'un' && $secondmode eq 'rt') { print $stdout "-- hmm. seems contradictory. no dice.\n"; return 0; } my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } &cordfav($tweet->{'id_str'}, 1, (($mode eq 'un') ? $favdelurl : $favurl), &descape($tweet->{'text'}), (($mode eq 'un') ? 'removed' : 'created')); if ($secondmode eq 'rt') { $_ = "/rt $code"; # and fall through } else { return 0; } } # Retweet API and manual RTs if (s#^/([oe]?)r(etweet|t) ([zZ]?[a-zA-Z]?[0-9]+)\s*##) { my $mode = $1; my $code = lc($3); my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } # use a native retweet unless we can't (or user used /ort /ert) unless ($nonewrts || length || length($mode)) { # we don't always get rs->text, so we simulate it. my $text = &descape($tweet->{'text'}); $text =~ s/^RT \@[^\s]+:\s+// if ($tweet->{'retweeted_status'}->{'id_str'}); print $stdout "-- status retweeted\n" unless(&updatest($text, 1, 0, undef, $tweet->{'retweeted_status'}->{'id_str'} || $tweet->{'id_str'})); return 0; } # we can't or user requested /ert /ort $retweet = "RT @" . &descape($tweet->{'user'}->{'screen_name'}) . ": " . &descape($tweet->{'text'}); if ($mode eq 'e') { &add_history($retweet); print $stdout &wwrap( "-- ok, %RT% and %% are now \"$retweet\"\n"); return 0; } $_ = (length) ? "$retweet $_" : $retweet; print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto TWEETPRINT; # fugly! FUGLY! } if (m#^/(re)?rts?of?me?(\s+\+\d+)?$# && !$nonewrts) { #TODO # when more fields are added, integrate them over the JSON_ref my $mode = $1; my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; my $my_json_ref = &grabjson($rtsofmeurl, 0, 0, $countmaybe); &dt_tdisplay($my_json_ref, "rtsofme"); if ($mode eq 're') { $_ = '/re'; # and fall through ... } else { return 0; } } if (m#^/rts?of\s+([zZ]?[a-zA-Z]?[0-9]+)$# && !$nonewrts) { my $code = lc($1); my $tweet = &get_tweet($code); my $id; if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } $id = $tweet->{'retweeted_status'}->{'id_str'} || $tweet->{'id_str'}; if (!$id) { print $stdout "-- hmmm, that tweet is major bogus.\n"; return 0; } my $url = $rtsbyurl; $url =~ s/%I/$id/; my $users_ref = &grabjson("$url", 0, 0, 100, undef, 1); return if (!defined($users_ref) || ref($users_ref) ne 'ARRAY'); my $k = scalar(@{ $users_ref }); if (!$k) { print $stdout "-- no known retweeters, or they're private.\n"; return 0; } my $j; foreach $j (@{ $users_ref }) { &$userhandle($j->{'user'}); } return 0; } # enable and disable NewRTs from users # we allow this even if newRTs are off from -nonewrts if (s#^/rts(on|off)\s+## && length) { &rtsonoffuser($_, 1, ($1 eq 'on')); return 0; } if (m#^/del(ete)?\s+([zZ]?[a-zA-Z]?[0-9]+)$#) { my $code = lc($2); unless ($code =~ /^d[0-9][0-9]+$/) { # this is a DM. my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } if (lc(&descape($tweet->{'user'}->{'screen_name'})) ne lc($whoami)) { print $stdout "-- not allowed to delete somebody's else's tweets\n"; return 0; } print $stdout &wwrap( "-- verify you want to delete: \"@{[ &descape($tweet->{'text'}) ]}\""); print $stdout "\n"; $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, tweet is NOT deleted.\n"; return 0; } $lastpostid = -1 if ($tweet->{'id_str'} == $lastpostid); &deletest($tweet->{'id_str'}, 1); return 0; } # dxxx falls through to ... } # DM delete version if (m#^/del(ete)? ([dD][a-zA-Z]?[0-9]+)$#) { my $code = lc($2); my $dm = &get_dm($code); if (!defined($dm)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } print $stdout &wwrap( "-- verify you want to delete: " . "(from @{[ &descape($dm->{'sender'}->{'screen_name'}) ]}) ". "\"@{[ &descape($dm->{'text'}) ]}\""); print $stdout "\n"; $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, DM is NOT deleted.\n"; return 0; } &deletedm($dm->{'id_str'}, 1); return 0; } # /deletelast if (m#^/de?l?e?t?e?last$#) { if (!$lastpostid) { print $stdout "-- you haven't posted yet this time!\n"; return 0; } if ($lastpostid == -1) { print $stdout "-- you already deleted it!\n"; return 0; } print $stdout &wwrap( "-- verify you want to delete: \"$lasttwit\""); print $stdout "\n"; $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, tweet is NOT deleted.\n"; return 0; } &deletest($lastpostid, 1); $lastpostid = -1; return 0; } if (s#^/(v)?re(ply)? ([zZ]?[a-zA-Z]?[0-9]+) ## && length) { my $mode = $1; my $code = lc($3); unless ($code =~ /^d[0-9][0-9]+/) { # this is a DM my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } my $target = &descape($tweet->{'user'}->{'screen_name'}); $_ = '@' . $target . " $_"; unless ($mode eq 'v') { $in_reply_to = $tweet->{'id_str'}; $expected_tweet_ref = $tweet; } else { $_ = ".$_"; } $readline_completion{'@'.lc($target)}++ if ($termrl); print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto TWEETPRINT; # fugly! FUGLY! } else { # this is a DM, reconstruct it $_ = "/${mode}re $code $_"; # and fall through to ... } } # DM reply version if (s#^/(dm)?re(ply)? ([dD][a-zA-Z]?[0-9]+) ## && length) { my $code = lc($3); my $dm = &get_dm($code); if (!defined($dm)) { print $stdout "-- no such DM (yet?): $code\n"; return 0; } # in the future, add DM in_reply_to here my $target = &descape($dm->{'sender'}->{'screen_name'}); $readline_completion{'@'.lc($target)}++ if ($termrl); $_ = "/dm $target $_"; print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; # and fall through to /dm } # replyall (based on @FunnelFiasco's extension) if (s#^/(v)?r(eply)?(to)?a(ll)? ([zZ]?[a-zA-Z]?[0-9]+) ## && length) { my $mode = $1; my $code = $5; # common code from /vreply my $tweet = &get_tweet($code); if (!defined($tweet)) { print $stdout "-- no such tweet (yet?): $code\n"; return 0; } my $target = &descape($tweet->{'user'}->{'screen_name'}); my $text = $_; $_ = '@' . $target; unless ($mode eq 'v') { $in_reply_to = $tweet->{'id_str'}; $expected_tweet_ref = $tweet; } else { $_ = ".$_"; } # don't repeat the target or myself; track other mentions my %did_mentions = map { $_ => 1 } (lc($target)); my $reply_tweet = &descape($tweet->{'text'}); while($reply_tweet =~ s/\@(\w+)//) { my $name = $1; my $mame = lc($name); # preserve camel case next if ($mame eq $whoami || $did_mentions{$mame}++); $_ .= " \@$name"; } $_ .= " $text"; # add everyone in did_mentions to readline_completion grep { $readline_completion{'@'.$_}++ } (keys %did_mentions) if ($termrl); # and fall through to post print $stdout &wwrap("(expanded to \"$_\")"); print $stdout "\n"; goto TWEETPRINT; # fugly! FUGLY! } if (m#^/re(plies)?(\s+\+\d+)?$#) { my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if ($anonymous) { print $stdout "-- sorry, how can anyone reply to you if you're anonymous?\n"; } else { # we are intentionally not keeping track of "last_re" # in this version because it is not automatically # updated and may not act as we expect. print $stdout "-- synchronous /replies command\n" if ($verbose); my $my_json_ref = &grabjson($rurl, 0, 0, $countmaybe, undef, 1); &dt_tdisplay($my_json_ref, "replies"); } return 0; } # DMs if ($_ eq '/dm' || $_ eq '/dmrefresh' || $_ eq '/dmr') { &dmthump; return 0; } # /dmsent, /dmagain if (m#^/dm(s|sent|a|again)(\s+\+\d+)?$#) { my $mode = $1; my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; if ($countmaybe > 999) { print $stdout "-- greedy bastard, try +fewer.\n"; return 0; } $countmaybe = sprintf("%03i", $countmaybe); print $stdout "-- background request sent\n" unless ($synch); $mode = ($mode =~ /^s/) ? 's' : 'd'; print C "${mode}mreset${countmaybe}---------\n"; &sync_semaphore; return 0; } if (s#^/dm \@?([^\s]+)\s+## && length) { return &common_split_post($_, undef, $1); } # follow and leave users if (m#^/(follow|leave|unfollow) \@?([^\s/]+)$#) { my $m = $1; my $u = lc($2); &foruuser($u, 1, (($m eq 'follow') ? $followurl : $leaveurl), (($m eq 'follow') ? 'started' : 'stopped')); return 0; } # follow and leave lists. this is, frankly, pointless; it does # nothing other than to mark you. otherwise, /liston and /listoff # actually add lists to your timeline. if (m#^/(l?follow|l?leave|l?unfollow) \@?([^\s/]*)/([^\s/]+)$#) { my $m = $1; my $uname = lc($2); my $lname = lc($3); if (!length($uname) || $uname eq $whoami) { print $stdout &wwrap( "** you can't mark/unmark yourself as a follower of your own lists!\n"); print $stdout &wwrap( "** to add/remove your own lists from your timeline, use /liston /listoff\n"); return 0; } if ($m !~ /^l/) { print $stdout &wwrap( "-- to mark/unmark you as a follower of a list, use /lfollow /lleave\n"); print $stdout &wwrap( "-- to add/remove your own lists from your timeline, use /liston /listoff\n"); return 0; } my $r = &postjson( ($m ne 'lfollow') ? $delfliurl : $crefliurl, "owner_screen_name=$uname&slug=$lname"); if ($r) { my $t = ($m eq 'lfollow') ? "" : "un"; print $stdout &wwrap( "*** ok, you are now ${t}marked as a follower of $uname/${lname}.\n"); my $c = ($t eq 'un') ? "off" : "on"; $t = ($t eq 'un') ? "remove from" : "add to"; print $stdout &wwrap( "--- to also $t your timeline, use /list${c}\n"); } return 0; } # block and unblock users if (m#^/(block|unblock) \@?([^\s/]+)$#) { my $m = $1; my $u = lc($2); if ($m eq 'block') { $answer = lc(&linein( "-- sure you want to block $u? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, $u is NOT blocked.\n"; return 0; } } &boruuser($u, 1, (($m eq 'block') ? $blockurl : $blockdelurl), (($m eq 'block') ? 'started' : 'stopped')); return 0; } # list support # /withlist (/withlis, /with, /wl) if (s#^/(withlist|withlis|withl|with|wl)\s+([^/\s]+)\s+## && ($lname=lc($2)) && s/\s*$// && length) { my $comm = ''; my $args = ''; my $dont_return = 0; if ($anonymous) { print $stdout "-- no list love for anonymous\n"; return 0; } if (/\s+/) { ($comm, $args) = split(/\s+/, $_, 2); } else { $comm = $_; } my $return; # this is a Twitter bug -- it will not give you the # new slug in the returned hash. my $state = "modified list $lname (WAIT! then /lists to see new slug)"; if ($comm eq 'create') { my $desc; ($args, $desc) = split(/\s+/, $args, 2) if ($args =~ /\s+/); if ($args ne 'public' && $args ne 'private') { print $stdout "-- must specify public or private\n"; return 0; } $state = "created new list $lname (mode $args)"; $desc = "description=".&url_oauth_sub($desc)."&" if (length($desc)); $return = &postjson($creliurl, "${desc}mode=$args&name=$lname"); } elsif ($comm eq 'private' || $comm eq 'public') { $return = &postjson($modifyliurl, "mode=$comm&owner_screen_name=${whoami}&slug=${lname}"); } elsif ($comm eq 'desc' || $comm eq 'description') { if (!length($args)) { print $stdout "-- $comm needs an argument\n"; return 0; } $return = &postjson($modifyliurl, "description=".&url_oauth_sub($args). "&owner_screen_name=${whoami}&slug=${lname}"); } elsif ($comm eq 'name') { if (!length($args)) { print $stdout "-- $comm needs an argument\n"; return 0; } $return = &postjson($modifyliurl, "name=".&url_oauth_sub($args). "&owner_screen_name=${whoami}&slug=${lname}"); $state = "RENAMED list $lname (WAIT! then /lists to see new slug)"; } elsif ($comm eq 'add' || $comm eq 'adduser' || ($comm eq 'delete' && length($args))) { my $u = ($comm eq 'delete') ? $deluliurl : $adduliurl; $state = ($comm eq 'delete') ? "user(s) deleted from list $lname" : "user(s) added to list $lname"; if ($args !~ /,/ || $args =~ /\s+/) { 1 while ($args =~ s/\s+/,/); } if ($args =~ /\s*,\s+/ || $args =~ /\s+,\s*/) { 1 while ($args =~ s/\s+//); } if (!length($args)) { print $stdout "-- illegal/missing argument\n"; return 0; } print $stdout "--- warning: user list not checked\n"; $return = &postjson($u, "owner_screen_name=${whoami}". "&screen_name=".&url_oauth_sub($args). "&slug=${lname}"); } elsif ($comm eq 'delete' && !length($args)) { $state = "deleted list $lname"; print $stdout "-- verify you want to delete list $lname\n"; my $answer = lc(&linein( "-- sure you want to delete? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, list is NOT deleted.\n"; return 0; } $return = &postjson($delliurl, "owner_screen_name=${whoami}&slug=${lname}"); if ($return) { # check and see if this is in our autolists. # if it is, delete it there too. my $value = &getvariable('lists'); &setvariable('lists', $value, 1) if ($value=~s#(^|,)${whoami}/${lname}($|,)##); } } elsif ($comm eq 'list') { # synonym for /list $_ = "/list /$lname"; $dont_return = 1; # and fall through } else { print $stdout "*** illegal list operation $comm\n"; } if ($return) { print $stdout "*** ok, $state\n"; } return 0 unless ($dont_return); } # /a to show statuses in a list if (m#^/a(gain)?\s+(\+\d+\s+)?\@?([^\s/]*)/([^\s/]+)#) { my $uname = lc($3); if ($anonymous && !length($uname)) { print $stdout "-- you must specify a username when anonymous.\n"; return 0; } my $lname = lc($4); my $countmaybe = $2; $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $uname ||= $whoami; my $my_json_ref = &grabjson( "${statusliurl}?owner_screen_name=${uname}&slug=${lname}", 0, 0, $countmaybe, undef, 1); &dt_tdisplay($my_json_ref, "again"); return 0; } # /lists command: if @, show their lists. if @?../... show that list. # trivially duplicates /frs and /fos for lists # also handles /listfos and /listfrs if (length($whoami) && (m#^/list?s?$# || m#^/list?f[ro](llower|iend)?s$#)) { $_ .= " $whoami"; } if (m#^/lis(t|ts|t?fos|tfollowers|t?frs|tfriends)?\s+(\+\d+\s+)?(\@?[^\s]+)$#) { my $mode = $1; my $countmaybe = $2; my $uname = lc($3); my $lname = ''; $mode = ($mode =~ /^t?fo/) ? 'fo' : ($mode =~ /^t?fr/) ? 'fr' : ''; $uname =~ s/^\@//; ($uname, $lname) = split(m#/#, $uname, 2) if ($uname =~ m#/#); if ($anonymous && !length($uname) && length($mode)) { print $stdout "-- you must specify a username when anonymous.\n"; return 0; } $uname ||= $whoami; if (length($lname) && length($mode)) { print $stdout "-- specify username only\n"; return 0; } $countmaybe =~ s/[^\d]//g if (length($countmaybe)); $countmaybe += 0; $countmaybe ||= 20; # this is copied from /friends and /followers (q.v.) my $countper = ($countmaybe < 100) ? $countmaybe : 100; my $cursor = -1; # initial value my $nofetch = 0; my $printed = 0; my $json_ref = undef; my @usarray = undef; shift(@usarray); # force underflow my $furl = (length($lname)) ? ($getliurl."?owner_") : ($mode eq '') ? ($getlisurl."?") : ($mode eq 'fo') ? ($getuliurl."?") : ($getufliurl."?"); $furl .= "screen_name=${uname}"; $furl .= "&slug=${lname}" if (length($lname)); LABIO: while($countmaybe--) { if(!scalar(@usarray)) { last LABIO if ($nofetch); $json_ref = &grabjson( "${furl}&count=${countper}&cursor=${cursor}", 0, 0, 0, undef, 1); @usarray = @{ ((length($lname)) ? $json_ref->{'users'} : $json_ref ) }; last LABIO if (!scalar(@usarray)); if (length($lname)) { $cursor = $json_ref->{'next_cursor_str'} || $json_ref->{'next_cursor'} || -1; $nofetch = ($cursor < 1) ? 1 : 0; } else { $nofetch = 1; } } my $list_ref = shift(@usarray); if (length($lname)) { &$userhandle($list_ref); } else { # lists/list returns their lists AND the # ones they subscribe to, different from 1.0. # right now we just deal with that. #next if ($uname ne # $list_ref->{'user'}->{'screen_name'}); # listhandle? my $list_name = "\@$list_ref->{'user'}->{'screen_name'}/@{[ &descape($list_ref->{'slug'}) ]}"; my $list_full_name = (length($list_ref->{'name'})) ? &descape($list_ref->{'name'})."${OFF} ($list_name)" : $list_name; my $list_mode = (lc(&descape($list_ref->{'mode'})) ne 'public') ? " ${EM}(@{[ ucfirst(&descape($list_ref->{'mode'})) ]})${OFF}" : ""; print $streamout <<"EOF"; ${CCprompt}$list_full_name${OFF} (f:$list_ref->{'member_count'}/$list_ref->{'subscriber_count'})$list_mode EOF my $desc = &strim(&descape($list_ref->{'description'})); my $klen = ($wrap || 79) - 9; $klen = 10 if ($klen < 0); $desc = substr($desc, 0, $klen)."..." if (length($desc) > $klen); print $streamout (' "' . $desc . '"' . "\n") if (length($desc)); } $printed++; } if (!$printed) { print $stdout ((length($lname)) ? "-- list $uname/$lname does not follow anyone.\n" : ($mode eq 'fr') ? "-- user $uname doesn't follow any lists.\n" : ($mode eq 'fo') ? "-- user $uname isn't followed by any lists.\n" : "-- no lists found for user $uname.\n"); } return 0; } &sync_n_quit if ($_ eq '/end' || $_ eq '/e'); ##### # # below this point, we are posting # ##### if (m#^/me\s#) { $slash_first = 0; # kludge! } if ($slash_first) { if (!m#^//#) { print $stdout "*** invalid command\n"; print $stdout "*** to pass as a tweet, type /%%\n"; return 0; } s#^/##; # leave the second slash on } TWEETPRINT: # fugly! FUGLY! return &common_split_post($_, $in_reply_to, undef); } # this is the common code used by standard updates and by the /dm command. sub common_split_post { my $k = shift; my $in_reply_to = shift; my $dm_user = shift; my $dm_lead = (length($dm_user)) ? "/dm $dm_user " : ''; my $ol = "$dm_lead$k"; my (@tweetstack) = &csplit($k, ($autosplit eq 'char' || $autosplit eq 'cut') ? 1 : 0); my $m = shift(@tweetstack); if (scalar(@tweetstack)) { $l = "$dm_lead$m"; $history[0] = $l; if (!$autosplit) { print $stdout &wwrap( "*** sorry, too long to send; ". "truncated to \"$l\" (@{[ length($m) ]} chars)\n"); print $stdout "*** use %% for truncated version, or append to %%.\n"; return 0; } print $stdout &wwrap( "*** over $linelength; autosplitting to \"$l\"\n"); } # there was an error; stop autosplit, restore original command if (&updatest($m, 1, $in_reply_to, $dm_user)) { $history[0] = $ol; return 0; } if (scalar(@tweetstack)) { $k = shift(@tweetstack); $l = "$dm_lead$k"; &add_history($l); print $stdout &wwrap("*** next part is ready: \"$l\"\n"); print $stdout "*** (this will also be automatically split)\n" if (length($k) > $linelength); print $stdout "*** to send this next portion, use %%.\n"; } return 1; } # helper functions for the command line processor. sub add_history { my $h = shift; @history = (($h, @history)[0..&min(scalar(@history), $maxhist)]); if ($termrl) { if ($termrl->Features()->{'canSetTopHistory'}) { $termrl->settophistory($h); } else { $termrl->addhistory($h); } } } sub sub_helper { my $r = shift; my $s = shift; my $g = shift; my $x; my $q = 0; my $proband; if ($r eq '%') { $x = -1; } else { $x = $r + 0; } if (!$x || $x < -(scalar(@history))) { print $stdout "*** illegal history index\n"; return (0, $_, undef, undef, undef); } $proband = $history[-($x + 1)]; if ($s eq '--') { $q = 1; } elsif ($s eq '*') { if ($x != -1 || !length($shadow_history)) { print $stdout "*** can only %%* on most recent command\n"; return (0, $_, undef, undef, undef); } # we assume it's at the end; it's only relevant there $proband = substr($shadow_history, length($g)-(2+length($r))); } else { $q = -(0+$s); } if ($q) { my $j; my $c; for($j=0; $j<$q; $j++) { $c++ if ($proband =~ s/\s+[^\s]+$//); } if ($j != $c) { print $stdout "*** illegal word index\n"; return (0, $_, undef, undef, undef); } } return (1, $proband, $r, $s); } # this is used for synchronicity mode to make sure we receive the # GA semaphore from the background before printing another prompt. sub sync_console { &thump; &dmthump unless (!$dmpause); } sub sync_semaphore { if ($synch) { my $k = ''; while(!length($k)) { sysread(W, $k, 1); } # wait for semaphore } } # wrapper function to get a line from the terminal. sub linein { my $prompt = shift; my $return; return 'y' if ($script); $prompt .= " "; if ($termrl) { $dont_use_counter = 1; eval '$termrl->hook_no_counter'; $return = $termrl->readline($prompt); $dont_use_counter = $nocounter; eval '$termrl->hook_no_counter'; } else { print $stdout $prompt; chomp($return = lc(<$stdin>)); } return $return; } #### this is the background part of the process #### MONITOR: %store_hash = (); $is_background = 1; $first_synch = $synchronous_mode = 0; $rin = ''; vec($rin,fileno(STDIN),1) = 1; # paranoia binmode($stdout, ":crlf") if ($termrl); unless ($seven) { binmode(STDIN, ":utf8"); binmode($stdout, ":utf8"); } # allow foreground process to squelch us # we have to cover all the various versions of 30/31 signals on various # systems just in case we are on a system without POSIX.pm. this set should # cover Linux 2.x/3.x, AIX, Mac OS X, *BSD and Solaris. we have to assert # these signals before starting streaming, or we may "kill" ourselves by # accident because it is possible to process a tweet before these are # operational. &sigify(sub { $suspend_output ^= 1 if ($suspend_output != -1); $we_got_signal = 1; }, qw(USR1 PWR XCPU)); &sigify( sub { $suspend_output = -1; $we_got_signal = 1; }, qw(USR2 SYS UNUSED XFSZ)); &sigify("IGNORE", qw(INT)); # don't let slowpost kill us # now we can safely initialize streaming if ($dostream) { @events = (); $lasteventtime = time(); &sigify(sub { print $stdout "-- killing processes $nursepid $bufferpid\n" if ($verbose); kill $SIGHUP, $nursepid if ($nursepid); kill $SIGHUP, $bufferpid if ($bufferpid); kill 9, $curlpid if ($curlpid); sleep 1; # send myself a shutdown kill 9, $nursepid if ($nursepid); kill 9, $bufferpid if ($bufferpid); kill $SIGTERM, $$; }, qw(HUP)); # use SIGHUP etc. from parent process to signal end $bufferpid = &start_streaming; vec($rin, fileno(STBUF), 1) = 1; } else { &sigify("IGNORE", qw(HUP)); # we only respond to SIGKILL/SIGTERM } $interactive = $previous_last_id = $we_got_signal = 0; $suspend_output = -1; $stream_failure = 0; $dm_first_time = ($dmpause) ? 1 : 0; $stuck_stdin = 0; # tell the foreground we are ready kill $SIGUSR2, $parent; # loop until we are killed or told to stop. # we receive instructions on stdin, and send data back on our pipe(). for(;;) { &$heartbeat; &update_effpause; $wrapseq = 0; # remember, we don't know when commands are sent. &refresh($interactive, $previous_last_id) unless (!$effpause && !$interactive); $dont_refresh_first_time = 0; $previous_last_id = $last_id; if ($dmpause && ($effpause || $synch)) { if ($dm_first_time) { &dmrefresh(0); $dmcount = $dmpause; } elsif (!$interactive) { if (!--$dmcount) { &dmrefresh($interactive); # using dm_first_time $dmcount = $dmpause; } } } DONT_REFRESH: # nrvs is tricky with synchronicity if (!$synch || ($synch && $synchronous_mode && !$dm_first_time)) { $k = length($notify_rate) + length($vs) + length($credlog); if ($k) { &send_removereadline if ($termrl); print $stdout $notify_rate; print $stdout $vs; print $stdout $credlog; $wrapseq = 1; } $notify_rate = ""; $vs = ""; $credlog = ""; } print P "0" if ($synchronous_mode && $interactive); &send_repaint if ($termrl); # this core loop is tricky. most signals will not restart the call. # -- respond to alarms if we are ignoring our timeout. # -- do not respond to bogus packets if a signal handler triggered it. # -- clear our flag when we detect a signal handler has been called. # if our master select is interrupted, we must restart with the # appropriate time taken from effpause. however, most implementations # don't report timeleft, so we must. $restarttime = time() + $effpause; RESTART_SELECT: &send_repaint if ($termrl); $interactive = 0; $we_got_signal = 0; # acknowledge all signals if ($effpause == undef) { # -script and anonymous have no effpause. print $stdout "-- select() loops forever\n" if ($verbose); $nfound = select($rout = $rin, undef, undef, undef); } else { $actualtime = $restarttime - time(); print $stdout "-- select pending ($actualtime sec left)\n" if ($superverbose); if ($actualtime <= 0) { $nfound = 0; } else { $nfound = select( $rout = $rin, undef, undef, $actualtime); } } if ($nfound > 0) { my $len; # service the streaming socket first, if we have one. if ($dostream) { if (vec($rout, fileno(STBUF), 1) == 1) { my $json_ref; my $buf = ''; my $rbuf; my $reads = 0; print $stdout "-- data on streaming socket\n" if ($superverbose); # read until we get eight hex digits. this forces the # data stream to synchronize. # first, however, make sure we actually have valid # data, or we sit here and slow down the user. sysread(STBUF, $buf, 1); if (!length($buf)) { # if we get a "ready" but there's actually # no data, that means either 1) a signal # occurred on the buffer, which we need to # ignore, or 2) something killed the # buffer, which is unrecoverable. if we keep # getting repeated ready-no data situations, # it's probably the latter. $stream_failure++; &screech(<<"EOF") if ($stream_failure > 100); *** fatal error *** something killed the streaming buffer process. I can't recover from this. please restart TTYtter. EOF goto DONESTREAM; } $stream_failure = 0; if ($buf !~ /^[0-9a-fA-F]+$/) { print $stdout "-- warning: bogus character(s) ".unpack("H*", $buf)."\n" if ($superverbose); goto DONESTREAM; } while (length($buf) < 8) { # don't read 8 -- read 1. that means we can # skip trailing garbage without a window. sysread(STBUF, $rbuf, 1); $reads++; if ($rbuf =~ /[0-9a-fA-F]/) { $buf .= $rbuf; $reads = 0; } else { print $stdout "-- warning: bogus character(s) ".unpack("H*", $rbuf)."\n" if ($superverbose); $buf = '' if (length($rbuf)); # bogus data } print $stdout "-- master, I am stuck: $reads reads on stream and no valid data\n" if ($reads > 0 && ($reads % 1000) == 0); } print $stdout "-- length packet: $buf\n" if ($superverbose); $len = hex($buf); $buf = ''; while (length($buf) < $len) { sysread(STBUF, $rbuf, ($len-length($buf))); $buf .= $rbuf; } print $stdout "-- streaming data ($len) --\n$buf\n-- streaming data --\n\n" if ($superverbose); $json_ref = &parsejson($buf); push(@events, $json_ref); if (scalar(@events) > $eventbuf || (scalar(@events) && (time()-$lasteventtime) > $effpause)){ sleep 5 while ($suspend_output > 0); &streamevents(@events); &send_repaint if ($termrl); @events = (); $lasteventtime = time(); } } DONESTREAM: print $stdout "-- done with streaming events\n" if ($superverbose); } # then, check if there is data on our control socket. # command packets should always be (initially) 20 characters. # if we come up short, it's either a bug, signal or timeout. if ($we_got_signal) { goto RESTART_SELECT; } goto RESTART_SELECT if(vec($rout, fileno(STDIN), 1) != 1); print $stdout "-- waiting for data ", scalar localtime, "\n" if ($superverbose); if(sysread(STDIN, $rout, 20) != 20) { # if we get repeated "ready" but no data on STDIN, # like the streaming buffer, we probably lost our # IPC and we should die here. if (++$stuck_stdin > 100) { print $stdout "parent is dead; we die too\n"; kill 9,$$; } goto RESTART_SELECT; } $stuck_stdin = 0; # background communications central command code # we received a command from the console, so let's look at it. print $stdout "-- command received ", scalar localtime, " $rout" if ($verbose); if ($rout =~ /^rsga/) { $suspend_output = 0; # reset our status goto RESTART_SELECT; } elsif ($rout =~ /^pipet (..)/) { my $key = &get_tweet($1); my $ms = $key->{'menu_select'} || 'XX'; my $ds = $key->{'created_at'} || 'argh, no created_at'; $ds =~ s/\s/_/g; my $src = $key->{'source'} || 'unknown'; $src =~ s/\|//g; # shouldn't be any anyway. $key = substr(( "$ms ".($key->{'id_str'})." ". ($key->{'in_reply_to_status_id_str'})." ". ($key->{'retweeted_status'}->{'id_str'})." ". ($key->{'user'}->{'geo_enabled'} || "false") . " ". ($key->{'geo'}->{'coordinates'}->[0]). " ". ($key->{'geo'}->{'coordinates'}->[1]). " ". $key->{'place'}->{'id'} . " ". $key->{'place'}->{'country_code'} ." ". $key->{'place'}->{'place_type'} . " ". unpack("${pack_magic}H*", $key->{'place'}->{'full_name'})." ". $key->{'tag'}->{'type'}. " ". # NO SPACES! unpack("${pack_magic}H*", $key->{'tag'}->{'payload'}). " ". ($key->{'retweet_count'} || "0") . " " . $key->{'user'}->{'screen_name'}." $ds $src|". unpack("${pack_magic}H*", $key->{'text'}). $space_pad), 0, 1024); print P $key; goto RESTART_SELECT; } elsif ($rout =~ /^piped (..)/) { my $key = $dm_store_hash{$1}; my $ms = $key->{'menu_select'} || 'XX'; my $ds = $key->{'created_at'} || 'argh, no created_at'; $ds =~ s/\s/_/g; $key = substr(( "$ms ".($key->{'id_str'})." ". $key->{'sender'}->{'screen_name'}." $ds ". unpack("${pack_magic}H*", $key->{'text'}). $space_pad), 0, 1024); print P $key; goto RESTART_SELECT; } elsif ($rout =~ /^ki ([^\s]+) /) { my $key = $1; my $module; sysread(STDIN, $module, 1024); $module =~ s/\s+$//; $module = pack("H*", $module); print $stdout "-- fetch for module $module key $key\n" if ($verbose); print P substr(unpack("${pack_magic}H*", $master_store->{$module}->{$key}).$space_pad, 0, 1024); goto RESTART_SELECT; } elsif ($rout =~ /^kn ([^\s]+) /) { my $key = $1; my $module; sysread(STDIN, $module, 1024); $module =~ s/\s+$//; $module = pack("H*", $module); print $stdout "-- nulled module $module key $key\n" if ($verbose); $master_store->{$module}->{$key} = undef; goto RESTART_SELECT; } elsif ($rout =~ /^ko ([^\s]+) /) { my $key = $1; my $value; my $module; sysread(STDIN, $module, 1024); $module =~ s/\s+$//; $module = pack("H*", $module); sysread(STDIN, $value, 1024); $value =~ s/\s+$//; print $stdout "-- set module $module key $key = $value\n" if ($verbose); $master_store->{$module}->{$key} = pack("H*", $value); goto RESTART_SELECT; } elsif ($rout =~ /^sync/) { print $stdout "-- synced; exiting at ", scalar localtime, "\n" if ($verbose); exit $laststatus; } elsif ($rout =~ /^synm/) { $first_synch = $synchronous_mode = 1; print $stdout "-- background is now synchronous\n" if ($verbose); } elsif ($rout =~ /([\=\?\+])([^ ]+)/) { $comm = $1; $key =$2; if ($comm eq '?') { print P substr("${$key}$space_pad", 0, 1024); } else { sysread(STDIN, $value, 1024); $value =~ s/\s+$//; $interactive = ($comm eq '+') ? 0 : 1; if ($key eq 'tquery') { print $stdout "*** custom query installed\n" if ($interactive || $verbose); print $stdout "$value" if ($verbose); @trackstrings = (); # already URL encoded push(@trackstrings, $value); } else { $$key = $value; print $stdout "*** changed: $key => $$key\n" if ($interactive || $verbose); &generate_ansi if ($key eq 'ansi' || $key =~ /^colour/); $rate_limit_next = 0 if ($key eq 'pause' && $value eq 'auto'); &tracktags_makearray if ($key eq 'track'); &filter_compile if ($key eq 'filter'); ¬ify_compile if ($key eq 'notifies'); &list_compile if ($key eq 'lists'); &filterflags_compile if ($key eq 'filterflags'); $filterrts_sub = &filteruserlist_compile( $filterrts_sub, $value) if ($key eq 'filterrts'); $filterusers_sub = &filteruserlist_compile( $filterusers_sub,$value) if ($key eq 'filterusers'); $filteratonly_sub = &filteruserlist_compile( $filteratonly_sub, $value) if ($key eq 'filteratonly'); &filterats_compile if ($key eq 'filterats'); } } goto RESTART_SELECT; } else { $interactive = 1; ($fetchwanted = 0+$1, $fetch_id = 0, $last_id = 0) if ($rout =~ /^reset(\d+)/); ($dmfetchwanted = 0+$1, $last_dm = 0) if ($rout =~ /^dmreset(\d+)/); if ($rout =~ /^smreset/) { # /dmsent $dmfetchwanted = 0+$1 if ($rout =~ /(\d+)/); &dmrefresh(1, 1); &send_repaint if ($termrl); # we do not want to force a refresh. goto DONT_REFRESH; } if ($rout =~ /^dm/) { &dmrefresh($interactive); &send_repaint if ($termrl); $dmcount = $dmpause; goto DONT_REFRESH; } } } else { if ($we_got_signal || $nfound == -1) { # we need to restart the call. we might be waiting # longer, but this is unavoidable. goto RESTART_SELECT; } print $stdout "-- routine refresh (effpause = $effpause, $dmcount to next dm) ", scalar localtime, "\n" if ($verbose); } } #### internal implementation functions for the twitter API. DON'T ALTER #### # manage automatic rate limiting by checking our max. #TODO # autoslowdown as we run out of requests, then speed up when hour # has passed. sub update_effpause { return ($effpause = undef) if ($script); # for select() if ($pause ne 'auto' && $noratelimit) { $effpause = (0+$pause) || undef; return; } $effpause = (0+$pause) || undef if ($anonymous || (!$pause && $pause ne 'auto')); if (!$rate_limit_next && !$anonymous && ($pause > 0 || $pause eq 'auto')) { # Twitter 1.0 used a simple remaining_hits and # hourly_limit. 1.1 uses multiple rate endpoints. we # are only interested in certain specific ones, though # we currently fetch them all and we might use more later. $rate_limit_next = 5; $rate_limit_ref = &grabjson($rlurl, 0, 0, 0, undef, 1); if (defined $rate_limit_ref && ref($rate_limit_ref) eq 'HASH') { # of mentions_timeline, home_timeline and search/tweets, # choose the MOST restrictive and normalize that. $rate_limit_left = &min( 0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/home_timeline'}->{'remaining'}, &min( 0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/mentions_timeline'}->{'remaining'}, 0+$rate_limit_ref->{'resources'}->{'search'}->{'\\/search\\/tweets'}->{'remaining'})); $rate_limit_rate = &min( 0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/home_timeline'}->{'limit'}, &min( 0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/mentions_timeline'}->{'limit'}, 0+$rate_limit_ref->{'resources'}->{'search'}->{'\\/search\\/tweets'}->{'limit'})); if ($rate_limit_left < 3 && $rate_limit_rate) { $estring = "*** warning: API rate limit imminent"; if ($pause eq 'auto') { $estring .= "; temporarily halting autofetch"; $effpause = 0; } &$exception(5, "$estring\n"); } else { if ($pause eq 'auto') { # the new rate limits do not require us to reduce our fetching for mentions, # direct messages or search, because they pull from different buckets, and # their rate limits are roughly the same. $effpause = 5*$rate_limit_rate; # this will usually be 75s # for lists, however, we have to drain the list bucket faster, so for every # list AFTER THE FIRST ONE we subscribe to, add rate_limit_rate to slow. # for search, it has 180 requests, so we don't care so much. if this # changes later, we will probably need something similar to this for # cases where the search array is > 1. $effpause += ((scalar(@listlist)-1)* $rate_limit_rate) if (scalar(@listlist) > 1); if (!$effpause) { print $stdout "-- rate limit rate failure: using 180 second fallback\n"; $effpause = 180; } # we don't go under sixty. $effpause = 60 if ($effpause < 60); } else { $effpause = 0+$pause; } } print $stdout "-- rate limit check: $rate_limit_left/$rate_limit_rate (rate is $effpause sec)\n" if ($verbose); $adverb = (!$last_rate_limit) ? ' currently' : ($last_rate_limit < $rate_limit_rate) ? ' INCREASED to': ($last_rate_limit > $rate_limit_rate) ? ' REDUCED to': ''; $notify_rate = "-- notification: API rate limit is${adverb} ${rate_limit_rate} req/15min\n" if ($last_rate_limit != $rate_limit_rate); $last_rate_limit = $rate_limit_rate; } else { $rate_limit_next = 0; $effpause = ($pause eq 'auto') ? 180 : 0+$pause; print $stdout "-- failed to fetch rate limit (rate is $effpause sec)\n" if ($verbose); } } else { $rate_limit_next-- unless ($anonymous); } } # streaming API support routines ### INITIALIZE STREAMING ### spin off a nurse process to proxy data from curl, and a buffer process ### to protect the background process from signals curl may generate. sub start_streaming { $bufferpid = 0; unless ($streamtest) { if($bufferpid = open(STBUF, "-|")) { # streaming processes initialized return $bufferpid; } } # now within buffer process # verbosity does not work here, so force both off. $verbose = 0; $superverbose = 0; $0 = "TTYtter (streaming buffer thread)"; $in_buffer = 1; # set up signal handlers $streampid = 0; &sigify(sub { # in an earlier version we wrote a disconnect packet to the # pipe in this handler. THIS IS NOT SAFE on certain OS/Perl # combinations. I moved this down to the HELLOAGAINNURSE loop, # or otherwise you get random seg faults. $i = $streampid; $streampid = 0; waitpid $i, 0 if ($i); }, qw(CHLD PIPE)); &sigify(sub { $i = $streampid; $streampid = 0; # suppress handler above kill ($SIGHUP, $i) if ($i); waitpid $i, 0 if ($i); kill 9, $curlpid if ($curlpid && !$i); kill 9, $$; }, qw(HUP TERM)); &sigify("IGNORE", qw(INT)); $packets_read = 0; # part of exponential backoff $wait_time = 0; # open the nurse process HELLOAGAINNURSE: $w = "{\"packet\" : \"connect\", \"payload\" : {} }"; select(STDOUT); $|++; printf STDOUT ("%08x%s", length($w), $w); close(NURSE); if (!$packets_read) { $wait_time += (($wait_time) ? $wait_time : 1) } else { $wait_time = 0; } $packets_read = 0; $wait_time = ($wait_time > 60) ? 60 : $wait_time; if ($streampid = open(NURSE, "-|")) { # within the buffer process select(NURSE); $|++; select(STDOUT); my $rin = ''; vec($rin,fileno(NURSE),1) = 1; my $datasize = 0; my $buf = ''; my $cuf = ''; my $duf = ''; # read the curlpid from the stream read(NURSE, $curlpax, 8); $curlpid = hex($curlpax); # if we are testing the socket, just emit data. if ($streamtest) { my $c; for(;;) { sysread(NURSE, $c, 1); print STDOUT $c; } } HELLONURSE: while(1) { # restart nurse process if it/curl died goto HELLOAGAINNURSE if(!$streampid); # read a line of text (hopefully numbers) chomp($buf = ); # should be nothing but digits and whitespace. # if anything else, we're getting garbage, and we # should reconnect. if ($buf =~ /[^0-9\r\l\n\s]+/s) { close(NURSE); kill 9, $streampid if ($streampid); # and SIGCHLD will reap kill 9, $curlpid if ($curlpid); goto HELLOAGAINNURSE; } $datasize = 0+$buf; next HELLONURSE if (!$datasize); $datasize--; read(NURSE, $duf, $datasize); # don't send broken entries next HELLONURSE if (length($duf) < $datasize); # yank out all \r\n 1 while $duf =~ s/[\r\n]//g; $duf = "{ \"packet\" : \"data\", \"pid\" : \"$streampid\", \"curlpid\" : \"$curlpid\", \"payload\" : $duf }"; printf STDOUT ("%08x%s", length($duf), $duf); $packets_read++; } } else { # within the nurse process $0 = "TTYtter (waiting $wait_time sec to connect to stream)"; sleep $wait_time; $curlpid = 0; $replarg = ($streamallreplies) ? '&replies=all' : ''; &sigify(sub { kill 9, $curlpid if ($curlpid); waitpid $curlpid, 0 unless (!$curlpid); $curlpid = 0; kill 9, $$; }, qw(CHLD PIPE)); &sigify(sub { kill 9, $curlpid if ($curlpid); }, qw(INT HUP TERM)); # which will cascade into SIGCHLD ($comm, $args, $data) = &$stringify_args($baseagent, [ $streamurl, "delimited=length${replarg}" ], undef, undef, '-s', '-A', "TTYtter_Streaming/$TTYtter_VERSION", '-N', '-H', 'Expect:'); ($curlpid = open(K, "|$comm")) || die("failed curl: $!\n"); printf STDOUT ("%08x", $curlpid); # "DIE QUICKLY" $0 = "TTYtter (streaming socket nurse thread to ${curlpid})"; select(K); $|++; select(STDOUT); $|++; print K "$args\n"; close(K); waitpid $curlpid, 0; $curlpid = 0; kill 9, $$; } } # handle a set of events acquired from the streaming socket. # ordinarily only the background is calling this. sub streamevents { my (@events) = (@_); my $w; my @x; my %k; # need temporary dedupe foreach $w (@events) { my $tmp; # don't send non-data events (yet). next if ($w->{'packet'} ne 'data'); # try to get PID information if available for faster shutdown $nnursepid = 0+($w->{'pid'}); if ($nnursepid != $nursepid) { $nursepid = $nnursepid; print $stdout "-- got new pid of streaming nurse socket process: $nursepid\n" if ($verbose); } $ncurlpid = 0+($w->{'curlpid'}); if ($ncurlpid != $curlpid) { $curlpid = $ncurlpid; print $stdout "-- got new pid of streaming curl process: $ncurlpid\n" if ($verbose); } # we don't use this (yet). next if ($w->{'payload'}->{'friends'}); sleep 5 while ($suspend_output > 0); # dispatch tweets if ($w->{'payload'}->{'text'} && !$notimeline) { # normalize the tweet first. my $payload = &normalizejson($w->{'payload'}); my $sid = $payload->{'id_str'}; $payload->{'tag'}->{'type'} = 'timeline'; $payload->{'tag'}->{'payload'} = 'stream'; # filter replies from streaming socket if the # user requested it. use $tweettype to determine # this so the user can interpose custom logic. if ($nostreamreplies) { my $sn = &descape( $payload->{'user'}->{'screen_name'}); my $text = &descape($payload->{'text'}); next if (&$tweettype($payload, $sn, $text) eq 'reply'); } # finally, filter everything else and dedupe. unless (length($id_cache{$sid}) || $filter_next{$sid} || $k{$sid}) { &tdisplay([ $payload ]); $k{$sid}++; } # roll *_id so that we don't do unnecessary work # testing the API. don't roll fetch_id, search uses # it. don't roll if last_id was zero, because that # means we are streaming *before* the API backfetch. $last_id = $sid unless (!$last_id); } # dispatch DMs elsif (($tmp = $w->{'payload'}->{'direct_message'}) && $dmpause) { &dmrefresh(0, 0, [ $tmp ]); # don't roll last_dm yet. } # must be an event. see if standardevent can make sense of it. elsif (!$notimeline) { $w = $w->{'payload'}; my $sou_sn = &descape($w->{'source'}->{'screen_name'}); if (!length($sou_sn) || !$filterusers_sub || !&$filterusers_sub($sou_sn)) { &send_removereadline if ($termrl); &$eventhandle($w); $wrapseq = 1; &send_repaint if ($termrl); } } } } # REST API support # # thump for timeline # THIS MUST ONLY BE RUN BY THE BACKGROUND. sub refresh { my $interactive = shift; my $relative_last_id = shift; my $k; my $my_json_ref = undef; my $i; my @streams = (); my $dont_roll_back_too_far = 0; # this mixes all the tweet streams (timeline, hashtags, replies # and lists) into a single unified data river. # backload can be zero, but this will still work since &grabjson # sees a count of zero as "default." # first, get my own timeline # note that anonymous has no timeline (but they can sample the # stream) unless ($notimeline || $anonymous) { # in streaming mode, use $last_id # in API mode, use $fetch_id my $base_json_ref = &grabjson($url, ($dostream) ? $last_id : $fetch_id, 0, (($last_id) ? 250 : $fetchwanted || $backload), { "type" => "timeline", "payload" => "api" }, 1); # if I can't get my own timeline, ABORT! highest priority! return if (!defined($base_json_ref) || ref($base_json_ref) ne 'ARRAY'); # we have to filter against the ID cache right now, because # we might not have any other streams! if ($fetch_id && $last_id) { $my_json_ref = []; my $l; my %k; # need temporary dedupe foreach $l (@{ $base_json_ref }) { unless (length($id_cache{$l->{'id_str'}}) || $filter_next{$l->{'id_str'}} || $k{$l->{'id_str'}}) { push(@{ $my_json_ref }, $l); $k{$l->{'id_str'}}++; } } } else { $my_json_ref = $base_json_ref; } } # add stream for replies, if requested if ($mentions) { # same thing my $r = &grabjson($rurl, ($dostream && !$nostreamreplies) ? $last_id : $fetch_id, 0, (($last_id) ? 250 : $fetchwanted || $backload), { "type" => "reply", "payload" => "" }, 1); push(@streams, $r) if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })); } # next handle hashtags and tracktags # failure here does not abort, because search may be down independently # of the main timeline. if (!$notrack && scalar(@trackstrings)) { my $r; my $k; my $l; if (!$last_id) { $l = &min($backload, $searchhits); } else { $l = (($fetchwanted) ? $fetchwanted : &max(100, $searchhits)); } # temporarily squelch server complaints (see below) $muffle_server_messages = 1 unless ($verbose); foreach $k (@trackstrings) { # use fetch_id here in both modes. $r = &grabjson("$queryurl?${k}&result_type=recent", $fetch_id, 0, $l, { "type" => "search", "payload" => $k }, 1); # depending on the state of the search API, we might be using # a bogus search ID that is too far back. so if this fails, # try again with last_id, but not if we're streaming (it # will always fetch zero). if (!defined($r) || ref($r) ne 'ARRAY' || !$dostream) { print $stdout "-- search retry $k attempted with last_id\n" if ($verbose); $r = &grabjson("$queryurl?${k}&result_type=recent", $last_id, 0, $l, { "type" => "search", "payload" => $k }, 1); $dont_roll_back_too_far = 1; } # or maybe not even then? if (!defined($r) || ref($r) ne 'ARRAY') { print $stdout "-- search retry $k attempted with zero!\n" if ($verbose); $r = &grabjson("$queryurl?${k}&result_type=recent", 0, 0, $l, { "type" => "search", "payload" => $k }, 1); $dont_roll_back_too_far = 1; } push(@streams, $r) if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })); } $muffle_server_messages = 0; } # add stream for lists we have on with /set lists, and tag it with # the list. if (scalar(@listlist)) { foreach $k (@listlist) { # always use fetch_id my $r = &grabjson( "${statusliurl}?owner_screen_name=".$k->[0].'&slug='.$k->[1], $fetch_id, 0, (($last_id) ? 250 : $fetchwanted), { "type" => "list", "payload" => ($k->[0] ne $whoami) ? "$k->[0]/$k->[1]" : "$k->[1]" }, 1); push(@streams, $r) if (defined($r) && ref($r) eq 'ARRAY' && scalar(@{ $r })); } } $fetchwanted = 0; # done with that. # now, streamix all the streams into my_json_ref, discarding duplicates # a simple hash lookup is no good; it has to be iterative. because of # that, we might as well just splice it in here and save a sort later. # the streammix logic is unnecessarily complex, probably. # remember, the most recent tweets are FIRST. if (scalar(@streams)) { my $j; my $k; my $l = scalar(@{ $my_json_ref }); my $m; my $n; foreach $n (@streams) { SMIX0: foreach $j (@{ $n }) { my $id = $j->{'id_str'}; # for ease of use # possible to happen if search tryhard is on next SMIX0 if ($id < $fetch_id); # filter this lot against the id cache # and any tweets we just filtered. next SMIX0 if (length($id_cache{$id}) && $fetch_id); next SMIX0 if ($filter_next{$id} && $fetch_id); if (!$l) { # degenerate case push (@{ $my_json_ref }, $j); $l++; next SMIX0; } # find the same ID, or one just before, # and splice in $m = -1; SMIX1: for($i=0; $i<$l; $i++) { next SMIX0 # it's a duplicate if($my_json_ref->[$i]->{'id_str'} == $id); if($my_json_ref->[$i]->{'id_str'} < $id) { $m = $i; last SMIX1; # got it } } if ($m == -1) { # didn't find push (@{ $my_json_ref }, $j); } elsif ($m == 0) { # degenerate case unshift (@{ $my_json_ref }, $j); } else { # did find, so splice splice(@{ $my_json_ref }, $m, 0, $j); } $l++; } } } %filter_next = (); # fetch_id gyration. initially start with last_id, then roll. we # want to keep a window, though, so we try to pick a sensible value # that doesn't fetch too much but includes some overlap. we can't # do computations on the ID itself, because it's "opaque." $fetch_id = 0 if ($last_id == 0); &send_removereadline if ($termrl); if ($dont_refresh_first_time) { $last_id = &max($my_json_ref->[0]->{'id_str'}, $last_id); } else { ($last_id, $crap) = &tdisplay($my_json_ref, undef, $relative_last_id); } my $new_fi = (scalar(@{ $my_json_ref })) ? $my_json_ref->[(scalar(@{ $my_json_ref })-1)]->{'id_str'} : ''; # try to widen the window to a "reasonable amount" $fetch_id = ($fetch_id == 0) ? $last_id : (length($new_fi) && $new_fi ne $last_id && $new_fi > $fetch_id) ? $new_fi : ($relative_last_id > 0 && $relative_last_id ne $last_id && $relative_last_id > $fetch_id) ? $relative_last_id : $fetch_id; print $stdout "-- last_id $last_id, fetch_id $fetch_id, rollback $relative_last_id\n". "-- (@{[ scalar(keys %id_cache) ]} cached)\n" if ($verbose); &send_removereadline if ($termrl); &$conclude; $wrapseq = 1; &send_repaint if ($termrl); } # convenience function for filters (see below) sub killtw { my $j = shift; $filtered++; $filter_next{$j->{'id_str'}}++ if ($is_background); } # handle (i.e., display) an array of tweets in standard format sub tdisplay { # used by both synchronous /again and asynchronous refreshes my $my_json_ref = shift; my $class = shift; my $relative_last_id = shift; my $mini_id = shift; my $printed = 0; my $disp_max = &min($print_max, scalar(@{ $my_json_ref })); my $save_counter = -1; my $i; my $j; if ($disp_max) { # null list may be valid if we get code 304 unless ($is_background) { # reset store hash each console if ($mini_id) { #TODO # generalize this at some point instead of hardcoded menu codes # maybe an ma0-mz9? $save_counter = $tweet_counter; $tweet_counter = $mini_split; for(0..9) { undef $store_hash{"zz$_"}; } }# else { # $tweet_counter = $back_split; # %store_hash = (); #} } for($i = $disp_max; $i > 0; $i--) { my $g = ($i-1); $j = $my_json_ref->[$g]; my $id = $j->{'id_str'}; my $sn = $j->{'user'}->{'screen_name'}; next if (!length($sn)); $sn = lc(&descape($sn)); # # implement filter stages: # do so in such a way that we can toss tweets out # quickly, because multiple layers eat CPU! # # zeroth: if this is us, do not filter. if (($anonymous || $sn ne $whoami) && !($nofilter)) { # first, filterusers. this is very fast. # do for the tweet (&killtw($j), next) if ($filterusers_sub && &$filterusers_sub($sn)); # and if the tweet has a retweeted status, do for # that. (&killtw($j), next) if ($j->{'retweeted_status'} && $filterusers_sub && &$filterusers_sub(lc(&descape($j-> {'retweeted_status'}-> {'user'}->{'screen_name'})))); # second, filterrts. this is almost as fast. (&killtw($j), next) if ($filterrts_sub && length($j->{'retweeted_status'}->{'id_str'})&& &$filterrts_sub($sn)); # third, filteratonly. this has a fast case and a # slow case. my $tex = &descape($j->{'text'}); (&killtw($j), next) if ($filteratonly_sub && &$filteratonly_sub($sn) && # fast test $tex !~ /\@$whoami\b/i); # slow test # fourth, filterats. this is somewhat expensive. (&killtw($j), next) if ($filterats_c && &$filterats_c($tex)); # finally, classic -filter. this is the most expensive. (&killtw($j), next) if ($filter_c && &$filter_c($tex)); } # damn it, user may actually want this tweet. # assign menu codes and place into caches $key = (($is_background) ? '' : 'z' ). substr($alphabet, $tweet_counter/10, 1) . $tweet_counter % 10; $tweet_counter = ($tweet_counter == 259) ? $mini_split : ($tweet_counter == ($mini_split - 1)) ? 0 : ($tweet_counter+1); $j->{'menu_select'} = $key; $key = lc($key); # recover ID cache memory: find the old ID with this # menu code and remove it, then add the new one # except if this is the foreground. we don't use this # in the foreground. if ($is_background) { delete $id_cache{$store_hash{$key}->{'id_str'}}; $id_cache{$id} = $key; } # finally store in menu code cache $store_hash{$key} = $j; sleep 5 while ($suspend_output > 0); &send_removereadline if ($termrl); $wrapseq++; $printed += scalar(&$handle($j, ($class || (($id <= $relative_last_id) ? 'again' : undef)))); } } $tweet_counter = $save_counter if ($save_counter > -1); sleep 5 while ($suspend_output > 0); &$exception(6,"*** warning: more tweets than menu codes; truncated\n") if (scalar(@{ $my_json_ref }) > $print_max); if (($interactive || $verbose) && !$printed) { &send_removereadline if ($termrl); print $stdout "-- sorry, nothing to display.\n"; $wrapseq = 1; } return (&max($my_json_ref->[0]->{'id_str'}, $last_id), $j); } sub dt_tdisplay { my $my_json_ref = shift; my $class = shift; if (defined($my_json_ref) && ref($my_json_ref) eq 'ARRAY' && scalar(@{ $my_json_ref })) { my ($crap, $art) = &tdisplay($my_json_ref, $class); unless ($timestamp) { my ($time, $ts1) = &$wraptime( $my_json_ref->[(&min($print_max,scalar(@{ $my_json_ref }))-1)]->{'created_at'}); my ($time, $ts2) = &$wraptime($art->{'created_at'}); print $stdout &wwrap( "-- update covers $ts1 thru $ts2\n"); } &$conclude; } } # thump for DMs sub dmrefresh { my $interactive = shift; my $sent_dm = shift; # for streaming API to inject DMs it receives my $my_json_ref = shift; if ($anonymous) { print $stdout "-- sorry, you can't read DMs if you're anonymous.\n" if ($interactive); return; } # no point in doing this if we can't even get to our own timeline # (unless user specifically requested it, or our timeline is off) return if (!$interactive && !$last_id && !$notimeline); # NOT last_dm $my_json_ref = &grabjson((($sent_dm) ? $dmsenturl : $dmurl), (($sent_dm) ? 0 : $last_dm), 0, $dmfetchwanted, undef, 1) if (!defined($my_json_ref) || ref($my_json_ref) ne 'ARRAY'); return if (!defined($my_json_ref) || ref($my_json_ref) ne 'ARRAY'); my $orig_last_dm = $last_dm; $last_dm = 0 if ($sent_dm); $dmfetchwanted = 0; my $printed = 0; my $max = 0; my $disp_max = &min($print_max, scalar(@{ $my_json_ref })); my $i; my $g; my $key; if ($disp_max) { # an empty list can be valid if ($dm_first_time) { sleep 5 while ($suspend_output > 0); &send_removereadline if ($termrl); print $stdout "-- checking for most recent direct messages:\n"; $disp_max = 2; $interactive = 1; } for($i = $disp_max; $i > 0; $i--) { $g = ($i-1); my $j = $my_json_ref->[$g]; next if (!$sent_dm && $j->{'id_str'} <= $last_dm); next if (!length($j->{'sender'}->{'screen_name'}) || !length($j->{'recipient'}->{'screen_name'})); $key = substr($alphabet, $dm_counter/10, 1) . $dm_counter % 10; $dm_counter = ($dm_counter == 259) ? 0 : ($dm_counter+1); $j->{'menu_select'} = $key; $dm_store_hash{lc($key)} = $j; sleep 5 while ($suspend_output > 0); &send_removereadline if ($termrl); $wrapseq++; $printed += scalar(&$dmhandle($j)); } $max = $my_json_ref->[0]->{'id_str'}; } sleep 5 while ($suspend_output > 0); if (($interactive || $verbose) && !$printed && !$dm_first_time) { &send_removereadline if ($termrl); print $stdout (($sent_dm) ? "-- you haven't sent anything yet.\n" : "-- sorry, no new direct messages.\n"); $wrapseq = 1; } $last_dm = ($sent_dm) ? $orig_last_dm : &max($last_dm, $max); $dm_first_time = 0 if ($last_dm || !scalar(@{ $my_json_ref })); print $stdout "-- dm bookmark is $last_dm.\n" if ($verbose); &$dmconclude; &send_repaint if ($termrl); } # post an update # this is a general API function that handles status updates and sending DMs. sub updatest { my $string = shift; my $interactive = shift; my $in_reply_to = shift; my $user_name_dm = shift; my $rt_id = shift; # even if this is set, string should also be set. my $urle = ''; my $i; my $subpid; my $istring; my $verb = (length($user_name_dm)) ? "DM $user_name_dm" : ($rt_id) ? 'RE-tweet' : 'tweet'; if ($anonymous) { print $stdout "-- sorry, you can't $verb if you're anonymous.\n" if ($interactive); return 99; } # "the pastebrake" if (!$slowpost && !$verify && !$script) { if ((time() - $postbreak_time) < 5) { $postbreak_count++; if ($postbreak_count == 3) { print $stdout "-- you're posting pretty fast. did you mean to do that?\n". "-- waiting three seconds before taking the next set of tweets\n". "-- hit CTRL-C NOW! to kill TTYtter if you accidentally pasted in this window\n"; sleep 3; $postbreak_count = 0; } } else { $postbreak_count = 0; } $postbreak_time = time(); } my $payload = (length($user_name_dm)) ? 'text' : 'status'; $string = &$prepost($string) unless ($user_name_dm || $rt_id); # YES, you *can* verify and slowpost. I thought about this and I # think I want to allow it. if ($verify && !$status) { my $answer; print $stdout &wwrap("-- verify you want to $verb: \"$string\"\n"); $answer = lc(&linein( "-- send to server? (only y or Y is affirmative):")); if ($answer ne 'y') { print $stdout "-- ok, NOT sent to server.\n"; return 97; } } unless ($rt_id) { $urle = ''; foreach $i (unpack("${pack_magic}C*", $string)) { my $k = chr($i); if ($k =~ /[-._~a-zA-Z0-9]/) { $urle .= $k; } else { $k = sprintf("%02X", $i); $urle .= "%$k"; } } } $user_name_dm = (length($user_name_dm)) ? "&user=$user_name_dm" : ''; my $i = ''; $i .= "source=TTYtter&" if ($authtype eq 'basic'); $i .= "in_reply_to_status_id=${in_reply_to}&" if ($in_reply_to > 0); if (!$rt_id && defined $lat && defined $long && $location) { print $stdout "-- using lat/long: ($lat, $long)\n"; $i .= "lat=${lat}&long=${long}&"; } elsif ((defined $lat || defined $long) && $location && !$rt_id) { print $stdout "-- warning: incomplete location ($lat, $long) ignored\n"; } $i .= "${payload}=${urle}${user_name_dm}" unless ($rt_id); $i .= "id=$rt_id" if ($rt_id); $slowpost += 0; if ($slowpost && !$script && !$status && !$silent) { if($pid = open(SLOWPOST, '-|')) { # pause background so that it doesn't kill itself # when this signal occurs. kill $SIGUSR1, $child; print $stdout &wwrap( "-- waiting $slowpost seconds to $verb, ^C cancels: \"$string\"\n"); close(SLOWPOST); # this should wait for us if ($? > 256) { print $stdout "\n-- not sent, cancelled by user\n"; return 97; } print $stdout "-- sending to server\n"; kill $SIGUSR2, $child; &send_removereadline if ($termrl && $dostream); } else { $in_backticks = 1; # defeat END sub &sigify(sub { exit 254; }, qw(BREAK INT TERM PIPE)); sleep $slowpost; exit 0; } } my $return = &backticks($baseagent, '/dev/null', undef, (length($user_name_dm)) ? $dmupdate : ($rt_id) ? "$rturl/${rt_id}.json" : $update, $i, 0, @wend); print $stdout "-- return --\n$return\n-- return --\n" if ($superverbose); if ($? > 0) { $x = $? >> 8; print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: connect timeout or no confirmation received ($x) *** to attempt a resend, type %%${OFF} EOF return $?; } my $ec; if ($ec = &is_json_error($return)) { print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: server error message received *** "$ec"${OFF} EOF return 98; } if ($ec = &is_fail_whale($return) || $return =~ /^\[?\]?/i || $return =~ /^<\??xml\s+/) { print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: Twitter Fail Whale${OFF} EOF return 98; } $lastpostid = &parsejson($return)->{'id_str'}; unless ($user_name_dm || $rt_id) { $lasttwit = $string; &$postpost($string); } return 0; } # this dispatch routine replaces the common logic of deletest, deletedm, # follow, leave and the favourites system. # this is a modified, abridged version of &updatest. sub central_cd_dispatch { my ($payload, $interactive, $update) = (@_); my $return = &backticks($baseagent, '/dev/null', undef, $update, $payload, 0, @wend); print $stdout "-- return --\n$return\n-- return --\n" if ($superverbose); if ($? > 0) { $x = $? >> 8; print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: connect timeout or no confirmation received ($x) *** to attempt again, type %%${OFF} EOF return ($?, ''); } my $ec; if ($ec = &is_json_error($return)) { print $stdout <<"EOF" if ($interactive); ${MAGENTA}*** warning: server error message received *** "$ec"${OFF} EOF return (98, $return); } return (0, $return); } # the following functions may be user-exposed in a future version of # TTYtter, but are officially still "private interfaces." # delete a status sub deletest { my $id = shift; my $interactive = shift; my $url = $delurl; $url =~ s/%I/$id/; my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $url); print $stdout "-- tweet id #${id} has been removed\n" if ($interactive && !$en); print $stdout "*** (was the tweet already deleted?)\n" if ($interactive && $en); return 0; } # delete a DM sub deletedm { my $id = shift; my $interactive = shift; my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $dmdelurl); print $stdout "-- DM id #${id} has been removed\n" if ($interactive && !$en); print $stdout "*** (was the DM already deleted?)\n" if ($interactive && $en); return 0; } # create or destroy a favourite sub cordfav { my $id = shift; my $interactive = shift; my $basefav = shift; my $text = shift; my $verb = shift; my ($en, $em) = ¢ral_cd_dispatch("id=$id", $interactive, $basefav); print $stdout "-- favourite $verb for tweet id #${id}: \"$text\"\n" if ($interactive && !$en); print $stdout "*** (was the favourite already ${verb}?)\n" if ($interactive && $en); return 0; } # follow or unfollow a user sub foruuser { my $uname = shift; my $interactive = shift; my $basef = shift; my $verb = shift; my ($en, $em) = ¢ral_cd_dispatch("screen_name=$uname", $interactive, $basef); print $stdout "-- ok, you have $verb following user $uname.\n" if ($interactive && !$en); return 0; } # block or unblock a user sub boruuser { my $uname = shift; my $interactive = shift; my $basef = shift; my $verb = shift; my ($en, $em) = ¢ral_cd_dispatch("screen_name=$uname", $interactive, $basef); print $stdout "-- ok, you have $verb blocking user $uname.\n" if ($interactive && !$en); return 0; } # enable or disable retweets for a user sub rtsonoffuser { my $uname = shift; my $interactive = shift; my $selection = shift; my $verb = ($selection) ? 'enabled' : 'disabled'; my $tval = ($selection) ? 'true' : 'false'; my ($en, $em) = ¢ral_cd_dispatch( "retweets=${tval}&screen_name=${uname}", $interactive, $frupdurl); print $stdout "-- ok, you have ${verb} retweets for user $uname.\n" if ($interactive && !$en); return 0; } #### TTYtter internal API utility functions #### # ... which your API *can* call # gets and returns the contents of a URL (optionally pass a POST body) sub graburl { my $resource = shift; my $data = shift; return &backticks($baseagent, '/dev/null', undef, $resource, $data, 1, @wind); } # format a tweet based on user options sub standardtweet { my $ref = shift; my $nocolour = shift; my $sn = &descape($ref->{'user'}->{'screen_name'}); my $tweet = &descape($ref->{'text'}); my $colour; my $g; my $h; # wordwrap really ruins our day here, thanks a lot, @augmentedfourth # have to insinuate the ansi sequences after the string is wordwrapped $g = $colour = ${'CC' . scalar(&$tweettype($ref, $sn, $tweet)) } unless ($nocolour); $colour = $OFF . $colour unless ($nocolour); # prepend screen name "badges" $sn = "\@$sn" if ($ref->{'in_reply_to_status_id_str'} > 0); $sn = "+$sn" if ($ref->{'user'}->{'geo_enabled'} eq 'true' && (($ref->{'geo'}->{'coordinates'}->[0] ne 'undef' && length($ref->{'geo'}->{'coordinates'}->[0]) && $ref->{'geo'}->{'coordinates'}->[1] ne 'undef' && length($ref->{'geo'}->{'coordinates'}->[0])) || length($ref->{'place'}->{'id'}))); $sn = "%$sn" if (length($ref->{'retweeted_status'}->{'id_str'})); $sn = "*$sn" if ($ref->{'source'} =~ /TTYtter/ && $ttytteristas); # prepend list information, if this tweet originated from a list $sn = "($ref->{'tag'}->{'payload'})$sn" if (length($ref->{'tag'}->{'payload'}) && $ref->{'tag'}->{'type'} eq 'list'); $tweet = "<$sn> $tweet"; # twitter doesn't always do this right. $h = $ref->{'retweet_count'}; $h += 0; #$h = "${h}+" if ($h >= 100); # twitter doesn't always handle single retweets right. good f'n grief. $tweet = "(x${h}) $tweet" if ($h > 1 && !$nonewrts); # br3nda's modified timestamp patch if ($timestamp) { my ($time, $ts) = &$wraptime($ref->{'created_at'}); $tweet = "[$ts] $tweet"; } # pull it all together $tweet = &wwrap($tweet, ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0) if ($wrap); # remember to account for prompt length on #1 $tweet =~ s/^([^<]*)<([^>]+)>/${g}\1<${EM}\2${colour}>/ unless ($nocolour); $tweet =~ s/\n*$//; $tweet .= ($nocolour) ? "\n" : "$OFF\n"; # highlight anything that we have in track if(scalar(@tracktags)) { # I'm paranoid foreach $h (@tracktags) { $h =~ s/^"//; $h =~ s/"$//; # just in case $tweet =~ s/(^|[^a-zA-Z0-9])($h)([^a-zA-Z0-9]|$)/\1${EM}\2${colour}\3/ig unless ($nocolour); } } # smb's underline/bold patch goes on last (modified for lists) unless ($nocolour) { # only do this after the < > portion. my $k = index($tweet, ">"); my $botsub = substr($tweet, $k); my $topsub = substr($tweet, 0, $k); $botsub =~ s/(^|[^a-zA-Z0-9_])\@([a-zA-Z0-9_\/]+)/\1\@${UNDER}\2${colour}/g; $tweet = $topsub . $botsub; } return $tweet; } # format a DM based on standard user options sub standarddm { my $ref = shift; my $nocolour = shift; my ($time, $ts) = &$wraptime($ref->{'created_at'}); my $text = &descape($ref->{'text'}); my $sns = &descape($ref->{'sender'}->{'screen_name'}); if ($sns eq $whoami) { $sns = "->" . &descape($ref->{'recipient'}->{'screen_name'}); } my $g = &wwrap("[DM d$ref->{'menu_select'}]". "[$sns/$ts] $text", ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0); $g =~ s/^\[DM ([^\/]+)\//${CCdm}[DM ${EM}\1${OFF}${CCdm}\// unless ($nocolour); $g =~ s/\n*$//; $g .= ($nocolour) ? "\n" : "$OFF\n"; $g =~ s/(^|[^a-zA-Z0-9_])\@(\w+)/\1\@${UNDER}\2${OFF}${CCdm}/g unless ($nocolour); return $g; } # format an event record based on standard user options (mostly for # streaming API, perhaps REST API one day) sub standardevent { my $ref = shift; my $nocolour = shift; my $g = '>>> '; my $verb = &descape($ref->{'event'}); # https://dev.twitter.com/docs/streaming-apis/messages if (length($verb)) { # see below for server-level events my $tar_sn = '@'.&descape($ref->{'target'}->{'screen_name'}); my $sou_sn = '@'.&descape($ref->{'source'}->{'screen_name'}); my $tar_list_name = ''; my $tar_list_desc = ''; # For all verbs starting with "list", get name and desc if ($verb =~ m/^list/ ) { $tar_list_name = &descape($ref->{'target_object'}->{'full_name'}); $tar_list_desc = &descape($ref->{'target_object'}->{'description'}); } if ($verb eq 'favorite' || $verb eq 'unfavorite') { my $rto = &destroy_all_tco($ref->{'target_object'}); my $txt = &descape($rto->{'text'}); $g .= "$sou_sn just ${verb}d ${tar_sn}'s tweet: \"$txt\""; } elsif ($verb eq 'follow') { $g .= "$sou_sn is now following $tar_sn"; } elsif ($verb eq 'user_update') { $g .= "$sou_sn updated their profile (/whois $sou_sn to see)"; } elsif ($verb eq 'list_member_added') { $g .= "$sou_sn added $tar_sn to the list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'list_member_removed') { $g .= "$sou_sn removed $tar_sn from the list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'list_user_subscribed') { $g .= "$sou_sn is now following the list \"$tar_list_desc\" ($tar_list_name) from $tar_sn"; } elsif ($verb eq 'list_user_unsubscribed') { $g .= "$sou_sn is no longer following the list \"$tar_list_desc\" ($tar_list_name) from $tar_sn"; } elsif ($verb eq 'list_created') { $g .= "$sou_sn created the new list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'list_destroyed') { $g .= "$sou_sn destroyed the list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'list_updated') { $g .= "$sou_sn updated the list \"$tar_list_desc\" ($tar_list_name)"; } elsif ($verb eq 'block' || $verb eq 'unblock') { $g .= "$sou_sn ${verb}ed $tar_sn ($tar_sn is not ". "notified)"; } elsif ($verb eq 'access_revoked') { $g .= "$sou_sn revoked oAuth access to $tar_sn"; } elsif ($verb eq 'access_unrevoked') { $g .= "$sou_sn restored oAuth access to $tar_sn"; } else { # try to handle new types of events we don't # recognize yet. $verb .= ($verb =~ /e$/) ? 'd' : 'ed'; $g .= "$sou_sn $verb $tar_sn (basic)"; } # server events ("public stream messages") are handled differently. # we support almost all except for the ones that are irrelevant to # this medium. } elsif ($ref->{'delete'}) { # this is the best we can do -- it's already on the screen! # we don't want to make it easy which tweet it is, since that # would be embarrassing, so just say a delete occurred. $g .= "tweet ID# ".$ref->{'delete'}->{'status'}->{'id_str'}. " deleted by server"; } elsif ($ref->{'status_withheld'}) { # Twitter doesn't document id_str as available here. check. if (!length($ref->{'status_withheld'}->{'id_str'})) { # do nothing right now } else { $g .= "tweet ID# ".$ref->{'status_withheld'}->{'id_str'}. " censored by server in your country"; } } elsif ($ref->{'user_withheld'}) { $g .= "user ID# ".$ref->{'user_withheld'}->{'user_id'}. " censored by server in your country"; } elsif ($ref->{'disconnect'}) { $g .= "DISCONNECTED BY SERVER (".$ref->{'disconnect'}->{'code'}. "); will retry: ".$ref->{'disconnect'}->{'reason'}; } else { # we have no idea what this is. just BS our way out. $g .= "unknown server event received (non-fatal)"; } if ($timestamp) { my ($time, $ts) = &$wraptime($ref->{'created_at'}); $g = "[$ts] $g"; } $g = &wwrap("$g\n", ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0); # highlight screen names $g =~ s/(^|[^a-zA-Z0-9_])\@([a-zA-Z0-9_\-\/]+)/\1\@${UNDER}\2${OFF}/g unless ($nocolour); return $g; } # for future expansion: this is the declared API callable method # for executing a command as if the console had typed it. sub ucommand { die("** can't call &ucommand during multi-module loading.\n") if ($multi_module_mode == -1); &prinput(@_); } # your application can also call &grabjson to get a hashref # corresponding to parsed JSON from an arbitrary resource. # see that function later on. #### DEFAULT TTYtter INTERNAL API METHODS #### # don't change these here. instead, use -exts=yourlibrary.pl and set there. # note that these are all anonymous subroutine references. # anything you don't define is overwritten by the defaults. # it's better'n'superclasses. # NOTE: defaultaddaction, defaultmain and defaultprompt # are all defined in the "console" section above for # clarity. # this first set are the multi-module aware ones. # the standard iterator for multi-module methods sub multi_module_dispatch { my $default = shift; my $dispatch_chain = shift; my $rv_handler = shift; my @args = @_; local $dispatch_ref; # on purpose; get_key/set_key may need it # $*_call_default is a global $did_call_default = 0; $this_call_default = 0; $multi_module_context = 0; if ($rv_handler == 0) { $rv_handler = sub { return 0; }; } # fall through to default if no dispatch chain if (!scalar(@{ $dispatch_chain })) { return &$default(@args); } foreach $dispatch_ref (@{ $dispatch_chain }) { # each reference has the code, and the file that specified it. # set up a multi-module context and run that function. if the # default ever gets called, we log it to tell the multi-module # handler to call the default at the end. my $rv; my $irv; my $caller = (caller(1))[3]; $caller =~ s/^main::multi//; $multi_module_context = 1; # defaults then know to defer $this_call_default = 0; $store = $master_store->{ $dispatch_ref->[0] }; print "-- calling \$$caller in $dispatch_ref->[0]\n" if ($verbose); my $code_ref = $dispatch_ref->[1]; $rv = &$rv_handler(@irv = &$code_ref(@args)); $multi_module_context = 0; if ($rv & 4) { # rv_handler indicating to call default and halt # if it was called. return &$default(@args) if ($did_call_default); } if ($rv & 2) { # rv_handler indicating to make new @args from @irv @args = @irv; } if ($rv & 1) { # rv_handler indicating to halt early. do so. return (wantarray) ? @irv : $irv[0]; } } $multi_module_context = 0; return &$default(@args) if ($did_call_default); return (wantarray) ? @irv : $irv[0]; } # these are the stubs that call the dispatcher. sub multiaddaction { &multi_module_dispatch(\&defaultaddaction, \@m_addaction, sub{ # return immediately on the first extension to accept return (shift>0); }, @_); } sub multiconclude { &multi_module_dispatch(\&defaultconclude, \@m_conclude, 0, @_); } sub multidmconclude { &multi_module_dispatch(\&defaultdmconclude, \@m_dmconclude, 0, @_); } sub multidmhandle { &multi_module_dispatch(\&defaultdmhandle, \@m_dmhandle, sub { my $rv = shift; # skip default calls. return 0 if ($this_call_default); # if not a default call, and the DM was refused for # processing by this extension, then the DM is now # suppressed. do not call any other extensions after this. # even if it ends in suppression, we still call the default # if it was ever called before. return 5 if ($rv == 0); # if accepted in any manner, keep calling. return 0; }, @_); } sub multieventhandle { &multi_module_dispatch(\&defaulteventhandle, \@m_eventhandle, sub { my $rv = shift; # skip default calls. return 0 if ($this_call_default); # if not a default call, and the event was refused for # processing by this extension, then the event is now # suppressed. do not call any other extensions after this. # even if it ends in suppression, we still call the default # if it was ever called before. return 5 if ($rv == 0); # if accepted in any manner, keep calling. return 0; }, @_); } sub multiexception { # this is a secret option for people who want to suppress errors. if ($exception_is_maskable) { &multi_module_dispatch(\&defaultexception, \@m_exception, sub { my $rv = shift; # same logic as handle/dmhandle, except return -1- # to mask from subsequent extensions. return 0 if ($this_call_default); return 5 if ($rv); return 0; }, @_); } else { &multi_module_dispatch( \&defaultexception, \@m_exception, 0, @_); } } sub multishutdown { return if ($shutdown_already_called++); &multi_module_dispatch(\&defaultshutdown, \@m_shutdown, 0, @_); } sub multiuserhandle { &multi_module_dispatch(\&defaultuserhandle, \@m_userhandle, sub{ # skip default calls. return 0 if ($this_call_default); # return immediately on the first extension to accept return (shift>0); }, @_); } sub multilisthandle { &multi_module_dispatch(\&defaultlisthandle, \@m_listhandle, sub{ # skip default calls. return 0 if ($this_call_default); # return immediately on the first extension to accept return (shift>0); }, @_); } sub multihandle { &multi_module_dispatch(\&defaulthandle, \@m_handle, sub { my $rv = shift; # skip default calls. return 0 if ($this_call_default); # if not a default call, and the tweet was refused for # processing by this extension, then the tweet is now # suppressed. do not call any other extensions after this. # even if it ends in suppression, we still call the default # if it was ever called before. return 5 if ($rv==0); # if accepted in any manner, keep calling. return 0; }, @_); } sub multiheartbeat { &multi_module_dispatch(\&defaultheartbeat, \@m_heartbeat, 0, @_); } sub multiprecommand { &multi_module_dispatch(\&defaultprecommand, \@m_precommand, sub { return 2; # feed subsequent chains the result. }, @_); } sub multiprepost { &multi_module_dispatch(\&defaultprepost, \@m_prepost, sub { return 2; # feed subsequent chains the result. }, @_); } sub multipostpost { &multi_module_dispatch(\&defaultpostpost, \@m_postpost, 0, @_); } sub multitweettype { &multi_module_dispatch(\&defaulttweettype, \@m_tweettype, sub { # if this module DID NOT call default, exit now. return (!$this_call_default); }, @_); } sub flag_default_call { $this_call_default++; $did_call_default++; } # now the actual default methods sub defaultexception { (&flag_default_call, return) if ($multi_module_context); my $msg_code = shift; return if ($msg_code == 2 && $muffle_server_messages); my $message = "@_"; $message =~ s/\n*$//sg; if ($timestamp) { my ($time, $ts) = &$wraptime(scalar(localtime)); $message = "[$ts] $message"; $message =~ s/\n/\n[$ts] /sg; } &send_removereadline if ($termrl); $wrapseq = 1; print $stdout "${MAGENTA}${message}${OFF}\n"; &send_repaint if ($termrl); $laststatus = 1; } sub defaultshutdown { (&flag_default_call, return) if ($multi_module_context); } sub defaultlisthandle { (&flag_default_call, return) if ($multi_module_context); my $list_ref = shift; print $streamout "*** for future expansion ***\n"; return 1; } sub defaulthandle { (&flag_default_call, return) if ($multi_module_context); my $tweet_ref = shift; my $class = shift; my $dclass = ($verbose) ? "{$class,$tweet_ref->{'id_str'}} " : ''; my $sn = &descape($tweet_ref->{'user'}->{'screen_name'}); my $tweet = &descape($tweet_ref->{'text'}); my $stweet = &standardtweet($tweet_ref); my $menu_select = $tweet_ref->{'menu_select'}; $menu_select = (length($menu_select) && !$script) ? (($menu_select =~ /^z/) ? "${EM}${menu_select}>${OFF} " : "${menu_select}> ") : ''; print $streamout $menu_select . $dclass . $stweet; &sendnotifies($tweet_ref, $class); return 1; } sub defaultuserhandle { (&flag_default_call, return) if ($multi_module_context); my $user_ref = shift; &userline($user_ref, $streamout); my $desc = &strim(&descape($user_ref->{'description'})); my $klen = ($wrap || 79) - 9; $klen = 10 if ($klen < 0); $desc = substr($desc, 0, $klen)."..." if (length($desc) > $klen); print $streamout (' "' . $desc . '"' . "\n") if (length($desc)); return 1; } sub userline { # used by both $userhandle and /whois my $my_json_ref = shift; my $fh = shift; my $verified = ($my_json_ref->{'verified'} eq 'true') ? "${EM}(Verified)${OFF} " : ''; my $protected = ($my_json_ref->{'protected'} eq 'true') ? "${EM}(Protected)${OFF} " : ''; print $fh <<"EOF"; ${CCprompt}@{[ &descape($my_json_ref->{'name'}) ]}${OFF} (@{[ &descape($my_json_ref->{'screen_name'}) ]}) (f:$my_json_ref->{'friends_count'}/$my_json_ref->{'followers_count'}) (u:$my_json_ref->{'statuses_count'}) ${verified}${protected} EOF return; } sub sendnotifies { # this is a default subroutine of a sort, right? my $tweet_ref = shift; my $class = shift; my $sn = &descape($tweet_ref->{'user'}->{'screen_name'}); my $tweet = &descape($tweet_ref->{'text'}); # interactive? first time? unless (length($class) || !$last_id || !length($tweet)) { $class = scalar(&$tweettype($tweet_ref, $sn, $tweet)); ¬ifytype_dispatch($class, &standardtweet($tweet_ref, 1), $tweet_ref) if ($notify_list{$class}); } } sub defaulttweettype { (&flag_default_call, return) if ($multi_module_context); my $ref = shift; my $sn = shift; my $tweet = shift; # br3nda's and smb's modified colour patch unless ($anonymous) { if (lc($sn) eq $whoami) { # if it's me speaking, colour the line yellow return 'me'; } elsif ($tweet =~ /\@$whoami(\b|$)/i) { # if I'm in the tweet, colour red return 'reply'; } } if ($ref->{'class'} eq 'search') { # anonymous allows this too # if this is a search result, colour cyan return 'search'; } if ($ref->{'tag'}->{'type'} eq 'list') { # anonymous allows this too return 'list'; } return 'default'; } sub defaultconclude { (&flag_default_call, return) if ($multi_module_context); if ($filtered && $filter_attribs{'count'}) { print $stdout "-- (filtered $filtered tweets)\n"; $filtered = 0; } } sub defaultdmhandle { (&flag_default_call, return) if ($multi_module_context); my $dm_ref = shift; my $sns = &descape($dm_ref->{'sender'}->{'screen_name'}); print $streamout &standarddm($dm_ref); &senddmnotifies($dm_ref) if ($sns ne $whoami); return 1; } sub senddmnotifies { my $dm_ref = shift; ¬ifytype_dispatch('DM', &standarddm($dm_ref, 1), $dm_ref) if ($notify_list{'dm'} && $last_dm); } sub defaulteventhandle { (&flag_default_call, return) if ($multi_module_context); my $event_ref = shift; # in this version, we silently filter delete events, but your # extension would still get them delivered. return 1 if ($event_ref->{'delete'}); print $streamout &standardevent($event_ref); return 1; } sub defaultdmconclude { (&flag_default_call, return) if ($multi_module_context); } sub defaultheartbeat { (&flag_default_call, return) if ($multi_module_context); } # not much sense to multi-module protect these. sub defaultprecommand { return ("@_"); } sub defaultprepost { return ("@_"); } sub defaultpostpost { (&flag_default_call, return) if ($multi_module_context); my $line = shift; return if (!$termrl); # populate %readline_completion if readline is on while($line =~ s/^\@(\w+)\s+//) { $readline_completion{'@'.lc($1)}++; } if ($line =~ /^[dD]\s+(\w+)\s+/) { $readline_completion{'@'.lc($1)}++; } } sub defaultautocompletion { my ($text, $line, $start) = (@_); my $qmtext = quotemeta($text); my @proband; my @rlkeys; # handle / completion if ($start == 0 && $text =~ m#^/#) { return sort grep(/^$qmtext/i, '/history', '/print', '/quit', '/bye', '/again', '/wagain', '/whois', '/thump', '/dm', '/refresh', '/dmagain', '/set', '/help', '/reply', '/url', '/thread', '/retweet', '/replyall', '/replies', '/ruler', '/exit', '/me', '/vcheck', '/oretweet', '/eretweet', '/fretweet', '/liston', '/listoff', '/dmsent', '/rtsof', '/rtson', '/rtsoff', '/lists', '/withlist', '/add', '/padd', '/push', '/pop', '/followers', '/friends', '/lfollow', '/lleave', '/listfollowers', '/listfriends', '/unset', '/verbose', '/short', '/follow', '/unfollow', '/doesfollow', '/search', '/tron', '/troff', '/delete', '/deletelast', '/dump', '/track', '/trends', '/block', '/unblock', '/fave', '/faves', '/unfave', '/eval'); } @rlkeys = keys(%readline_completion); # handle @ completion. this works slightly weird because # readline hands us the string WITHOUT the @, so we have to # test somewhat blindly. this works even if a future readline # DOES give us the word with @. also handles D, /wa, /wagain, # /a, /again, etc. if (($line =~ m#^(D|/wa|/wagain|/a|/again) #i) || ($start == 1 && substr($line, 0, 1) eq '@') || # this code is needed to prevent inline @ from flipping out ($start >= 1 && substr($line, ($start-2), 2) eq ' @')) { @proband = grep(/^\@$qmtext/i, @rlkeys); if (scalar(@proband)) { @proband = map { s/^\@//;$_ } @proband; return @proband; } } # definites that are left over, including @ if it were included if(scalar(@proband = grep(/^$qmtext/i, @rlkeys))) { return @proband; } # heuristics # URL completion (this doesn't always work of course) if ($text =~ m#https?://#) { return (&urlshorten($text) || $text); } # "I got nothing." return (); } #### built-in notification routines #### # growl for Mac OS X sub notifier_growl { my $class = shift; my $text = shift; my $ref = shift; # not used in this version if (!defined($class) || !length($notify_tool_path)) { # we are being asked to initialize $notify_tool_path = &wherecheck("trying to find growlnotify", "growlnotify", "growlnotify must be installed to use growl notifications. check your\n" . "documentation for how to do this.\n") unless ($notify_tool_path); if (!defined($class)) { return 1 if ($script || $notifyquiet); $class = 'Growl support activated'; $text = 'You can configure notifications for TTYtter in the Growl preference pane.'; } } # handle this in the background for faster performance. # to avoid problems with SIGCHLD, we fork ourselves twice (mmm!), # leaving an orphan which init should grab (we need SIGCHLD for # proper backticks, so it can't be IGNOREd). my $gchild; if ($gchild = fork()) { # the parent harvests the child, which will die immediately. waitpid($gchild, 0); return 1; } elsif (!defined ($gchild)) { print $stdout "warning: failed growl fork: $!\n"; return 1; } # this is the child. spawn, then exit and abandon our own child, # which init will reap. the problem with teen pregnancy is mounting. $in_backticks = 1; my $hchild; if ($hchild = fork()) { exit; } elsif (!defined ($hchild)) { print $stdout "warning: failed growl fork: $!\n"; exit; } # this is the subchild, which is abandoned at a fire sta^W^W^Winit. open(GROWL, "|$notify_tool_path -n 'TTYtter' 'TTYtter: $class'"); binmode(GROWL, ":utf8") unless ($seven); print GROWL $text; close(GROWL); exit; } # libnotify for {Linux,whatevs} # this is EXPERIMENTAL, and requires this patch to notify-send: # http://www.floodgap.com/software/ttytter/libnotifypatch.txt # why it has not already been applied is fricking beyond me, it makes # sense. would YOU want arbitrary characters on the command line # separated only from overwriting your home directory by a quoting routine? sub notifier_libnotify { my $class = shift; my $text = shift; my $ref = shift; # not used in this version if (!defined($class) || !defined($notify_tool_path)) { # we are being asked to initialize $notify_tool_path = &wherecheck("trying to find notify-send", "notify-send", "notify-send must be installed to use libnotify, and it must be modified\n". "for standard input. see the documentation for how to do this.\n") unless ($notify_tool_path); if (!defined($class)) { return 1 if ($script || $notifyquiet); $class = 'libnotify support activated'; $text = 'Congratulations, your notify-send is correctly configured for TTYtter.'; } } # figure out the time to display based on length of tweet my $t = 1000+50*length($text); # about 150-180wpm read speed open(NOTIFYSEND, "|$notify_tool_path -t $t -f - 'TTYtter: $class'"); binmode(NOTIFYSEND, ":utf8") unless ($seven); print NOTIFYSEND $text; close(NOTIFYSEND); return 1; } #### IPC routines for communicating between the foreground + background #### # this is the central routine that takes a rolling tweet code, figures # out where that tweet is, and returns something approximating a tweet # structure (or the actual tweet structure itself if it can). sub get_tweet { my $code = lc(shift); #TODO # implement querying the id_cache here. we need IPC for it, though. # if the code is all numbers, treat it like an id_str, and try # to get it from the server. we have similar code in get_dm. # the first tweet that is of relevance is ID 20. try /dump 20 :) return &grabjson("${idurl}?id=${code}", 0, 0, 0, undef, 1) if ($code =~ /^[0-9]+$/ && (0+$code > 19)); return undef if ($code !~ /^z?[a-z][0-9]$/); my $source = ($code =~ /^z/) ? 1 : 0; my $k = ''; my $l = ''; my $w = {'user' => {}}; if ($is_background) { if ($source == 1) { # foreground only return undef; } return $store_hash{$code}; } return $store_hash{$code} if ($source); # foreground c/foreground twt print $stdout "-- querying background: $code\n" if ($verbose); kill $SIGUSR2, $child if ($child); print C "pipet $code ----------\n"; while(length($k) < 1024) { sysread(W, $l, 1024); $k .= $l; } return undef if ($k !~ /[^\s]/); $k =~ s/\s+$//; # remove trailing spaces print $stdout "-- background store fetch: $k\n" if ($verbose); ($w->{'menu_select'}, $w->{'id_str'}, $w->{'in_reply_to_status_id_str'}, $w->{'retweeted_status'}->{'id_str'}, $w->{'user'}->{'geo_enabled'}, $w->{'geo'}->{'coordinates'}->[0], $w->{'geo'}->{'coordinates'}->[1], $w->{'place'}->{'id'}, $w->{'place'}->{'country_code'}, $w->{'place'}->{'place_type'}, $w->{'place'}->{'full_name'}, $w->{'tag'}->{'type'}, $w->{'tag'}->{'payload'}, $w->{'retweet_count'}, $w->{'user'}->{'screen_name'}, $w->{'created_at'}, $l) = split(/\s/, $k, 17); ($w->{'source'}, $k) = split(/\|/, $l, 2); $w->{'text'} = pack("H*", $k); $w->{'place'}->{'full_name'} = pack("H*",$w->{'place'}->{'full_name'}); $w->{'tag'}->{'payload'} = pack("H*", $w->{'tag'}->{'payload'}); return undef if (!length($w->{'text'})); # unpossible $w->{'created_at'} =~ s/_/ /g; return $w; } # this is the analogous function for a rolling DM code. it is somewhat # simpler as DM codes are always rolling and have no foreground store # currently, so it always executes a background request. sub get_dm { my $code = lc(shift); my $k = ''; my $l = ''; my $w = {'sender' => {}}; return undef if (length($code) < 3 || $code !~ s/^d//); # this is the aforementioned "similar code" (see get_tweet). # optimization: I doubt ANY of us can get DMIDs less than 9. return &grabjson("${dmidurl}?id=$code", 0, 0, 0, undef, 1) if ($code =~ /^[0-9]+$/ && (0+$code > 9)); return undef if ($code !~ /^[a-z][0-9]$/); kill $SIGUSR2, $child if ($child); # prime pipe print C "piped $code ----------\n"; # internally two alphanum, recall while(length($k) < 1024) { sysread(W, $l, 1024); $k .= $l; } return undef if ($k !~ /[^\s]/); $k =~ s/\s+$//; # remove trailing spaces print $stdout "-- background store fetch: $k\n" if ($verbose); ($w->{'menu_select'}, $w->{'id_str'}, $w->{'sender'}->{'screen_name'}, $w->{'created_at'}, $l) = split(/\s/, $k, 5); $w->{'text'} = pack("H*", $l); return undef if (!length($w->{'text'})); # not possible $w->{'created_at'} =~ s/_/ /g; return $w; } # this function requests a $store key from the background. it only works # if foreground. sub getbackgroundkey { if ($is_background) { print $stdout "*** can't call getbackgroundkey from background\n"; return undef; } my $key = shift; my $l; my $k; print C substr("ki $key ---------------------", 0, 19)."\n"; my $ref = (length($dispatch_ref->[0])) ? ($dispatch_ref->[0]) : "DEFAULT"; print C substr(unpack("${pack_magic}H*", $ref).$space_pad, 0, 1024); while(length($k) < 1024) { sysread(W, $l, 1024); $k .= $l; } $k =~ s/[^0-9a-fA-F]//g; print $stdout "-- background store fetch: $k\n" if ($verbose); return pack("H*", $k); } # this function sends a $store key to the background. it only works if # foreground. sub sendbackgroundkey { if ($is_background) { print $stdout "*** can't call sendbackgroundkey from background\n"; return; } my $key = shift; my $value = shift; if (ref($value)) { print $stdout "*** send_key only supported for scalars\n"; return; } if (!length($value)) { print C substr("kn $key ---------------------", 0, 19)."\n"; } else { print C substr("ko $key ---------------------", 0, 19)."\n"; } my $ref = (length($dispatch_ref->[0])) ? ($dispatch_ref->[0]) : "DEFAULT"; print C substr(unpack("${pack_magic}H*", $ref).$space_pad, 0, 1024); return if (!length($value)); print C substr(unpack("${pack_magic}H*", $value).$space_pad, 0, 1024); } sub thump { print C "update-------------\n"; &sync_semaphore; } sub dmthump { print C "dmthump------------\n"; &sync_semaphore; } sub sync_n_quit { if ($child) { print $stdout "waiting for child ...\n" unless ($silent); print C "sync---------------\n"; waitpid $child, 0; $child = 0; print $stdout "exiting.\n" unless ($silent); exit ($? >> 8); } exit; } # setter for internal variables, with all the needed side effects for those # variables that are programmed to trigger internal actions when changed. sub setvariable { my $key = shift; my $value = shift; my $interactive = 0+shift; $value =~ s/^\s+//; $value =~ s/\s+$//; # mostly to avoid problems with /(p)add if ($key eq 'script') { # this can never be changed by this routine print $stdout "*** script may only be changed on init\n"; return 1; } if ($key eq 'tquery' && $value eq '0') { # undo tqueries $tquery = undef; $key = 'track'; $value = $track; # falls thru to sync &tracktags_makearray; } if ($opts_can_set{$key} || # we CAN set read-only variables during initialization ($multi_module_mode == -1 && $valid{$key})) { if (length($value) > 1023) { # can't transmit this in a packet print $stdout "*** value too long\n"; return 1; } elsif ($opts_boolean{$key} && $value ne '0' && $value ne '1') { print $stdout "*** 0|1 only (boolean): $key\n"; return 1; } elsif ($opts_urls{$key} && $value !~ m#^(http|https|gopher)://#) { print $stdout "*** must be valid URL: $key\n"; return 1; } else { KEYAGAIN: $$key = $value; print $stdout "*** changed: $key => $$key\n" if ($interactive || $verbose); # handle special values &generate_ansi if ($key eq 'ansi' || $key =~ /^colour/); &generate_shortdomain if ($key eq 'shorturl'); &tracktags_makearray if ($key eq 'track'); &filter_compile if ($key eq 'filter'); ¬ify_compile if ($key eq 'notifies'); &list_compile if ($key eq 'lists'); &filterflags_compile if ($key eq 'filterflags'); $filterrts_sub = &filteruserlist_compile( $filterrts_sub, $value) if ($key eq 'filterrts'); $filterusers_sub = &filteruserlist_compile( $filterusers_sub,$value) if ($key eq 'filterusers'); $filteratonly_sub = &filteruserlist_compile( $filteratonly_sub, $value) if ($key eq 'filteratonly'); &filterats_compile if ($key eq 'filterats'); # transmit to background process sync-ed values if ($opts_sync{$key}) { &synckey($key, $value, $interactive); } if ($key eq 'superverbose') { if ($value eq '0') { $key = 'verbose'; $value = $supreturnto; goto KEYAGAIN; } $supreturnto = $verbose; } } # virtual keys } elsif ($key eq 'tquery') { my $ivalue = &tracktags_tqueryurlify($value); if (length($ivalue) > 139) { print $stdout "*** custom query is too long (encoded: $ivalue)\n"; return 1; } else { $tquery = $value; &synckey($key, $ivalue, $interactive); } } elsif ($valid{$key}) { print $stdout "*** read-only, must change on command line: $key\n"; return 1; } else { print $stdout "*** not a valid option or setting: $key\n"; return 1; } return 0; } sub synckey { my $key = shift; my $value = shift; my $interactive = 0+shift; my $commchar = ($interactive) ? '=' : '+'; print $stdout "*** (transmitting to background)\n" if ($interactive || $verbose); return if (!$child); kill $SIGUSR2, $child if ($child); print C (substr("${commchar}$key ", 0, 19) . "\n"); print C (substr(($value . $space_pad), 0, 1024)); sleep 1; } # getter for internal variables. right now this just returns the variable by # name and a couple virtuals, but in the future this might be expanded. sub getvariable { my $key = shift; if ($valid{$key}) { return $$key; } if ($key eq 'effpause' || $key eq 'rate_limit_rate' || $key eq 'rate_limit_left') { my $value; kill $SIGUSR2, $child if ($child); print C (substr("?$key ", 0, 19) . "\n"); sysread(W, $value, 1024); $value =~ s/\s+$//; return $value; } return undef; } # compatibility stub for extensions calling the old wraptime sub wraptime { return &$wraptime(@_); } #### url management (/url, /short) #### sub generate_shortdomain { my $x; my $y; undef $shorturldomain; ($shorturl =~ m#^http://([^/]+)/#) && ($x = $1); # chop off any leading hostname stuff (like api., etc.) while(1) { $y = $x; $x =~ s/^[^\.]*\.//; if ($x !~ /\./) { # a cut too far $shorturldomain = "http://$y/"; last; } } print $stdout "-- warning: couldn't parse shortener service\n" if (!length($shorturldomain)); } sub openurl { my $comm = $urlopen; my $url = shift; $url = "http://gopher.floodgap.com/gopher/gw?".&url_oauth_sub($url) if ($url =~ m#^gopher://# && $comm !~ /^[^\s]*lynx/); $urlshort = $url; $comm =~ s/\%U/'$url'/g; print $stdout "($comm)\n"; system("$comm"); } sub urlshorten { my $url = shift; my $rc; my $cl; $url = "http://gopher.floodgap.com/gopher/gw?".&url_oauth_sub($url) if ($url =~ m#^gopher://#); return $url if ($url =~ /^$shorturldomain/i); # stop loops $url = &url_oauth_sub($url); $cl = "$simple_agent \"${shorturl}$url\""; print $stdout "$cl\n" if ($superverbose); chomp($rc = `$cl`); return ($urlshort = (($rc =~ m#^http://#) ? $rc : undef)); } ##### optimizers -- these compile into an internal format ##### # utility routine for tquery support sub tracktags_tqueryurlify { my $value = shift; $value =~ s/([^ a-z0-9A-Z_])/"%".unpack("H2",$1)/eg; $value =~ s/\s/+/g; $value = "q=$value" if ($value !~ /^q=/); return $value; } # tracking subroutines # run when a string is passed sub tracktags_makearray { @tracktags = (); $track =~ s/^'//; $track =~ s/'$//; $track = lc($track); if (!length($track)) { @trackstrings = (); return; } my $k; my $l = ''; my $q = 0; my %w; my (@ptags) = split(/\s+/, $track); # filter duplicates and merge quoted strings foreach $k (@ptags) { if ($q && $k =~ /"$/) { # this has to be first $l .= " $k"; $q = 0; } elsif ($k =~ /^"/ || $q) { $l .= (length($l)) ? " $k" : $k; $q = 1; next; } else { $l = $k; } if ($w{$l}) { print $stdout "-- warning: dropping duplicate track term \"$l\"\n"; } elsif (uc($l) eq 'OR' || uc($l) eq 'AND') { print $stdout "-- warning: dropping unnecessary logical op \"$l\"\n"; } else { $w{$l} = 1; push(@tracktags, $l); } $l = ''; } print $stdout "-- warning: syntax error, missing quote?\n" if ($q); $track = join(' ', @tracktags); &tracktags_compile; } # run when array is altered (based on @kellyterryjones' code) sub tracktags_compile { @trackstrings = (); return if (!scalar(@tracktags)); my $k; my $l = ''; # need to limit track tags to a certain number of pieces TAGBAG: foreach $k (@tracktags) { if (length($k) > 130) { # I mean, really print $stdout "-- warning: track tag \"$k\" is TOO LONG\n"; next TAGBAG; } if (length($l)+length($k) > 150) { # balance of size/querytime push(@trackstrings, "q=".&url_oauth_sub($l)); $l = ''; } $l = (length($l)) ? "${l} OR ${k}" : "${k}"; } push(@trackstrings, "q=".&url_oauth_sub($l)) if (length($l)); } # notification multidispatch sub notifytype_dispatch { return if (!scalar(@notifytypes)); my $nt; foreach $nt (@notifytypes) { &$nt(@_); } } # notifications compiler sub notify_compile { if ($notifies) { my $w; undef %notify_list; foreach $w (split(/\s*,\s*/, $notifies)) { $notify_list{$w} = 1; } $notifies = join(',', keys %notify_list); } } # lists compiler # we don't check the validity of lists here; /liston and /listoff do that. sub list_compile { my @oldlistlist = @listlist; my %already; undef @listlist; if ($lists) { my $w; my $u; my $l; foreach $w (split(/\s*,\s*/, $lists)) { $w =~ s/^@//; if ($w =~ m#/#) { ($u, $l) = split(m#\s*/\s*#, $w, 2); } else { $l = $w; } if (!length($u) && $anonymous) { print $stdout "*** must use fully specified lists when anonymous\n"; @listlist = @oldlistlist; return 0; } $u ||= $whoami; if ($l =~ m#/#) { print $stdout "*** syntax error in list $u/$l\n"; @listlist = @oldlistlist; return 0; } if ($already{"$u/$l"}++) { print $stdout "*** duplicate list $u/$l ignored\n"; } else { push(@listlist, [ $u, $l ]); } } $lists = join(',', keys %already); } return 1; } # -filterflags compiler (replaces old -filter syntax) sub filterflags_compile { my $s = $filterflags; undef %filter_attribs; $s =~ s/^\s*['"]?\s*//; $s =~ s/\s*['"]?\s*$//; return if (!length($s)); %filter_attribs = map { $_ => 1 } split(/\s*,\s*/, $s); } # -filterrts and -filterusers compiler. these simply use a list of usernames, # so they are fast and the same code suffices. emit code to compile that # just is one if-expression after another. sub filteruserlist_compile { my $old = shift; my $s = shift; undef $k; $s =~ s/^\s*['"]?\s*//; $s =~ s/\s*['"]?\s*$//; return $k if (!length($s)); my @us = map { $k=lc($_); "\$sn eq '$k'" } split(/\s*,\s*/, $s); my $uus = join(' || ', @us); my $uuus = <<"EOF"; \$k = sub { my \$sn = shift; return 1 if ($uus); return 0; }; EOF # print $stdout $uuus; eval $uuus; if (!defined($k)) { print $stdout "** bogus name in user list (error = $@)\n"; return $old; } return $k; } # -filterats compiler. this takes a list of usernames and then compiles a # whole bunch of regexes. sub filterats_compile { undef $filterats_c; my $s = $filterats; $s =~ s/^\s*['"]?\s*//; $s =~ s/\s*['"]?\s*$//; return 1 if (!length($s)); # undef my @us = map { $k=lc($_); "\$x=~/\\\@$k\\b/i" } split(/\s*,\s*/, $s); my $uus = join(' || ', @us); my $uuus = <<"EOF"; \$filterats_c = sub { my \$x = shift; return 1 if ($uus); return 0; }; EOF # print $stdout $uuus; eval $uuus; if (!defined($filterats_c)) { print $stdout "** bogus name in user list (error = $@)\n"; return 0; } return 1; } # -filter compiler. this is the generic case. sub filter_compile { undef %filter_attribs unless (length($filterflags)); undef $filter_c; if (length($filter)) { my $tfilter = $filter; $tfilter =~ s/^['"]//; $tfilter =~ s/['"]$//; # note attributes (compatibility) while ($tfilter =~ s/^([a-z]+),//) { my $atkey = $1; $filter_attribs{$atkey}++; print $stdout "** $atkey filter parameter should be in -filterflags\n"; } my $b = <<"EOF"; \$filter_c = sub { local \$_ = shift; return ($tfilter); }; EOF #print $b; eval $b; if (!defined($filter_c)) { print $stdout ("** syntax error in your filter: $@\n"); return 0; } } return 1; } #### common system subroutines follow #### sub updatecheck { my $vcheck_url = "http://www.floodgap.com/software/ttytter/02current.txt"; my $vrlcheck_url = "http://www.floodgap.com/software/ttytter/01readlin.txt"; my $update_url = shift; my $vs = ''; my $vvs; my $tverify; my $inversion; my $bversion; my $rcnum; my $download; my $maj; my $min; my $s1, $s2, $s3; my $update_trlt = undef; if ($termrl && $termrl->ReadLine eq 'Term::ReadLine::TTYtter') { my $trlv = $termrl->Version; print $stdout "-- checking Term::ReadLine::TTYtter version: $vrlcheck_url\n"; $vvs = `$simple_agent $vrlcheck_url`; print $stdout "-- server response: $vvs\n" if ($verbose); ($vvs, $s1, $s2, $s3) = split(/--__--\n/s, $vvs); $s1 = undef if ($s1 !~ /^\*/) ; $s2 = undef if ($s2 !~ /^\*/) ; $s3 = undef if ($s3 !~ /^\*/) ; chomp($vvs); # right now we're only using $inversion (no betas/rcs). ($tverify, $inversion, $bversion, $rcnum, $download, $bdownload) = split(/;/, $vvs, 6); if ($tverify ne 'trlt') { $vs .= "-- warning: unable to verify Term::ReadLine::TTYtter version\n"; } else { if ($trlv < 0+$inversion) { $vs .= "** NEW Term::ReadLine::TTYtter VERSION AVAILABLE: $inversion **\n" . "** GET IT: $download\n"; $update_trlt = $download; } else { $vs .= "-- your version of Term::ReadLine::TTYtter is up to date ($trlv)\n"; } } } print $stdout "-- checking TTYtter version: $vcheck_url\n"; $vvs = `$simple_agent $vcheck_url`; print $stdout "-- server response: $vvs\n" if ($verbose); ($vvs, $s1, $s2, $s3) = split(/--__--\n/s, $vvs); $s1 = undef if ($s1 !~ /^\*/) ; $s2 = undef if ($s2 !~ /^\*/) ; $s3 = undef if ($s3 !~ /^\*/) ; chomp($vvs); ($tverify, $inversion, $bversion, $rcnum, $download, $bdownload) = split(/;/, $vvs, 6); if ($tverify ne 'ttytter') { $vs .= "-- warning: unable to verify TTYtter version\n"; } else { if ($my_version_string eq $bversion) { $vs .= "** REMINDER: you are using a beta version (${my_version_string}b${TTYtter_RC_NUMBER})\n"; $vs .= "** NEW TTYtter RELEASE CANDIDATE AVAILABLE: build $rcnum **\n" . "** get it: $bdownload\n$s2" if ($TTYtter_RC_NUMBER < $rcnum); $vs .= "** (this is the most current beta)\n" if ($TTYtter_RC_NUMBER == $rcnum); $vs .= "$s1$s3"; if ($TTYtter_RC_NUMBER < $rcnum) { if ($update_url) { $vs .= "-- %URL% is now $bdownload (/short shortens, /url opens)\n"; $urlshort = $bdownload; } } elsif (length($update_trlt) && $update_url) { $urlshort = $update_trlt; $vs .= "-- %URL% is now $urlshort (/short shortens, /url opens)\n"; } return $vs; } if ($my_version_string eq $inversion && $TTYtter_RC_NUMBER) { $vs .= "** FINAL TTYtter RELEASE NOW AVAILABLE for version $inversion **\n" . "** get it: $download\n$s2$s1"; if ($update_url) { $vs .= "-- %URL% is now $bdownload (/short shortens, /url opens)\n"; $urlshort = $bdownload; } return $vs; } ($inversion =~/^(\d+\.\d+)\.(\d+)$/) && ($maj = 0+$1, $min = 0+$2); if (0+$TTYtter_VERSION < $maj || (0+$TTYtter_VERSION == $maj && $TTYtter_PATCH_VERSION < $min)) { $vs .= "** NEWER TTYtter VERSION NOW AVAILABLE: $inversion **\n" . "** get it: $download\n$s2$s1"; if ($update_url) { $vs .= "-- %URL% is now $download (/short shortens, /url opens)\n"; $urlshort = $download; } return $vs; } elsif (0+$TTYtter_VERSION > $maj || (0+$TTYtter_VERSION == $maj && $TTYtter_PATCH_VERSION > $min)) { $vs .= "** unable to identify your version of TTYtter\n$s1"; } else { $vs .= "-- your version of TTYtter is up to date ($inversion)\n$s1"; } } # if we got this far, then there is no TTYtter update, but maybe a # T:RL:T update, so we offer that as the URL if (length($update_trlt) && $update_url) { $urlshort = $update_trlt; $vs .= "-- %URL% is now $urlshort (/short shortens, /url opens)\n"; } return $vs; } sub generate_otabcomp { if (scalar(@j = keys(%readline_completion))) { # print optimized readline. include all that we # manually specified, plus/including top @s, total 10. @keys = sort { $readline_completion{$b} <=> $readline_completion{$a} } @j; $factor = $readline_completion{$keys[0]}; foreach(keys %original_readline) { $readline_completion{$_} += $factor; } print $stdout "*** optimized readline:\n"; @keys = sort { $readline_completion{$b} <=> $readline_completion{$a} } keys %readline_completion; @keys = @keys[0..14] if (scalar(@keys) > 15); print $stdout "-readline=\"@keys\"\n"; } } sub end_me { exit; } # which falls through to, via END, ... sub killkid { # for streaming assistance if ($child) { print $stdout "\n\ncleaning up.\n"; kill $SIGHUP, $child; # warn it about shutdown if (length($track)) { print $stdout "*** you were tracking:\n"; print $stdout "-track='$track'\n"; } if (length($filter)) { print $stdout "*** your current filter expression:\n"; print $stdout "-filter='$filter'\n"; } &generate_otabcomp; sleep 2 if ($dostream); kill 9, $curlpid if ($curlpid); kill 9, $child; } &$shutdown unless (!$shutdown); } sub generate_ansi { my $k; $BLUE = ($ansi) ? "${ESC}[34;1m" : ''; $RED = ($ansi) ? "${ESC}[31;1m" : ''; $GREEN = ($ansi) ? "${ESC}[32;1m" : ''; $YELLOW = ($ansi) ? "${ESC}[33m" : ''; $MAGENTA = ($ansi) ? "${ESC}[35m" : ''; $CYAN = ($ansi) ? "${ESC}[36m" : ''; $EM = ($ansi) ? "${ESC}[1m" : ''; $UNDER = ($ansi) ? "${ESC}[4m" : ''; $OFF = ($ansi) ? "${ESC}[0m" : ''; foreach $k (qw(prompt me dm reply warn search list default)) { ${"colour$k"} = uc(${"colour$k"}); if (!defined($${"colour$k"})) { print $stdout "-- warning: bogus colour '".${"colour$k"}."'\n"; } else { eval("\$CC$k = \$".${"colour$k"}); } } eval '$termrl->hook_use_ansi' if ($termrl); } # always POST sub postjson { my $url = shift; my $postdata = shift; # add _method=DELETE for delete my $data; # this is copied mostly verbatim from grabjson chomp($data = &backticks($baseagent, '/dev/null', undef, $url, $postdata, 0, @wend)); my $k = $? >> 8; $data =~ s/[\r\l\n\s]*$//s; $data =~ s/^[\r\l\n\s]*//s; if (!length($data) || $k == 28 || $k == 7 || $k == 35) { &$exception(1, "*** warning: timeout or no data\n"); return undef; } # old non-JSON based error reporting code still supported if ($data =~ /^\[?\]?/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); } # count needs to be removed for the default case due to show, etc. push(@xargs, "count=$count") if ($count); # timeline control. this speeds up parsing since there's less data. # can't use skip_user: no SN push (@xargs, "since_id=${last_id}") if ($last_id); # request entities, which should be supported everywhere now push (@xargs, "include_entities=1") if ($do_entities); my $resource = (scalar(@xargs)) ? [ $url, join('&', sort @xargs) ] : $url; chomp($data = &backticks($baseagent, '/dev/null', undef, $resource, undef, $is_anon + $anonymous, @wind)); my $k = $? >> 8; $data =~ s/[\r\l\n\s]*$//s; $data =~ s/^[\r\l\n\s]*//s; if (!length($data) || $k == 28 || $k == 7 || $k == 35) { &$exception(1, "*** warning: timeout or no data\n"); return undef; } # old non-JSON based error reporting code still supported if ($data =~ /^\[?\]?<!DOCTYPE\s+html/i || $data =~ /^(Status:\s*)?50[0-9]\s/ || $data =~ /^<html>/i || $data =~ /^<\??xml\s+/) { print $stdout $data if ($superverbose); if (&is_fail_whale($data)) { &$exception(2, "*** warning: Twitter Fail Whale\n"); } else { &$exception(2, "*** warning: Twitter error message received\n" . (($data =~ /<title>Twitter:\s*([^<]+)</) ? "*** \"$1\"\n" : '')); } return undef; } if ($data =~ /^rate\s*limit/i) { print $stdout $data if ($superverbose); &$exception(3, "*** warning: exceeded API rate limit for this interval.\n" . "*** no updates available until interval ends.\n"); return undef; } if ($k > 0) { &$exception(4, "*** warning: unexpected error code ($k) from user agent\n"); return undef; } # handle things like 304, or other things that look like HTTP # error codes if ($data =~ m#^HTTP/\d\.\d\s+(\d+)\s+#) { $code = 0+$1; print $stdout $data if ($superverbose); # 304 is actually a cop-out code and is not usually # returned, so we should consider it a non-fatal error if ($code == 304 || $code == 200 || $code == 204) { &$exception(1, "*** warning: timeout or no data\n"); return undef; } &$exception(4, "*** warning: unexpected HTTP return code $code from server\n"); return undef; } # test for error/warning conditions with trivial case if ($data =~ /^\s*\{\s*(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1/s || $data =~ /(['"])(warning|error)\1\s*:\s*\1([^\1]*?)\1\}/s) { print $stdout $data if ($superverbose); &$exception(2, "*** warning: server $2 message received\n" . "*** \"$3\"\n"); return undef; } # if wrapped in statuses object, unwrap it # (and tag it to do more later) if ($data =~ s/^\s*(\{)\s*['"]statuses['"]\s*:\s*(\[.*\]).*$/$2/isg) { $kludge_search_api_adjust = 1; } $my_json_ref = &parsejson($data); # normalize the data into a standard form. # single tweets such as from statuses/show aren't arrays, so # we special-case for them. if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' && $my_json_ref->{'favorited'} && $my_json_ref->{'source'} && ((0+$my_json_ref->{'id'}) || length($my_json_ref->{'id_str'}))) { $my_json_ref = &normalizejson($my_json_ref); } if (defined($my_json_ref) && ref($my_json_ref) eq 'ARRAY') { foreach $i (@{ $my_json_ref }) { $i = &normalizejson($i,$kludge_search_api_adjust,$tag); } } $laststatus = 0; return $my_json_ref; } # convert t.co into actual URLs. separate from normalizejson because other # things need this. modified from /entities. sub destroy_all_tco { my $hash = shift; return $hash if ($notco); my $v; my $w; # Twitter puts entities in multiple fields. foreach $w (qw(media urls)) { my $p = $hash->{'entities'}->{$w}; next if (!defined($p) || ref($p) ne 'ARRAY'); foreach $v (@{ $p }) { next if (!defined($v) || ref($v) ne 'HASH'); next if (!length($v->{'url'}) || (!length($v->{'expanded_url'}) && !length($v->{'media_url'}))); my $u1 = quotemeta($v->{'url'}); my $u2 = $v->{'expanded_url'}; my $u3 = $v->{'media_url'}; my $u4 = $v->{'media_url_https'}; $u2 = $u4 || $u3 || $u2; $hash->{'text'} =~ s/$u1/$u2/; } } return $hash; } # takes a tweet structure and normalizes it according to settings. # what this currently does is the following gyrations: # - if there is no id_str, see if we can convert id into one. if # there is loss of precision, warn the user. same for # in_reply_to_status_id_str. # - if the source of this JSON data source is the Search API, translate # its fields into the standard API. # - if the calling function has specified a tag, tag the tweets, since # we're iterating through them anyway. the tag should be a hashref payload. # - if the tweet is an newRT, unwrap it so that the full tweet text is # revealed (unless -nonewrts). # - if this appears to be a tweet, put in a stub geo hash if one does # not yet exist. # - if coordinates are flat string 'null', turn into a real null. # one day I would like this code to go the hell away. sub normalizejson { my $i = shift; my $kludge_search_api_adjust = shift; my $tag = shift; my $rt; # tag the tweet $i->{'tag'} = $tag if (defined($tag)); # id -> id_str if needed if (!length($i->{'id_str'})) { my $k = "" + (0 + $i->{'id'}); if ($k !~ /[eE][+-]/) { $i->{'id_str'} = $k; } else { # desperately try to convert $k =~ s/[eE][+-]\d+$//; $k =~ s/\.//g; # this is a hack, so we warn. &$exception(13, "*** impending doom: ID overflows Perl precision; stubbed to $k\n"); $i->{'id_str'} = $k; } } # irtsid -> irtsid_str (if there is one) if (!length($i->{'in_reply_to_status_id_str'}) && $i->{'in_reply_to_status_id'}) { my $k = "" + (0+$i->{'in_reply_to_status_id'}); if ($k !~ /[eE][+-]/) { $i->{'in_reply_to_status_id_str'} = $k; } else { # desperately try to convert $k =~ s/[eE][+-]\d+$//; $k =~ s/\.//g; # this is a hack, so we warn. &$exception(13, "*** impending doom: IRT-ID overflows Perl precision; stubbed to $k\n"); $i->{'in_reply_to_status_id_str'} = $k; } } # normalize geo. if this has a source and it has a # favorited, then it is probably a tweet and we will # add a stub geo hash if one doesn't exist yet. if ($kludge_search_api_adjust || ($i->{'favorited'} && $i->{'source'})){ $i = &fix_geo_api_data($i); } # hooray! this just tags it if ($kludge_search_api_adjust) { $i->{'class'} = "search"; } # normalize newRTs # if we get newRTs with -nonewrts, oh well if (!$nonewrts && ($rt = $i->{'retweeted_status'})) { # reconstruct the RT in a "canonical" format # without truncation, but detco it first $rt = &destroy_all_tco($rt); $i->{'retweeted_status'} = $rt; $i->{'text'} = "RT \@$rt->{'user'}->{'screen_name'}" . ': ' . $rt->{'text'}; } return &destroy_all_tco($i); } # process the JSON data ... simplemindedly, because I just write utter crap, # am not a professional programmer, and don't give a flying fig whether # kludges suck or no. this used to be part of grabjson, but I split it out. sub parsejson { my $data = shift; my $my_json_ref = undef; # durrr hat go on foot my $i; my $tdata; my $seed; my $bbqqmask; my $ddqqmask; my $ssqqmask; # test for single logicals return { 'ok' => 1, 'result' => (($1 eq 'true') ? 1 : 0), 'literal' => $1, } if ($data =~ /^['"]?(true|false)['"]?$/); # first isolate escaped backslashes with a unique sequence. $bbqqmask = "BBQQ"; $seed = 0; $seed++ while ($data =~ /$bbqqmask$seed/); $bbqqmask .= $seed; $data =~ s/\\\\/$bbqqmask/g; # next isolate escaped quotes with another unique sequence. $ddqqmask = "DDQQ"; $seed = 0; $seed++ while ($data =~ /$ddqqmask$seed/); $ddqqmask .= $seed; $data =~ s/\\\"/$ddqqmask/g; # then turn literal ' into another unique sequence. you'll see # why momentarily. $ssqqmask = "SSQQ"; $seed = 0; $seed++ while ($data =~ /$ssqqmask$seed/); $ssqqmask .= $seed; $data =~ s/\'/$ssqqmask/g; # here's why: we're going to turn doublequoted strings into single # quoted strings to avoid nastiness like variable interpolation. $data =~ s/\"/\'/g; # and then we're going to turn the inline ones all back except # ssqq, which we'll do last so that our syntax checker still works. $data =~ s/$bbqqmask/\\\\/g; $data =~ s/$ddqqmask/"/g; print $stdout "$data\n" if ($superverbose); # trust, but verify. I'm sure twitter wouldn't send us malicious # or bogus JSON, but one day this might talk to something that would. # in particular, need to make sure nothing in this will eval badly or # run arbitrary code. that would really suck! # first, generate a syntax tree. $tdata = $data; 1 while $tdata =~ s/'[^']*'//; # empty strings are valid too ... $tdata =~ s/-?[0-9]+\.?[0-9]*([eE][+-][0-9]+)?//g; # have to handle floats *and* their exponents $tdata =~ s/(true|false|null)//g; $tdata =~ s/\s//g; print $stdout "$tdata\n" if ($superverbose); # now verify the syntax tree. # the remaining stuff should just be enclosed in [ ], and only {}:, # for example, imagine if a bare semicolon were in this ... if ($tdata !~ s/^\[// || $tdata !~ s/\]$// || $tdata =~ /[^{}:,]/) { $tdata =~ s/'[^']*$//; # cut trailing strings if (($tdata =~ /^\[/ && $tdata !~ /\]$/) || ($tdata =~ /^\{/ && $tdata !~ /\}$/)) { # incomplete transmission &$exception(10, "*** JSON warning: connection cut\n"); return undef; } # it seems that :[], or :[]} should be accepted as valid in the syntax tree # since identica uses this as possible for null properties # ,[], shouldn't be, etc. if ($tdata =~ /(^|[^:])\[\]($|[^},])/) { # oddity &$exception(11, "*** JSON warning: null list\n"); return undef; } # at this point all we should have are structural elements. # if something other than JSON structure is visible, then # the syntax tree is mangled. don't try to run it, it # might be unsafe. this exception was formerly uniformly # fatal. it is now non-fatal as of 2.1. if ($tdata =~ /[^\[\]\{\}:,]/) { &$exception(99, "*** JSON syntax error\n"); print $stdout <<"EOF" if ($verbose); --- data received --- $data --- syntax tree --- $tdata --- JSON PARSING ABORTED DUE TO SYNTAX TREE FAILURE -- EOF return undef; } } # syntax tree passed, so let's turn it into a Perl reference. # have to turn colons into ,s or Perl will gripe. but INTELLIGENTLY! 1 while ($data =~ s/([^'])'\s*:\s*(true|false|null|\'|\{|\[|-?[0-9])/\1\',\2/); # finally, single quotes, just before interpretation. $data =~ s/$ssqqmask/\\'/g; # now somewhat validated, so safe (?) to eval() into a Perl struct eval "\$my_json_ref = $data;"; print $stdout "$data => $my_json_ref $@\n" if ($superverbose); # do a sanity check if (!defined($my_json_ref)) { &$exception(99, "*** JSON syntax error\n"); print $stdout <<"EOF" if ($verbose); --- data received --- $data --- syntax tree --- $tdata --- JSON PARSING FAILED -- $@ --- JSON PARSING FAILED -- EOF } return $my_json_ref; } sub fix_geo_api_data { my $ref = shift; $ref->{'geo'}->{'coordinates'} = undef if ($ref->{'geo'}->{'coordinates'} eq 'null' || $ref->{'geo'}->{'coordinates'}->[0] eq '' || $ref->{'geo'}->{'coordinates'}->[1] eq ''); $ref->{'geo'}->{'coordinates'} ||= [ "undef", "undef" ]; return $ref; } sub is_fail_whale { # is this actually the dump from a fail whale? my $data = shift; return ($data =~ m#<title>Twitter.+Over.+capacity.*#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; } if ($newline) { $x =~ s/\\n/\n/sg; $x =~ s/\\r//sg; } return $x; } # used by descape: turn UTF-16 surrogates into a Unicode character sub deutf16 { my $one = hex(shift); my $two = hex(shift); # subtract 55296 from $one to yield top ten bits $one -= 55296; # $d800 # subtract 56320 from $two to yield bottom ten bits $two -= 56320; # $dc00 # experimentally, Twitter uses this endianness below (we have no BOM) # see RFC 2781 4.3 return chr(($one << 10) + $two + 65536); } sub max { return ($_[0] > $_[1]) ? $_[0] : $_[1]; } sub min { return ($_[0] < $_[1]) ? $_[0] : $_[1]; } sub prolog { my $k = shift; return "" if (!scalar(@_)); my $l = shift; return (&$k($l) . &$k(@_)); } # this is mostly a utility function for /eval. it is a recursive descent # pretty printer. sub a { my $w; my $x; return '' if(scalar(@_) < 1); if(scalar(@_) > 1) { $x = "("; foreach $w (@_) { $x .= &a($w); } return $x."), "; } $w = shift; if(ref($w) eq 'SCALAR') { return "\\\"". $$w . "\", "; } if(ref($w) eq 'HASH') { my %m = %{ $w }; return "\n\t{".&prolog(\&a, %m)."}, "; } if(ref($w) eq 'ARRAY') { return "\n\t[".&prolog(\&a, @{ $w })."], "; } return "\"$w\", "; } sub ssa { return (scalar(@_) ? ("('" . join("', '", @_) . "')") : "NULL"); } sub strim { my $x=shift; $x=~ s/^\s+//; $x=~ s/\s+$//; return $x; } sub wwrap { return shift if (!$wrap); my $k; my $klop = ($wrap > 1) ? $wrap : ($ENV{'COLUMNS'} || 79); $klop--; # don't ask me why my $lop; my $buf = ''; my $string = shift; my $indent = shift; # for very first time with the prompt my $needspad = 0; my $stringpad = " " x 3; $indent += 4; # for the menu select string $lop = $klop - $indent; $lop -= $indent; W: while($k = length($string)) { $lop += $indent if ($lop < $klop); ($buf .= $string, last W) if ($k <= $lop && $string !~ /\n/); ($string =~ s/^\s*\n//) && ($buf .= "\n", $needspad = 1, next W); if ($needspad) { $string = " $string"; $needspad = 0; } # I don't know if people will want this, so it's commented out. #($string =~ s#^(http://[^\s]+)# #) && ($buf .= "$1\n", # next W); ($string =~ s/^(.{4,$lop})\s/ /) && ($buf .= "$1\n", next W); # i.e., at least one char, plus 3 space indent ($string =~ s/^(.{$lop})/ /) && ($buf .= "$1\n", next W); warn "-- pathologic string somehow failed wordwrap! \"$string\"\n"; return $buf; } 1 while ($buf =~ s/\n\n\n/\n\n/s); # mostly paranoia $buf =~ s/[ \t]+$//; return $buf; } # these subs look weird, but they're encoding-independent and run anywhere sub uforcemulti { # forces multi-byte interpretation by abusing Perl my $x = shift; return $x if ($seven); $x = "\x{263A}".$x; return pack("${pack_magic}H*", substr(unpack("${pack_magic}H*",$x),6)); } sub ulength { my @k; return (scalar(@k = unpack("${pack_magic}C*", shift))); } sub uhex { # URL-encode an arbitrary string, even UTF-8 # more versatile than the miniature one in &updatest my $k = ''; my $s = shift; &$utf8_encode($s); foreach(split(//, $s)) { my $j = unpack("H256", $_); while(length($j)) { $k .= '%' . substr($j, 0, 2); $j = substr($j, 2); } } return $k; } # for t.co # adapted from github.com/twitter/twitter-text-js/blob/master/twitter-text.js # this is very hard to get right, and I know there are edge cases. this first # one is designed to be quick and dirty because it needs to be fast more than # it needs to be accurate, since T:RL:T calls it a LOT. however, it can be # fooled, see below. sub fastturntotco { my $s = shift; my $w; # turn domain names into http urls. this should look at .com, .net, # .etc., but things like you.suck.too probably *should* hit this # filter. this uses the heuristic that a domain name over some limit # is probably not actually a domain name. ($s =~ s#\b(([a-zA-Z0-9-_]\.)+([a-zA-Z]){2,})\b#((length($w="$1")>45)?$w:"http://$w")#eg); # now turn all http and https URLs into t.co strings ($s =~ s#\b(https?)://[a-zA-Z0-9-_]+[^\s]*?('|\\|\s|[\.;:,!\?]\s+|[\.;:,!\?]$|$)#\1://t.co/1234567\2#gi); return $s; } # slow t.co converter. this is for future expansion. sub turntotco { return &fastturntotco(shift); } sub ulength_tco { my $w = shift; return &ulength(($notco) ? $w : &turntotco($w)); } sub length_tco { my $w = shift; return length(($notco) ? $w : &turntotco($w)); } # take a string and return up to $linelength CHARS plus the rest. sub csplit { return &cosplit(@_, sub { return &length_tco(shift); }); } # take a string and return up to $linelength BYTES plus the rest. sub usplit { return &cosplit(@_, sub { return &ulength_tco(shift); }); } sub cosplit { # this is the common code for &csplit and &usplit. # this is tricky because we don't want to split up UTF-8 sequences, so # we let Perl do the work since it internally knows where they end. my $orig_k = shift; my $mode = shift; my $lengthsub = shift; my $z; my @m; my $q; my $r; $mode += 0; $k = $orig_k; # optimize whitespace $k =~ s/^\s+//; $k =~ s/\s+$//; $k =~ s/\s+/ /g; $z = &$lengthsub($k); return ($k) if ($z <= $linelength); # also handles the trivial case # this needs to be reply-aware, so we put @'s at the beginning of # the second half too (and also Ds for DMs) $r .= $1 while ($k =~ s/^(\@[^\s]+\s)\s*// || $k =~ s/^(D\s+[^\s]+\s)\s*//); # we have r/a, so while $k = "$r$k"; my $i = $linelength; $i-- while(($z = &$lengthsub($q = substr($k, 0, $i))) > $linelength); $m = substr($k, $i); # if we just wanted split-on-byte, return now (mode = 1) if ($mode) { # optimize again in case we split on whitespace $q =~ s/\s+$//; $m =~ s/^\s+//; return ($q, "$r$m"); } # else try to do word boundary and cut even more if (!$autosplit) { # use old mechanism first: drop trailing non-alfanum ($q =~ s/([^a-zA-Z0-9]+)$//) && ($m = "$1$m"); # optimize again in case we split on whitespace $q =~ s/\s+$//; return (&cosplit($orig_k, 1, $lengthsub)) if (!length($q) && !$mode); # it totally failed. fall back on charsplit. if (&$lengthsub($q) < $linelength) { $m =~ s/^\s+//; return($q, "$r$m") } } ($q =~ s/\s+([^\s]+)$//) && ($m = "$1$m"); return (&cosplit($orig_k, 1, $lengthsub)) if (!length($q) && !$mode); # it totally failed. fall back on charsplit. return ($q, "$r$m"); } ### OAuth methods, including our own homegrown SHA-1 and HMAC ### ### no Digest:* required! ### ### these routines are not byte-safe and need a use bytes; before you call ### # this is a modified, deciphered and deobfuscated version of the famous Perl # one-liner SHA-1 written by John Allen. hope he doesn't mind. sub sha1 { my $string = shift; print $stdout "string length: @{[ length($string) ]}\n" if ($showwork); my $constant = "D9T4C`>_-JXF8NMS^\$#)4=L/2X?!:\@GF9;MGKH8\\;O-S*8L'6"; my @A = unpack('N*', unpack('u', $constant)); my @K = splice(@A, 5, 4); my $M = sub { # 64-bit warning my $x; my $m; ($x = pop @_) - ($m=4294967296) * int($x / $m); }; my $L = sub { # 64-bit warning my $n = pop @_; my $x; ((($x = pop @_) << $n) | ((2 ** $n - 1) & ($x >> 32 - $n))) & 4294967295; }; my $l = ''; my $r; my $a; my $b; my $c; my $d; my $e; my $us; my @nuA; my $p = 0; $string = unpack("H*", $string); do { my $i; $us = substr($string, 0, 128); $string = substr($string, 128); $l += $r = (length($us) / 2); print $stdout "pad length: $r\n" if ($showwork); ($r++, $us .= "80") if ($r < 64 && !$p++); my @W = unpack('N16', pack("H*", $us) . "\000" x 7); $W[15] = $l * 8 if ($r < 57); foreach $i (16 .. 79) { push(@W, &$L($W[$i - 3] ^ $W[$i - 8] ^ $W[$i - 14] ^ $W[$i - 16], 1)); } ($a, $b, $c, $d, $e) = @A; foreach $i (0 .. 79) { my $qq = ($i < 20) ? ($b & ($c ^ $d) ^ $d) : ($i < 40) ? ($b ^ $c ^ $d) : ($i < 60) ? (($b | $c) & $d | $b & $c) : ($b ^ $c ^ $d); $t = &$M($qq + $e + $W[$i] + $K[$i / 20] + &$L($a, 5)); $e = $d; $d = $c; $c = &$L($b, 30); $b = $a; $a = $t; } @nuA = ($a, $b, $c, $d, $e); print $stdout "$a $b $c $d $e\n" if ($showwork); $i = 0; @A = map({ &$M($_ + $nuA[$i++]); } @A); } while ($r > 56); my $x = sprintf('%.8x' x 5, @A); @A = unpack("C*", pack("H*", $x)); return($x, @A); } # heavily modified from MIME::Base64 sub simple_encode_base64 { my $result = ''; my $input = shift; pos($input) = 0; while($input =~ /(.{1,45})/gs) { $result .= substr(pack("u", $1), 1); chop($result); } $result =~ tr|` -_|AA-Za-z0-9+/|; my $padding = (3 - length($input) % 3) % 3; $result =~ s/.{$padding}$/("=" x $padding)/e if ($padding); return $result; } # from RFC 2104/RFC 2202 sub hmac_sha1 { my $message = shift; my @key = (@_); my $opad; my $ipad; my $i; my @j; # sha1 blocksize is 512, so key should be 64 bytes print $stdout " KEY HASH \n" if ($showwork); ($i, @key) = &sha1(pack("C*", @key)) while (scalar(@key) > 64); push(@key, 0) while(scalar(@key) < 64); $opad = pack("C*", map { ($_ ^ 92) } @key); $ipad = pack("C*", map { ($_ ^ 54) } @key); print $stdout " MESSAGE HASH \n" if ($showwork); ($i, @j) = &sha1($ipad . $message); print $stdout " FINAL HASH \n" if ($showwork); $i = pack("C*", @j); # output hash is 160 bits ($i, @j) = &sha1($opad . $i); $i = &simple_encode_base64(pack("C20", @j)); return $i; } # simple encoder for OAuth modified URL encoding (used for lots of things, # actually) # this is NOT UTF-8 safe sub url_oauth_sub { my $x = shift; $x =~ s/([^-0-9a-zA-Z._~])/"%".uc(unpack("H*",$1))/eg; return $x; } # default method of getting password: ask for it. only relevant for Basic Auth, # which is no longer the default. sub defaultgetpassword { # original idea by @jcscoobyrs, heavily modified my $k; my $l; my $pass; $l = "no termios; password WILL"; if ($termios) { $termios->getattr(fileno($stdin)); $k = $termios->getlflag; $termios->setlflag($k ^ &POSIX::ECHO); $termios->setattr(fileno($stdin)); $l = "password WILL NOT"; } print $stdout "enter password for $whoami ($l be echoed): "; chomp($pass = <$stdin>); if ($termios) { print $stdout "\n"; $termios->setlflag($k); $termios->setattr(fileno($stdin)); } return $pass; } # this returns an immutable token corresponding to the current authenticated # session. in the case of Basic Auth, it is simply the user:password pair. # it does not handle OAuth -- that is run by a separate wizard. # the function then returns (token,secret) which for Basic Auth is token,undef. # most of the time we will be using tokens in a keyfile, however, so this # function runs in that case as a stub. sub authtoken { my @foo; my $pass; my $sig; my $return; my $tries = ($hold > 3) ? $hold : 3; # give up on token if we don't get one return (undef,undef) if ($anonymous); return ($tokenkey,$tokensecret) if (length($tokenkey) && length($tokensecret)); @foo = split(/:/, $user, 2); $whoami = $foo[0]; die("choose -user=username[:password], or -anonymous.\n") if (!length($whoami) || $whoami eq '1'); $pass = length($foo[1]) ? $foo[1] : &$getpassword; die("a password must be specified.\n") if (!length($pass)); return ($whoami, $pass); } # this is a sucky nonce generator. I was looking for an awesome nonce # generator, and then I realized it would only be used once, so who cares? # *rimshot* sub generate_nonce { unpack("H9000", pack("u", rand($$).$$.time())); } # this signs a request with the token and token secret. the result is undef if # Basic Auth. payload should already be URL encoded and *sorted*. # this is typically called by stringify_args to get authentication information. sub signrequest { # this horrible kludge is needed to account for both 5.005, or for # 5.6+ installs with no stdlibs and just a bare Perl, both of which # we support. I hope Larry Wall will forgive me for messing with # compiler internals next time I see him at church. BEGIN { $^H |= 0x00000008 unless ($] < 5.006); } my $resource = shift; my $payload = shift; # when we sign the initial request for an token, we obviously # don't have one yet, so mytoken/mytokensecret can be null. my $nonce = &generate_nonce; my @keybytes; my $sig_base; my $timestamp = time(); return undef if ($authtype eq 'basic'); # stub for oAuth 2.0 return undef if (!length($oauthkey) || !length($oauthsecret)); (@keybytes) = map { ord($_) } split(//, $oauthsecret.'&'.$mytokensecret); if (ref($resource) eq 'ARRAY' || length($payload)) { # split into _a and _b payloads lexically my $payload_a = ''; my $payload_b = ''; my $payload_c = ''; # this is for a special case my $w; my $aorb = 0; my $verifier = ''; my $method = "GET"; my $url; if (length($payload)) { $method = "POST"; # this is a bit problematic since it won't be # sorted. we'll deal with this as we need to. if (ref($resource) eq 'ARRAY') { $url = &url_oauth_sub($resource->[0]); $payload .= "&" . $resource->[1]; } else { $url = &url_oauth_sub($resource); } } elsif (ref($resource) eq 'ARRAY') { $url = &url_oauth_sub($resource->[0]); $payload = $resource->[1]; } else { $url = &url_oauth_sub($resource); } # this is pretty simplistic but it's really all we need. # the exception is oauth_verifier: that has to be wormed # into the middle, and we assume it's just that. if ($payload !~ /^oauth_verifier/) { foreach $w (split(/\&/, $payload)) { $aorb = 1 if ($w =~ /^[p-z]/ || $w =~ /^o[b-z]/); $w = &url_oauth_sub("${w}&"); if ($aorb) { $payload_b .= $w; } else { $payload_a .= $w; } } } else { $payload_c = &url_oauth_sub($payload) . "%26"; $payload_a = $payload_b = ''; $payload =~ s/^oauth_verifier=//; $verifier = ' oauth_verifier=\\"' . $payload . '\\",'; } $payload_b =~ s/%26$//; $sig_base = $method . "&" . $url . "&" . (length($payload_a) ? $payload_a : ''). "oauth_consumer_key%3D" . $oauthkey . "%26" . "oauth_nonce%3D" . $nonce . "%26" . "oauth_signature_method%3DHMAC-SHA1%26" . "oauth_timestamp%3D" . $timestamp . "%26" . (length($mytoken) ? ("oauth_token%3D" . $mytoken . "%26") : '') . $payload_c . "oauth_version%3D1.0" . (length($payload_b) ? ("%26" . $payload_b) : ''); } else { $sig_base = "GET&" . &url_oauth_sub($resource) . "&" . "oauth_consumer_key%3D" . $oauthkey . "%26" . "oauth_nonce%3D" . $nonce . "%26" . "oauth_signature_method%3DHMAC-SHA1%26" . "oauth_timestamp%3D" . $timestamp . "%26" . (length($mytoken) ? ("oauth_token%3D" . $mytoken . "%26") : '') . $payload_c . # could be part of it "oauth_version%3D1.0" ; } print $stdout "token-secret: $mytokensecret\nconsumer-secret: $oauthsecret\nsig-base: $sig_base\n" if ($superverbose); return ($timestamp, $nonce, &url_oauth_sub(&hmac_sha1($sig_base, @keybytes)), $verifier); } # this takes a token request and "tries hard" to get it. sub tryhardfortoken { my $url = shift; my $body = shift; my $tries = shift; my $rawtoken; $tries ||= 3; while($tries) { my $i; $rawtoken = &backticks($baseagent, '/dev/null', undef, $url, $body, 0, @wend); print $stdout ("token = $rawtoken\n") if ($superverbose); my (@keyarr) = split(/\&/, $rawtoken); my $got_token = ''; my $got_secret = ''; foreach $i (@keyarr) { my $key; my $value; ($key, $value) = split(/\=/, $i); $got_token = $value if ($key eq 'oauth_token'); $got_secret = $value if ($key eq 'oauth_token_secret'); } if (length($got_token) && length($got_secret)) { print $stdout " SUCCEEDED!\n"; return ($got_token, $got_secret); } print $stdout "."; $tries--; } print $stdout " FAILED!: \"$rawtoken\"\n"; die("unable to fetch token. here are some possible reasons:\n". " - root certificates are not updated (see documentation)\n". " - you entered your authentication information wrong\n". " - your computer's clock is not set correctly\n" . " - Twitter farted\n" . "fix these possible problems, or try again later.\n"); exit; } ttytter-2.1.0+1/test.pl0000644000175000017500000000374611463341711013740 0ustar thijsthijs#! /usr/bin/perl -w # Give an argument to use stdin, stdout instead of console # If argument starts with /dev, use it as console # If argument is '--no-print', do not print the result. require 5.006; BEGIN{ $ENV{PERL_RL} = 'TTYtter' }; # Do not test TR::Gnu ! use Term::ReadLine; use Carp; $SIG{__WARN__} = sub { warn Carp::longmess(@_) }; my $ev; if ($ENV{$ev = 'AUTOMATED_TESTING'} or $ENV{$ev = 'PERL_MM_NONINTERACTIVE'}) { print "1..0 # skip: \$ENV{$ev} is TRUE\n"; exit; } if (!@ARGV) { $term = new Term::ReadLine 'Simple Perl calc'; } elsif (@ARGV == 2) { open(IN,"<$ARGV[0]"); open(OUT,">$ARGV[1]"); $term = new Term::ReadLine 'Simple Perl calc', \*IN, \*OUT; } elsif ($ARGV[0] =~ m|^/dev|) { open(IN,"<$ARGV[0]"); open(OUT,">$ARGV[0]"); $term = new Term::ReadLine 'Simple Perl calc', \*IN, \*OUT; } else { $term = new Term::ReadLine 'Simple Perl calc', \*STDIN, \*STDOUT; $no_print = $ARGV[0] eq '--no-print'; } $prompt = "Enter arithmetic or Perl expression: "; if ((my $l = $ENV{PERL_RL_TEST_PROMPT_MINLEN} || 0) > length $prompt) { $prompt =~ s/(?=:)/ ' ' x ($l - length $prompt)/e; } $OUT = $term->OUT || STDOUT; $IN = $term->IN || STDIN; binmode($OUT, ":utf8"); binmode($IN, ":utf8"); our $dont_use_counter = 0; our $ansi = 1; $term->hook_no_counter; $term->hook_use_ansi; %features = %{ $term->Features }; if (%features) { @f = %features; print $OUT "Features present: @f\n"; #$term->ornaments(1) if $features{ornaments}; } else { print $OUT "No additional features present.\n"; } print $OUT "\n Flipping rl_default_selected each line.\n"; print $OUT <readline($prompt, "exit")) ) { $res = eval($_); warn $@ if $@; print $OUT $res, "\n" unless $@ or $no_print; $term->addhistory($_) if /\S/ and !$features{autohistory}; $readline::rl_default_selected = !$readline::rl_default_selected; } ttytter-2.1.0+1/ReadLine/0000755000175000017500000000000012021223227014065 5ustar thijsthijsttytter-2.1.0+1/ReadLine/TTYtter.pm0000644000175000017500000001062512021202731016003 0ustar thijsthijspackage Term::ReadLine::TTYtter; use Carp; @ISA = qw(Term::ReadLine::Stub Term::ReadLine::TTYtter::Compa Term::ReadLine::TTYtter::AU); $VERSION = $VERSION = 1.4; sub readline { shift; &readline_ttytter::readline(@_); } *addhistory = \&AddHistory; *settophistory = \&SetTopHistory; $readline_ttytter::minlength = 1; # To pacify -w $readline_ttytter::rl_readline_name = undef; # To pacify -w $readline_ttytter::rl_basic_word_break_characters = undef; # To pacify -w sub new { if (defined $term) { warn "Cannot create second readline interface, falling back to dumb.\n"; return Term::ReadLine::Stub::new(@_); } shift; # Package if (@_) { if ($term) { warn "Ignoring name of second readline interface.\n" if defined $term; shift; } else { $readline_ttytter::rl_readline_name = shift; # Name } } if (!@_) { if (!defined $term) { ($IN,$OUT) = Term::ReadLine->findConsole(); # Old Term::ReadLine did not have a workaround for a bug in Win devdriver $IN = 'CONIN$' if $^O eq 'MSWin32' and "\U$IN" eq 'CON'; open IN, # A workaround for another bug in Win device driver (($IN eq 'CONIN$' and $^O eq 'MSWin32') ? "+< $IN" : "< $IN") or croak "Cannot open $IN for read"; open(OUT,">$OUT") || croak "Cannot open $OUT for write"; $readline_ttytter::term_IN = \*IN; $readline_ttytter::term_OUT = \*OUT; } } else { if (defined $term and ($term->IN ne $_[0] or $term->OUT ne $_[1]) ) { croak "Request for a second readline interface with different terminal"; } $readline_ttytter::term_IN = shift; $readline_ttytter::term_OUT = shift; } eval {require Term::ReadLine::readline_ttytter}; die $@ if $@; # The following is here since it is mostly used for perl input: # $readline_ttytter::rl_basic_word_break_characters .= '-:+/*,[])}'; $term = bless [$readline_ttytter::term_IN,$readline_ttytter::term_OUT]; unless ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/) { local $Term::ReadLine::termcap_nowarn = 1; # With newer Perls local $SIG{__WARN__} = sub {}; # With older Perls $term->ornaments(1); } return $term; } sub newTTY { my ($self, $in, $out) = @_; $readline_ttytter::term_IN = $self->[0] = $in; $readline_ttytter::term_OUT = $self->[1] = $out; my $sel = select($out); $| = 1; # for DB::OUT select($sel); } sub ReadLine {'Term::ReadLine::TTYtter'} sub Version { $Term::ReadLine::TTYtter::VERSION } sub MinLine { my $old = $readline_ttytter::minlength; $readline_ttytter::minlength = $_[1] if @_ == 2; return $old; } sub SetHistory { shift; @readline_ttytter::rl_History = @_; $readline_ttytter::rl_HistoryIndex = @readline_ttytter::rl_History; } sub GetHistory { @readline_ttytter::rl_History; } sub AddHistory { shift; push @readline_ttytter::rl_History, @_; $readline_ttytter::rl_HistoryIndex = @readline_ttytter::rl_History + @_; } sub SetTopHistory { shift; pop @readline_ttytter::rl_History; push @readline_ttytter::rl_History, @_; $readline_ttytter::rl_HistoryIndex = @readline_ttytter::rl_History; } %features = (appname => 1, minline => 1, autohistory => 1, getHistory => 1, setHistory => 1, addHistory => 1, preput => 1, attribs => 1, 'newTTY' => 1, canRemoveReadline => 1, canRepaint => 1, canSetTopHistory => 1, canBackgroundSignal => 1, canHookUseAnsi => 1, canHookNoCounter => 1, tkRunning => Term::ReadLine::Stub->Features->{'tkRunning'}, ornaments => Term::ReadLine::Stub->Features->{'ornaments'}, ); sub Features { \%features; } # my %attribs; tie %attribs, 'Term::ReadLine::TTYtter::Tie' or die ; sub Attribs { \%attribs; } sub DESTROY {} package Term::ReadLine::TTYtter::AU; sub AUTOLOAD { { $AUTOLOAD =~ s/.*:://; } # preserve match data my $name = "readline_ttytter::rl_$AUTOLOAD"; die "Cannot do `$AUTOLOAD' in Term::ReadLine::TTYtter" unless exists $readline_ttytter::{"rl_$AUTOLOAD"}; *$AUTOLOAD = sub { shift; &$name }; goto &$AUTOLOAD; } package Term::ReadLine::TTYtter::Tie; sub TIEHASH { bless {} } sub DESTROY {} sub STORE { my ($self, $name) = (shift, shift); $ {'readline_ttytter::rl_' . $name} = shift; } sub FETCH { my ($self, $name) = (shift, shift); $ {'readline_ttytter::rl_' . $name}; } package Term::ReadLine::TTYtter::Compa; sub get_c { my $self = shift; getc($self->[0]); } sub get_line { my $self = shift; my $fh = $self->[0]; scalar <$fh>; } 1; ttytter-2.1.0+1/ReadLine/readline_ttytter.pm0000644000175000017500000041635012021223227020016 0ustar thijsthijsrequire 5.006; ## ## Term::Readline::Perl -> Term::Readline::TTYtter (Cameron Kaiser) ## it's much better. ## Same license as T::RL::Perl. But awesome. ## Fixes: UTF-8 safe now (crosses fingers) on Mac OS X, Ubuntu and more ## Upgrades: Repaintable readline/removeable readline, signal chaining, ## character count. ## ############################################################################ ## ## Perl Readline -- The Quick Help ## (see the manual for complete info) ## ## Once this package is included (require'd), you can then call ## $text = &readline'readline($input); ## to get lines of input from the user. ## ## Normally, it reads ~/.inputrc when loaded... to suppress this, set ## $readline'rl_NoInitFromFile = 1; ## before requiring the package. ## ## Call rl_bind to add your own key bindings, as in ## &readline'rl_bind('C-L', 'possible-completions'); ## ## Call rl_set to set mode variables yourself, as in ## &readline'rl_set('TcshCompleteMode', 'On'); ## ## To change the input mode (emacs or vi) use ~/.inputrc or call ## &readline::rl_set('EditingMode', 'vi'); ## or &readline::rl_set('EditingMode', 'emacs'); ## ## Call rl_basic_commands to set your own command completion, as in ## &readline'rl_basic_commands('print', 'list', 'quit', 'run', 'status'); ## ## # Wrap the code below (initially Perl4, now partially Perl4) into a fake # Perl5 pseudo-module; mismatch of package and file name is intentional # to make is harder to abuse this (very fragile) code... package readline_ttytter; my $autoload_broken = 1; # currently: defined does not work with a-l my $useioctl = 1; my $usestty = 1; my $max_include_depth = 10; # follow $include's in init files this deep my $background_control = 0; # see hook_background_control eval 'use POSIX; $readline_ttytter::SIGUSR1 = POSIX::SIGUSR1'; $SIGUSR1 ||= 30; BEGIN { # Some old systems have ioctl "unsupported" *ioctl = sub ($$$) { eval { ioctl $_[0], $_[1], $_[2] } }; } ## ## BLURB: ## A pretty full-function package similar to GNU's readline. ## Includes support for EUC-encoded Japanese text. ## ## Written by Jeffrey Friedl, Omron Corporation (jfriedl@omron.co.jp) ## ## Comments, corrections welcome. ## ## Thanks to the people at FSF for readline (and the code I referenced ## while writing this), and for Roland Schemers whose line_edit.pl I used ## as an early basis for this. ## $VERSION = $VERSION = '1.4'; ## - Changes from Slaven Rezic (slaven@rezic.de): ## * reverted the usage of $ENV{EDITOR} to set startup mode ## only ~/.inputrc or an explicit call to rl_set should ## be used to set startup mode ## # 1011109.011 - Changes from Russ Southern (russ@dvns.com): ## * Added $rl_vi_replace_default_on_insert # 1000510.010 - Changes from Joe Petolino (petolino@eng.sun.com), requested ## by Ilya: ## ## * Make it compatible with perl 5.003. ## * Rename getc() to getc_with_pending(). ## * Change unshift(@Pending) to push(@Pending). ## ## 991109.009 - Changes from Joe Petolino (petolino@eng.sun.com): ## Added vi mode. Also added a way to set the keymap default ## action for multi-character keymaps, so that a 2-character ## sequence (e.g. A) can be treated as two one-character ## commands (, then A) if the sequence is not explicitly ## mapped. ## ## Changed subs: ## ## * preinit(): Initialize new keymaps and other data structures. ## Use $ENV{EDITOR} to set startup mode. ## ## * init(): Sets the global *KeyMap, since &F_ReReadInitFile ## may have changed the key map. ## ## * InitKeymap(): $KeyMap{default} is now optional - don't ## set it if $_[1] eq ''; ## ## * actually_do_binding(): Set $KeyMap{default} for '\*' key; ## warning if double-defined. ## ## * rl_bind(): Implement \* to set the keymap default. Also fix ## some existing regex bugs that I happened to notice. ## ## * readline(): No longer takes input from $pending before ## calling &$rl_getc(); instead, it calls getc_with_pending(), ## which takes input from the new array @Pending ## before calling &$rl_getc(). Sets the global ## *KeyMap after do_command(), since do_command() ## may change the keymap now. Does some cursor ## manipulation after do_command() when at the end ## of the line in vi command mode, to match the ## behavior of vi. ## ## * rl_getc(): Added a my declaration for $key, which was ## apparently omitted by the author. rl_getc() is ## no longer called directly; instead, getc_with_pending() calls ## it only after exhausting any requeued characters ## in @Pending. @Pending is used to implement the ## vi '.' command, as well as the emacs DoSearch ## functionality. ## ## * do_command(): Now defaults the command to 'F_Ding' if ## $KeyMap{default} is undefined. This is part ## of the new \* feature. ## ## * savestate()/getstate(): Now use an anonymous array instead ## of packing the fields into a string. ## ## * F_AcceptLine(): Code moved to new sub add_line_to_history(), ## so that it may be called by F_SaveLine() ## as well as by F_AcceptLine(). ## ## * F_QuotedInsert(): Calls getc_with_pending() instead of &$rl_getc(). ## ## * F_UnixWordRubout(): Fixed bug: changed 'my' declaration of ## global $rl_basic_word_break_characters to 'local'. ## ## * DoSearch(): Calls getc_with_pending() instead of &$rl_getc(). Ungets ## character onto @Pending instead of $pending. ## ## * F_EmacsEditingMode(): Resets global $Vi_mode; ## ## * F_ToggleEditingMode(): Deleted. We use F_ViInput() and ## F_EmacsEditingMode() instead. ## ## * F_PrefixMeta(): Calls getc_with_pending() instead of &$rl_getc(). ## ## * F_DigitArgument(): Calls getc_with_pending() instead of &$rl_getc(). ## ## * F_Ding(): Returns undef, for testing by vi commands. ## ## * F_Complete(): Returns true if a completion was done, false ## otherwise, so vi completion routines can test it. ## ## * complete_internal(): Returns true if a completion was done, ## false otherwise, so vi completion routines can ## test it. Does a little cursor massaging in vi ## mode, to match the behavior of ksh vi mode. ## ## Disclaimer: the original code dates from the perl 4 days, and ## isn't very pretty by today's standards (for example, ## extensive use of typeglobs and localized globals). In the ## interests of not breaking anything, I've tried to preserve ## the old code as much as possible, and I've avoided making ## major stylistic changes. Since I'm not a regular emacs user, ## I haven't done much testing to see that all the emacs-mode ## features still work. ## ## 940817.008 - Added $var_CompleteAddsuffix. ## Now recognizes window-change signals (at least on BSD). ## Various typos and bug fixes. ## Changes from Chris Arthur (csa@halcyon.com): ## Added a few new keybindings. ## Various typos and bug fixes. ## Support for use from a dumb terminal. ## Pretty-printing of filename-completion matches. ## ## 930306.007 - Added rl_start_default_at_beginning. ## Added optional message arg to &redisplay. ## Added explicit numeric argument var to functions that use it. ## Redid many commands to simplify. ## Added TransposeChars, UpcaseWord, CapitalizeWord, DownCaseWord. ## Redid key binding specs to better match GNU.. added ## undocumented "new-style" bindings.... can now bind ## arrow keys and other arbitrairly long key sequences. ## Added if/else/then to .inputrc. ## ## 930305.006 - optional "default" added (from mmuegel@cssmp.corp.mot.com). ## ## 930211.005 - fixed strange problem with eval while keybinding ## ## ## Ilya: ## ## Added support for ReadKey, ## ## Added customization variable $minlength ## to denote minimal lenth of a string to be put into history buffer. ## ## Added support for a bug in debugger: preinit cannot be a subroutine ?!!! ## (See immendiately below) ## ## Added support for WINCH hooks. The subroutine references should be put into ## @winchhooks. ## ## Added F_ToggleInsertMode, F_HistorySearchBackward, ## F_HistorySearchForward, PC keyboard bindings. ## 0.93: Updates to Operate, couple of keybindings added. ## $rl_completer_terminator_character, $rl_correct_sw added. ## Reload-init-file moved to C-x C-x. ## C-x ? and C-x * list/insert possible completions. $rl_getc = \&rl_getc; &preinit; &init; # # # # use strict 'vars'; # # # # # Separation into my and vars needs some thought... # # # # use vars qw(@KeyMap %KeyMap $rl_screen_width $rl_start_default_at_beginning # # # # $rl_completion_function $rl_basic_word_break_characters # # # # $rl_completer_word_break_characters $rl_special_prefixes # # # # $rl_readline_name @rl_History $rl_MaxHistorySize # # # # $rl_max_numeric_arg $rl_OperateCount # # # # $KillBuffer $dumb_term $stdin_not_tty $InsertMode # # # # $rl_NoInitFromFile); # # # # my ($InputLocMsg, $term_OUT, $term_IN); # # # # my ($winsz_t, $TIOCGWINSZ, $winsz, $rl_margin, $hooj, $force_redraw); # # # # my ($hook, %var_HorizontalScrollMode, %var_EditingMode, %var_OutputMeta); # # # # my ($var_HorizontalScrollMode, $var_EditingMode, $var_OutputMeta); # # # # my (%var_ConvertMeta, $var_ConvertMeta, %var_MarkModifiedLines, $var_MarkModifiedLines); # # # # my ($term_readkey, $inDOS); # # # # my (%var_PreferVisibleBell, $var_PreferVisibleBell); # # # # my (%var_TcshCompleteMode, $var_TcshCompleteMode); # # # # my (%var_CompleteAddsuffix, $var_CompleteAddsuffix); # # # # my ($minlength, @winchhooks); # # # # my ($BRKINT, $ECHO, $FIONREAD, $ICANON, $ICRNL, $IGNBRK, $IGNCR, $INLCR, # # # # $ISIG, $ISTRIP, $NCCS, $OPOST, $RAW, $TCGETS, $TCOON, $TCSETS, $TCXONC, # # # # $TERMIOS_CFLAG, $TERMIOS_IFLAG, $TERMIOS_LFLAG, $TERMIOS_NORMAL_IOFF, # # # # $TERMIOS_NORMAL_ION, $TERMIOS_NORMAL_LOFF, $TERMIOS_NORMAL_LON, # # # # $TERMIOS_NORMAL_OOFF, $TERMIOS_NORMAL_OON, $TERMIOS_OFLAG, # # # # $TERMIOS_READLINE_IOFF, $TERMIOS_READLINE_ION, $TERMIOS_READLINE_LOFF, # # # # $TERMIOS_READLINE_LON, $TERMIOS_READLINE_OOFF, $TERMIOS_READLINE_OON, # # # # $TERMIOS_VMIN, $TERMIOS_VTIME, $TIOCGETP, $TIOCGWINSZ, $TIOCSETP, # # # # $fion, $fionread_t, $mode, $sgttyb_t, # # # # $termios, $termios_t, $winsz, $winsz_t); # # # # my ($line, $initialized, $term_readkey); # # # # # Global variables added for vi mode (I'm leaving them all commented # # # # # out, like the declarations above, until SelfLoader issues # # # # # are resolved). # # # # # True when we're in one of the vi modes. # # # # my $Vi_mode; # # # # # Array refs: saves keystrokes for '.' command. Undefined when we're # # # # # not doing a '.'-able command. # # # # my $Dot_buf; # Working buffer # # # # my $Last_vi_command; # Gets $Dot_buf when a command is parsed # # # # # These hold state for vi 'u' and 'U'. # # # # my($Dot_state, $Vi_undo_state, $Vi_undo_all_state); # # # # # Refs to hashes used for cursor movement # # # # my($Vi_delete_patterns, $Vi_move_patterns, # # # # $Vi_change_patterns, $Vi_yank_patterns); # # # # # Array ref: holds parameters from the last [fFtT] command, for ';' # # # # # and ','. # # # # my $Last_findchar; # # # # # Globals for history search commands (/, ?, n, N) # # # # my $Vi_search_re; # Regular expression (compiled by qr{}) # # # # my $Vi_search_reverse; # True for '?' search, false for '/' ## ## What's Cool ## ---------------------------------------------------------------------- ## * hey, it's in perl. ## * Pretty full GNU readline like library... ## * support for ~/.inputrc ## * horizontal scrolling ## * command/file completion ## * rebinding ## * history (with search) ## * undo ## * numeric prefixes ## * supports multi-byte characters (at least for the Japanese I use). ## * Has a tcsh-like completion-function mode. ## call &readline'rl_set('tcsh-complete-mode', 'On') to turn on. ## ## ## What's not Cool ## ---------------------------------------------------------------------- ## Can you say HUGE? ## I can't spell, so comments riddled with misspellings. ## Written by someone that has never really used readline. ## History mechanism is slightly different than GNU... may get fixed ## someday, but I like it as it is now... ## Killbuffer not a ring.. just one level. ## Obviously not well tested yet. ## Written by someone that doesn't have a bell on his terminal, so ## proper readline use of the bell may not be here. ## ## ## Functions beginning with F_ are functions that are mapped to keys. ## Variables and functions beginning rl_ may be accessed/set/called/read ## from outside the package. Other things are internal. ## ## Some notable internal-only variables of global proportions: ## $prompt -- line prompt (passed from user) ## $line -- the line being input ## $D -- ``Dot'' -- index into $line of the cursor's location. ## $InsertMode -- usually true. False means overwrite mode. ## $InputLocMsg -- string for error messages, such as "[~/.inputrc line 2]" ## *emacs_keymap -- keymap for emacs-mode bindings: ## @emacs_keymap - bindings indexed by ASCII ordinal ## $emacs_keymap{'name'} = "emacs_keymap" ## $emacs_keymap{'default'} = "SelfInsert" (default binding) ## *vi_keymap -- keymap for vi input mode bindings ## *vicmd_keymap -- keymap for vi command mode bindings ## *vipos_keymap -- keymap for vi positioning command bindings ## *visearch_keymap -- keymap for vi search pattern input mode bindings ## *KeyMap -- current keymap in effect. ## $LastCommandKilledText -- needed so that subsequent kills accumulate ## $lastcommand -- name of command previously run ## $lastredisplay -- text placed upon screen during previous &redisplay ## $si -- ``screen index''; index into $line of leftmost char &redisplay'ed ## $force_redraw -- if set to true, causes &redisplay to be verbose. ## $AcceptLine -- when set, its value is returned from &readline. ## $ReturnEOF -- unless this also set, in which case undef is returned. ## @Pending -- characters to be used as input. ## @undo -- array holding all states of current line, for undoing. ## $KillBuffer -- top of kill ring (well, don't have a kill ring yet) ## @tcsh_complete_selections -- for tcsh mode, possible selections ## ## Some internal variables modified by &rl_set (see comment at &rl_set for ## info about how these set'able variables work) ## $var_EditingMode -- a keymap typeglob like *emacs_keymap or *vi_keymap ## $var_TcshCompleteMode -- if true, the completion function works like ## in tcsh. That is, the first time you try to complete something, ## the common prefix is completed for you. Subsequent completion tries ## (without other commands in between) cycles the command line through ## the various possibilities. If/when you get the one you want, just ## continue typing. ## Other $var_ things not supported yet. ## ## Some variables used internally, but may be accessed from outside... ## $VERSION -- just for good looks. ## $rl_readline_name = name of program -- for .initrc if/endif stuff. ## $rl_NoInitFromFile -- if defined when package is require'd, ~/.inputrc ## will not be read. ## @rl_History -- array of previous lines input ## $rl_HistoryIndex -- history pointer (for moving about history array) ## $rl_completion_function -- see "How Command Completion Works" (way) below. ## $rl_basic_word_break_characters -- string of characters that can cause ## a word break for forward-word, etc. ## $rl_start_default_at_beginning -- ## Normally, the user's cursor starts at the end of any default text ## passed to readline. If this variable is true, it starts at the ## beginning. ## $rl_completer_word_break_characters -- ## like $rl_basic_word_break_characters (and in fact defaults to it), ## but for the completion function. ## $rl_completer_terminator_character -- what to insert to separate ## a completed token from the rest. Reset at beginning of ## completion to ' ' so completion function can change it. ## $rl_special_prefixes -- characters that are part of this string as well ## as of $rl_completer_word_break_characters cause a word break for the ## completer function, but remain part of the word. An example: consider ## when the input might be perl code, and one wants to be able to ## complete on variable and function names, yet still have the '$', ## '&', '@',etc. part of the $text to be completed. Then set this var ## to '&@$%' and make sure each of these characters is in ## $rl_completer_word_break_characters as well.... ## $rl_MaxHistorySize -- maximum size that the history array may grow. ## $rl_screen_width -- width readline thinks it can use on the screen. ## $rl_correct_sw -- is substructed from the real width of the terminal ## $rl_margin -- scroll by moving to within this far from a margin. ## $rl_CLEAR -- what to output to clear the screen. ## $rl_max_numeric_arg -- maximum numeric arg allowed. ## $rl_vi_replace_default_on_insert ## Normally, the text you enter is added to any default text passed to ## readline. If this variable is true, default text will start out ## highlighted (if supported by your terminal) and text entered while the ## default is highlighted (during the _first_ insert mode only) will ## replace the entire default line. Once you have left insert mode (hit ## escape), everything works as normal. ## - This is similar to many GUI controls' behavior, which select the ## default text so that new text replaces the old. ## - Use with $rl_start_default_at_beginning for normal-looking behavior ## (though it works just fine without it). ## Notes/Bugs: ## - Control characters (like C-w) do not actually terminate this replace ## mode, for the same reason it does not work in emacs mode. ## - Spine-crawlingly scary subroutine redefinitions ## $rl_mark - start of the region ## $line_rl_mark - the line on which $rl_mark is active ## $_rl_japanese_mb - For character movement suppose Japanese (which?!) ## multi-byte encoding. (How to make a sane default?) ## sub get_window_size { return unless (-t $term_OUT); my $sig = shift; my ($num_cols,$num_rows); local($., $@, $!, $^E, $?); if (defined $term_readkey) { ($num_cols,$num_rows) = Term::ReadKey::GetTerminalSize($term_OUT); $rl_screen_width = $num_cols - $rl_correct_sw if defined($num_cols) && $num_cols; } elsif (defined $TIOCGWINSZ and &ioctl($term_IN,$TIOCGWINSZ,$winsz)) { ($num_rows,$num_cols) = unpack($winsz_t,$winsz); $rl_screen_width = $num_cols - $rl_correct_sw if defined($num_cols) && $num_cols; } $rl_margin = int($rl_screen_width/3); if (defined $sig) { $force_redraw = 1; &redisplay(); } for $hook (@winchhooks) { eval {&$hook()}; warn $@ if $@ and $^W; } local $^W = 0; # WINCH may be illegal... $SIG{'WINCH'} = "readline_ttytter::get_window_size"; } # Fix: case-sensitivity of inputrc on/off keywords in # `set' commands. readline lib doesn't care about case. # changed case of keys 'On' and 'Off' to 'on' and 'off' # &rl_set changed so that it converts the value to # lower case before hash lookup. sub preinit { ## Set up the input and output handles $term_IN = \*STDIN unless defined $term_IN; $term_OUT = \*STDOUT unless defined $term_OUT; ## not yet supported... always on. $var_HorizontalScrollMode = 1; $var_HorizontalScrollMode{'On'} = 1; $var_HorizontalScrollMode{'Off'} = 0; $var_EditingMode{'emacs'} = *emacs_keymap; $var_EditingMode{'vi'} = *vi_keymap; $var_EditingMode{'vicmd'} = *vicmd_keymap; $var_EditingMode{'vipos'} = *vipos_keymap; $var_EditingMode{'visearch'} = *visearch_keymap; ## this is an addition. Very nice. $var_TcshCompleteMode = 0; $var_TcshCompleteMode{'On'} = 1; $var_TcshCompleteMode{'Off'} = 0; $var_CompleteAddsuffix = 1; $var_CompleteAddsuffix{'On'} = 1; $var_CompleteAddsuffix{'Off'} = 0; $var_DeleteSelection = $var_DeleteSelection{'On'} = 1; $var_DeleteSelection{'Off'} = 0; *rl_delete_selection = \$var_DeleteSelection; # Alias ## not yet supported... always on for ('InputMeta', 'OutputMeta') { ${"var_$_"} = 1; ${"var_$_"}{'Off'} = 0; ${"var_$_"}{'On'} = 1; } ## not yet supported... always off for ('ConvertMeta', 'MetaFlag', 'MarkModifiedLines', 'PreferVisibleBell', 'BlinkMatchingParen', 'VisibleStats', 'ShowAllIfAmbiguous', 'PrintCompletionsHorizontally', 'MarkDirectories', 'ExpandTilde', 'EnableKeypad', 'DisableCompletion', 'CompletionIgnoreCase') { ${"var_$_"} = 0; ${"var_$_"}{'Off'} = 0; ${"var_$_"}{'On'} = 1; } # To conform to interface $minlength = 1 unless defined $minlength; # WINCH hooks @winchhooks = (); $inDOS = $^O eq 'os2' || defined $ENV{OS2_SHELL} unless defined $inDOS; eval { require Term::ReadKey; $term_readkey++; } unless defined $ENV{PERL_RL_USE_TRK} and not $ENV{PERL_RL_USE_TRK}; unless ($term_readkey) { eval {require "ioctl.pl"}; ## try to get, don't die if not found. eval {require "sys/ioctl.ph"}; ## try to get, don't die if not found. eval {require "sgtty.ph"}; ## try to get, don't die if not found. if ($inDOS and !defined $TIOCGWINSZ) { $TIOCGWINSZ=0; $TIOCGETP=1; $TIOCSETP=2; $sgttyb_t="I5 C8"; $winsz_t=""; $RAW=0xf002; $ECHO=0x0008; } $TIOCGETP = &TIOCGETP if defined(&TIOCGETP); $TIOCSETP = &TIOCSETP if defined(&TIOCSETP); $TIOCGWINSZ = &TIOCGWINSZ if defined(&TIOCGWINSZ); $FIONREAD = &FIONREAD if defined(&FIONREAD); $TCGETS = &TCGETS if defined(&TCGETS); $TCSETS = &TCSETS if defined(&TCSETS); $TCXONC = &TCXONC if defined(&TCXONC); $TIOCGETP = 0x40067408 if !defined($TIOCGETP); $TIOCSETP = 0x80067409 if !defined($TIOCSETP); $TIOCGWINSZ = 0x40087468 if !defined($TIOCGWINSZ); $FIONREAD = 0x4004667f if !defined($FIONREAD); $TCGETS = 0x40245408 if !defined($TCGETS); $TCSETS = 0x80245409 if !defined($TCSETS); $TCXONC = 0x20005406 if !defined($TCXONC); ## TTY modes $ECHO = &ECHO if defined(&ECHO); $RAW = &RAW if defined(&RAW); $RAW = 040 if !defined($RAW); $ECHO = 010 if !defined($ECHO); #$CBREAK = 002 if !defined($CBREAK); $mode = $RAW; ## could choose CBREAK for testing.... $IGNBRK = 1 if !defined($IGNBRK); $BRKINT = 2 if !defined($BRKINT); $ISTRIP = 040 if !defined($ISTRIP); $INLCR = 0100 if !defined($INLCR); $IGNCR = 0200 if !defined($IGNCR); $ICRNL = 0400 if !defined($ICRNL); $OPOST = 1 if !defined($OPOST); $ISIG = 1 if !defined($ISIG); $ICANON = 2 if !defined($ICANON); $TCOON = 1 if !defined($TCOON); $TERMIOS_READLINE_ION = $BRKINT; $TERMIOS_READLINE_IOFF = $IGNBRK | $ISTRIP | $INLCR | $IGNCR | $ICRNL; $TERMIOS_READLINE_OON = 0; $TERMIOS_READLINE_OOFF = $OPOST; $TERMIOS_READLINE_LON = 0; $TERMIOS_READLINE_LOFF = $ISIG | $ICANON | $ECHO; $TERMIOS_NORMAL_ION = $BRKINT; $TERMIOS_NORMAL_IOFF = $IGNBRK; $TERMIOS_NORMAL_OON = $OPOST; $TERMIOS_NORMAL_OOFF = 0; $TERMIOS_NORMAL_LON = $ISIG | $ICANON | $ECHO; $TERMIOS_NORMAL_LOFF = 0; #$sgttyb_t = 'C4 S'; #$winsz_t = "S S S S"; # rows,cols, xpixel, ypixel $sgttyb_t = 'C4 S' if !defined($sgttyb_t); $winsz_t = "S S S S" if !defined($winsz_t); # rows,cols, xpixel, ypixel $winsz = pack($winsz_t,0,0,0,0); $fionread_t = "L"; $fion = pack($fionread_t, 0); $NCCS = 17; $termios_t = "LLLLc" . ("c" x $NCCS); # true for SunOS 4.1.3, at least... $termios = ''; ## just to shut up "perl -w". $termios = pack($termios, 0); # who cares, just make it long enough $TERMIOS_IFLAG = 0; $TERMIOS_OFLAG = 1; $TERMIOS_CFLAG = 2; $TERMIOS_LFLAG = 3; $TERMIOS_VMIN = 5 + 4; $TERMIOS_VTIME = 5 + 5; } $rl_delete_selection = 1; $rl_correct_sw = ($inDOS ? 1 : 0); $rl_scroll_nextline = 0 unless defined $rl_scroll_nextline; $rl_last_pos_can_backspace = ($inDOS ? 0 : 1) # Can backspace when the unless defined $rl_last_pos_can_backspace; # whole line is filled? $rl_start_default_at_beginning = 0; $rl_vi_replace_default_on_insert = 0; $rl_screen_width = 79; ## default $rl_completion_function = "rl_filename_list" unless defined($rl_completion_function); $rl_basic_word_break_characters = "\\\t\n' \"`\@\$><=;|&{("; $rl_completer_word_break_characters = $rl_basic_word_break_characters; $rl_special_prefixes = ''; ($rl_readline_name = $0) =~ s#.*[/\\]## if !defined($rl_readline_name); @rl_History=() if !(@rl_History); $rl_MaxHistorySize = 100 if !defined($rl_MaxHistorySize); $rl_max_numeric_arg = 200 if !defined($rl_max_numeric_arg); $rl_OperateCount = 0 if !defined($rl_OperateCount); $rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; @$rl_term_set or $rl_term_set = ["","","",""]; $InsertMode=1; $KillBuffer=''; $line=''; $D = 0; $InputLocMsg = ' [initialization]'; &InitKeymap(*emacs_keymap, 'SelfInsert', 'emacs_keymap', ($inDOS ? () : ('C-@', 'SetMark') ), 'C-a', 'BeginningOfLine', 'C-b', 'BackwardChar', 'C-c', 'Interrupt', 'C-d', 'DeleteChar', 'C-e', 'EndOfLine', 'C-f', 'ForwardChar', 'C-g', 'Abort', 'M-C-g', 'Abort', 'C-h', 'BackwardDeleteChar', "TAB" , 'Complete', "C-j" , 'AcceptLine', 'C-k', 'KillLine', 'C-l', 'ClearScreen', "C-m" , 'AcceptLine', 'C-n', 'NextHistory', 'C-o', 'OperateAndGetNext', 'C-p', 'PreviousHistory', 'C-q', 'QuotedInsert', #'C-r', 'ReverseSearchHistory', 'C-r', 'Repaint', 'C-s', 'ForwardSearchHistory', 'C-t', 'TransposeChars', 'C-u', 'UnixLineDiscard', ##'C-v', 'QuotedInsert', 'C-v', 'HistorySearchForward', 'C-w', 'UnixWordRubout', qq/"\cX\cX"/, 'ExchangePointAndMark', qq/"\cX\cR"/, 'ReReadInitFile', qq/"\cX?"/, 'PossibleCompletions', qq/"\cX*"/, 'InsertPossibleCompletions', qq/"\cX\cU"/, 'Undo', qq/"\cXu"/, 'Undo', qq/"\cX\cW"/, 'KillRegion', qq/"\cXw"/, 'CopyRegionAsKill', qq/"\cX\ec\\*"/, 'DoControlVersion', qq/"\cX\ec\0"/, 'SetMark', qq/"\cX\ec\@"/, 'SetMark', qq/"\cX\ec "/, 'SetMark', qq/"\cX\em\\*"/, 'DoMetaVersion', qq/"\cX\@c\\*"/, 'DoControlVersion', qq/"\cX\@c\0"/, 'SetMark', qq/"\cX\@c\@"/, 'SetMark', qq/"\cX\@c "/, 'SetMark', qq/"\cX\@m\\*"/, 'DoMetaVersion', 'C-y', 'Yank', 'C-z', 'Suspend', 'C-\\', 'Ding', 'C-^', 'Ding', 'C-_', 'Undo', 'DEL', ($inDOS ? 'BackwardKillWord' : # + 'BackwardDeleteChar' ), 'M-<', 'BeginningOfHistory', 'M->', 'EndOfHistory', 'M-DEL', 'BackwardKillWord', 'M-C-h', 'BackwardKillWord', 'M-C-j', 'ViInput', 'M-C-v', 'QuotedInsert', 'M-b', 'BackwardWord', 'M-c', 'CapitalizeWord', 'M-d', 'KillWord', 'M-f', 'ForwardWord', 'M-h', 'PrintHistory', 'M-l', 'DownCaseWord', 'M-r', 'RevertLine', 'M-t', 'TransposeWords', 'M-u', 'UpcaseWord', 'M-v', 'HistorySearchBackward', 'M-y', 'YankPop', "M-?", 'PossibleCompletions', "M-TAB", 'TabInsert', 'M-#', 'SaveLine', qq/"\e[A"/, 'previous-history', qq/"\e[B"/, 'next-history', qq/"\e[C"/, 'forward-char', qq/"\e[D"/, 'backward-char', qq/"\eOA"/, 'previous-history', qq/"\eOB"/, 'next-history', qq/"\eOC"/, 'forward-char', qq/"\eOD"/, 'backward-char', qq/"\eOy"/, 'HistorySearchBackward', # vt: PageUp qq/"\eOs"/, 'HistorySearchForward', # vt: PageDown qq/"\e[[A"/, 'previous-history', qq/"\e[[B"/, 'next-history', qq/"\e[[C"/, 'forward-char', qq/"\e[[D"/, 'backward-char', qq/"\e[2~"/, 'ToggleInsertMode', # X: # Mods: 1 + bitmask: 1 Shift, 2 Alt, 4 Control, 8 (sometimes) Meta qq/"\e[2;2~"/, 'YankClipboard', # + qq/"\e[3;2~"/, 'KillRegionClipboard', # + #qq/"\0\16"/, 'Undo', # + qq/"\eO5D"/, 'BackwardWord', # + qq/"\eO5C"/, 'ForwardWord', # + qq/"\e[5D"/, 'BackwardWord', # + qq/"\e[5C"/, 'ForwardWord', # + qq/"\eO5F"/, 'KillLine', # + qq/"\e[5F"/, 'KillLine', # + qq/"\e[4;5~"/, 'KillLine', # + qq/"\eO5s"/, 'EndOfHistory', # + qq/"\e[6;5~"/, 'EndOfHistory', # + qq/"\e[5H"/, 'BackwardKillLine', # + qq/"\eO5H"/, 'BackwardKillLine', # + qq/"\e[1;5~"/, 'BackwardKillLine', # + qq/"\eO5y"/, 'BeginningOfHistory', # + qq/"\e[5;5y"/, 'BeginningOfHistory', # + qq/"\e[2;5~"/, 'CopyRegionAsKillClipboard', # + qq/"\e[3;5~"/, 'KillWord', # + # XTerm mouse editing (f202/f203 not in mainstream yet): # Paste may be: move f200 STRING f201 # or f202 move f200 STRING f201 f203; # and Cut may be f202 move delete f203 qq/"\e[200~"/, 'BeginPasteGroup', # Pre-paste qq/"\e[201~"/, 'EndPasteGroup', # Post-paste qq/"\e[202~"/, 'BeginEditGroup', # Pre-edit qq/"\e[203~"/, 'EndEditGroup', # Post-edit # OSX xterm: # OSX xterm: home \eOH end \eOF delete \e[3~ help \e[28~ f13 \e[25~ # gray- \eOm gray+ \eOk gray-enter \eOM gray* \eOj gray/ \eOo gray= \eO # grayClear \e\e. qq/"\eOH"/, 'BeginningOfLine', # home qq/"\eOF"/, 'EndOfLine', # end # HP xterm #qq/"\e[A"/, 'PreviousHistory', # up arrow #qq/"\e[B"/, 'NextHistory', # down arrow #qq/"\e[C"/, 'ForwardChar', # right arrow #qq/"\e[D"/, 'BackwardChar', # left arrow qq/"\e[H"/, 'BeginningOfLine', # home #'C-k', 'KillLine', # clear display qq/"\e[5~"/, 'HistorySearchBackward', # prev qq/"\e[6~"/, 'HistorySearchForward', # next qq/"\e[\0"/, 'BeginningOfLine', # home # These contradict: ($^O =~ /^hp\W?ux/i ? ( qq/"\e[1~"/, 'HistorySearchForward', # find qq/"\e[3~"/, 'ToggleInsertMode', # insert char qq/"\e[4~"/, 'ToggleInsertMode', # select ) : ( # "Normal" xterm qq/"\e[1~"/, 'BeginningOfLine', # home qq/"\e[3~"/, 'DeleteChar', # delete qq/"\e[4~"/, 'EndOfLine', # end )), # hpterm (($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ? ( qq/"\eA"/, 'PreviousHistory', # up arrow qq/"\eB"/, 'NextHistory', # down arrow qq/"\eC"/, 'ForwardChar', # right arrow qq/"\eD"/, 'BackwardChar', # left arrow qq/"\eS"/, 'BeginningOfHistory', # shift up arrow qq/"\eT"/, 'EndOfHistory', # shift down arrow qq/"\e&r1R"/, 'EndOfLine', # shift right arrow qq/"\e&r1L"/, 'BeginningOfLine', # shift left arrow qq/"\eJ"/, 'ClearScreen', # clear display qq/"\eM"/, 'UnixLineDiscard', # delete line qq/"\eK"/, 'KillLine', # clear line qq/"\eG\eK"/, 'BackwardKillLine', # shift clear line qq/"\eP"/, 'DeleteChar', # delete char qq/"\eL"/, 'Yank', # insert line qq/"\eQ"/, 'ToggleInsertMode', # insert char qq/"\eV"/, 'HistorySearchBackward',# prev qq/"\eU"/, 'HistorySearchForward',# next qq/"\eh"/, 'BeginningOfLine', # home qq/"\eF"/, 'EndOfLine', # shift home qq/"\ei"/, 'Suspend', # shift tab ) : () ), ($inDOS ? ( qq/"\0\2"/, 'SetMark', # 2: + qq/"\0\3"/, 'SetMark', # 3: +<@> qq/"\0\4"/, 'YankClipboard', # 4: + qq/"\0\5"/, 'KillRegionClipboard', # 5: + qq/"\0\16"/, 'Undo', # 14: + # qq/"\0\23"/, 'RevertLine', # 19: + # qq/"\0\24"/, 'TransposeWords', # 20: + # qq/"\0\25"/, 'YankPop', # 21: + # qq/"\0\26"/, 'UpcaseWord', # 22: + # qq/"\0\31"/, 'ReverseSearchHistory', # 25: +

# qq/"\0\40"/, 'KillWord', # 32: + # qq/"\0\41"/, 'ForwardWord', # 33: + # qq/"\0\46"/, 'DownCaseWord', # 38: + #qq/"\0\51"/, 'TildeExpand', # 41: +<\'> # qq/"\0\56"/, 'CapitalizeWord', # 46: + # qq/"\0\60"/, 'BackwardWord', # 48: + # qq/"\0\61"/, 'ForwardSearchHistory', # 49: + #qq/"\0\64"/, 'YankLastArg', # 52: +<.> qq/"\0\65"/, 'PossibleCompletions', # 53: + qq/"\0\107"/, 'BeginningOfLine', # 71: qq/"\0\110"/, 'previous-history', # 72: qq/"\0\111"/, 'HistorySearchBackward', # 73: qq/"\0\113"/, 'backward-char', # 75: qq/"\0\115"/, 'forward-char', # 77: qq/"\0\117"/, 'EndOfLine', # 79: qq/"\0\120"/, 'next-history', # 80: qq/"\0\121"/, 'HistorySearchForward', # 81: qq/"\0\122"/, 'ToggleInsertMode', # 82: qq/"\0\123"/, 'DeleteChar', # 83: qq/"\0\163"/, 'BackwardWord', # 115: + qq/"\0\164"/, 'ForwardWord', # 116: + qq/"\0\165"/, 'KillLine', # 117: + qq/"\0\166"/, 'EndOfHistory', # 118: + qq/"\0\167"/, 'BackwardKillLine', # 119: + qq/"\0\204"/, 'BeginningOfHistory', # 132: + qq/"\0\x92"/, 'CopyRegionAsKillClipboard', # 146: + qq/"\0\223"/, 'KillWord', # 147: + qq/"\0#"/, 'PrintHistory', # Alt-H ) : ( 'C-@', 'Ding') ) ); *KeyMap = *emacs_keymap; my @add_bindings = (); foreach ('-', '0' .. '9') { push(@add_bindings, "M-$_", 'DigitArgument'); } foreach ("A" .. "Z") { next if # defined($KeyMap[27]) && defined (%{"$KeyMap{name}_27"}) && defined $ {"$KeyMap{name}_27"}[ord $_]; push(@add_bindings, "M-$_", 'DoLowercaseVersion'); } if ($inDOS) { # Default translation of Alt-char $ {"$KeyMap{name}_0"}{'Esc'} = *{"$KeyMap{name}_27"}; $ {"$KeyMap{name}_0"}{'default'} = 'F_DoEscVersion'; } &rl_bind(@add_bindings); # Vi input mode. &InitKeymap(*vi_keymap, 'SelfInsert', 'vi_keymap', "\e", 'ViEndInsert', 'C-c', 'Interrupt', 'C-h', 'BackwardDeleteChar', 'C-w', 'UnixWordRubout', 'C-u', 'UnixLineDiscard', 'C-v', 'QuotedInsert', 'DEL', 'BackwardDeleteChar', "\n", 'ViAcceptInsert', "\r", 'ViAcceptInsert', ); # Vi command mode. &InitKeymap(*vicmd_keymap, 'Ding', 'vicmd_keymap', 'C-c', 'Interrupt', 'C-e', 'EmacsEditingMode', 'C-h', 'ViMoveCursor', 'C-l', 'ClearScreen', "\n", 'ViAcceptLine', "\r", 'ViAcceptLine', ' ', 'ViMoveCursor', '#', 'SaveLine', '$', 'ViMoveCursor', '%', 'ViMoveCursor', '*', 'ViInsertPossibleCompletions', '+', 'NextHistory', ',', 'ViMoveCursor', '-', 'PreviousHistory', '.', 'ViRepeatLastCommand', '/', 'ViSearch', '0', 'ViMoveCursor', '1', 'ViDigit', '2', 'ViDigit', '3', 'ViDigit', '4', 'ViDigit', '5', 'ViDigit', '6', 'ViDigit', '7', 'ViDigit', '8', 'ViDigit', '9', 'ViDigit', ';', 'ViMoveCursor', '=', 'ViPossibleCompletions', '?', 'ViSearch', 'A', 'ViAppendLine', 'B', 'ViMoveCursor', 'C', 'ViChangeLine', 'D', 'ViDeleteLine', 'E', 'ViMoveCursor', 'F', 'ViMoveCursor', 'G', 'ViHistoryLine', 'H', 'PrintHistory', 'I', 'ViBeginInput', 'N', 'ViRepeatSearch', 'P', 'ViPutBefore', 'R', 'ViReplaceMode', 'S', 'ViChangeEntireLine', 'T', 'ViMoveCursor', 'U', 'ViUndoAll', 'W', 'ViMoveCursor', 'X', 'ViBackwardDeleteChar', 'Y', 'ViYankLine', '\\', 'ViComplete', '^', 'ViMoveCursor', 'a', 'ViAppend', 'b', 'ViMoveCursor', 'c', 'ViChange', 'd', 'ViDelete', 'e', 'ViMoveCursor', 'f', 'ViMoveCursorFind', 'h', 'ViMoveCursor', 'i', 'ViInput', 'j', 'NextHistory', 'k', 'PreviousHistory', 'l', 'ViMoveCursor', 'n', 'ViRepeatSearch', 'p', 'ViPut', 'r', 'ViReplaceChar', 's', 'ViChangeChar', 't', 'ViMoveCursorTo', 'u', 'ViUndo', 'w', 'ViMoveCursor', 'x', 'ViDeleteChar', 'y', 'ViYank', '|', 'ViMoveCursor', '~', 'ViToggleCase', (($inDOS and (not $ENV{'TERM'} or $ENV{'TERM'} !~ /^(vt|xterm)/i)) ? ( qq/"\0\110"/, 'PreviousHistory', # 72: qq/"\0\120"/, 'NextHistory', # 80: qq/"\0\113"/, 'BackwardChar', # 75: qq/"\0\115"/, 'ForwardChar', # 77: "\e", 'ViCommandMode', ) : (('M-C-j','EmacsEditingMode'), # Conflicts with \e otherwise (($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ? ( qq/"\eA"/, 'PreviousHistory', # up arrow qq/"\eB"/, 'NextHistory', # down arrow qq/"\eC"/, 'ForwardChar', # right arrow qq/"\eD"/, 'BackwardChar', # left arrow qq/"\e\\*"/, 'ViAfterEsc', ) : # Default ( qq/"\e[A"/, 'PreviousHistory', # up arrow qq/"\e[B"/, 'NextHistory', # down arrow qq/"\e[C"/, 'ForwardChar', # right arrow qq/"\e[D"/, 'BackwardChar', # left arrow qq/"\e\\*"/, 'ViAfterEsc', qq/"\e[\\*"/, 'ViAfterEsc', ) ))), ); # Vi positioning commands (suffixed to vi commands like 'd'). &InitKeymap(*vipos_keymap, 'ViNonPosition', 'vipos_keymap', '^', 'ViFirstWord', '0', 'BeginningOfLine', '1', 'ViDigit', '2', 'ViDigit', '3', 'ViDigit', '4', 'ViDigit', '5', 'ViDigit', '6', 'ViDigit', '7', 'ViDigit', '8', 'ViDigit', '9', 'ViDigit', '$', 'EndOfLine', 'h', 'BackwardChar', 'l', 'ForwardChar', ' ', 'ForwardChar', 'C-h', 'BackwardChar', 'f', 'ViForwardFindChar', 'F', 'ViBackwardFindChar', 't', 'ViForwardToChar', 'T', 'ViBackwardToChar', ';', 'ViRepeatFindChar', ',', 'ViInverseRepeatFindChar', '%', 'ViFindMatchingParens', '|', 'ViMoveToColumn', # Arrow keys ($inDOS ? ( qq/"\0\115"/, 'ForwardChar', # 77: qq/"\0\113"/, 'BackwardChar', # 75: "\e", 'ViPositionEsc', ) : ($ENV{'TERM'} and $ENV{'TERM'} eq 'hpterm') ? ( qq/"\eC"/, 'ForwardChar', # right arrow qq/"\eD"/, 'BackwardChar', # left arrow qq/"\e\\*"/, 'ViPositionEsc', ) : # Default ( qq/"\e[C"/, 'ForwardChar', # right arrow qq/"\e[D"/, 'BackwardChar', # left arrow qq/"\e\\*"/, 'ViPositionEsc', qq/"\e[\\*"/, 'ViPositionEsc', ) ), ); # Vi search string input mode for '/' and '?'. &InitKeymap(*visearch_keymap, 'SelfInsert', 'visearch_keymap', "\e", 'Ding', 'C-c', 'Interrupt', 'C-h', 'ViSearchBackwardDeleteChar', 'C-w', 'UnixWordRubout', 'C-u', 'UnixLineDiscard', 'C-v', 'QuotedInsert', 'DEL', 'ViSearchBackwardDeleteChar', "\n", 'ViEndSearch', "\r", 'ViEndSearch', ); # These constant hashes hold the arguments to &forward_scan() or # &backward_scan() for vi positioning commands, which all # behave a little differently for delete, move, change, and yank. # # Note: I originally coded these as qr{}, but changed them to q{} for # compatibility with older perls at the expense of some performance. # # Note: Some of the more obscure key combinations behave slightly # differently in different vi implementation. This module matches # the behavior of /usr/ucb/vi, which is different from the # behavior of vim, nvi, and the ksh command line. One example is # the command '2de', when applied to the string ('^' represents the # cursor, not a character of the string): # # ^5.6 7...88888888 # # With /usr/ucb/vi and with this module, the result is # # ^...88888888 # # but with the other three vi implementations, the result is # # ^ 7...88888888 $Vi_delete_patterns = { ord('w') => q{(?:\w+|[^\w\s]+|)\s*}, ord('W') => q{\S*\s*}, ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+}, ord('B') => q{\S+\s*|^\s+}, ord('e') => q{.\s*\w+|.\s*[^\w\s]+|.\s*$}, ord('E') => q{.\s*\S+|.\s*$}, }; $Vi_move_patterns = { ord('w') => q{(?:\w+|[^\w\s]+|)\s*}, ord('W') => q{\S*\s*}, ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+}, ord('B') => q{\S+\s*|^\s+}, ord('e') => q{.\s*\w*(?=\w)|.\s*[^\w\s]*(?=[^\w\s])|.?\s*(?=\s$)}, ord('E') => q{.\s*\S*(?=\S)|.?\s*(?=\s$)}, }; $Vi_change_patterns = { ord('w') => q{\w+|[^\w\s]+|\s}, ord('W') => q{\S+|\s}, ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+}, ord('B') => q{\S+\s*|^\s+}, ord('e') => q{.\s*\w+|.\s*[^\w\s]+|.\s*$}, ord('E') => q{.\s*\S+|.\s*$}, }; $Vi_yank_patterns = { ord('w') => q{(?:\w+|[^\w\s]+|)\s*}, ord('W') => q{\S*\s*}, ord('b') => q{\w+\s*|[^\w\s]+\s*|^\s+}, ord('B') => q{\S+\s*|^\s+}, ord('e') => q{.\s*\w*(?=\w)|.\s*[^\w\s]*(?=[^\w\s])|.?\s*(?=\s$)}, ord('E') => q{.\s*\S*(?=\S)|.?\s*(?=\s$)}, }; my $default_mode = 'emacs'; *KeyMap = $var_EditingMode = $var_EditingMode{$default_mode}; ## my $name; ## for $name ( keys %{'readline::'} ) { ## # Create aliases accessible via tied interface ## *{"rl_$1"} = \$ {"var_$1"} if $name =~ /$var_(.*)/; ## } 1; # Returning a glob causes a bug in db5.001m } sub init { if ($ENV{'TERM'} and ($ENV{'TERM'} eq 'emacs' || $ENV{'TERM'} eq 'dumb')) { $dumb_term = 1; } elsif (! -c $term_IN && $term_IN eq \*STDIN) { # Believe if it is given $stdin_not_tty = 1; } else { &get_window_size; &F_ReReadInitFile if !defined($rl_NoInitFromFile); $InputLocMsg = ''; *KeyMap = $var_EditingMode; } $initialized = 1; } ## ## InitKeymap(*keymap, 'default', 'name', bindings.....) ## sub InitKeymap { local(*KeyMap) = shift(@_); my $default = shift(@_); my $name = $KeyMap{'name'} = shift(@_); # 'default' is now optional - if '', &do_command() defaults it to # 'F_Ding'. Meta-maps now don't set a default - this lets # us detect multiple '\*' default declarations. JP if ($default ne '') { my $func = $KeyMap{'default'} = "F_$default"; ### Temporarily disabled die qq/Bad default function [$func] for keymap "$name"/ if !$autoload_broken and !defined(&$func); } &rl_bind if @_ > 0; ## The rest of @_ gets passed silently. } ## ## Accepts an array as pairs ($keyspec, $function, [$keyspec, $function]...). ## and maps the associated bindings to the current KeyMap. ## ## keyspec should be the name of key sequence in one of two forms: ## ## Old (GNU readline documented) form: ## M-x to indicate Meta-x ## C-x to indicate Ctrl-x ## M-C-x to indicate Meta-Ctrl-x ## x simple char x ## where 'x' above can be a single character, or the special: ## special means ## -------- ----- ## space space ( ) ## spc space ( ) ## tab tab (\t) ## del delete (0x7f) ## rubout delete (0x7f) ## newline newline (\n) ## lfd newline (\n) ## ret return (\r) ## return return (\r) ## escape escape (\e) ## esc escape (\e) ## ## New form: ## "chars" (note the required double-quotes) ## where each char in the list represents a character in the sequence, except ## for the special sequences: ## \\C-x Ctrl-x ## \\M-x Meta-x ## \\M-C-x Meta-Ctrl-x ## \\e escape. ## \\x x (if not one of the above) ## ## ## FUNCTION should be in the form 'BeginningOfLine' or 'beginning-of-line'. ## It is an error for the function to not be known.... ## ## As an example, the following lines in .inputrc will bind one's xterm ## arrow keys: ## "\e[[A": previous-history ## "\e[[B": next-history ## "\e[[C": forward-char ## "\e[[D": backward-char ## sub filler_Pending ($) { my $keys = shift; sub { my $c = shift; push @Pending, map chr, @$keys; return if not @$keys or $c == 1 or not defined(my $in = &getc_with_pending); # provide the numeric argument local(*KeyMap) = $var_EditingMode; $doingNumArg = 1; # Allow NumArg inside NumArg &do_command(*KeyMap, $c, ord $in); return; } } sub _unescape ($) { my($key, @keys) = shift; ## New-style bindings are enclosed in double-quotes. ## Characters are taken verbatim except the special cases: ## \C-x Control x (for any x) ## \M-x Meta x (for any x) ## \e Escape ## \* Set the keymap default (JP: added this) ## (must be the last character of the sequence) ## ## \x x (unless it fits the above pattern) ## ## Look for special case of "\C-\M-x", which should be treated ## like "\M-\C-x". while (length($key) > 0) { # JP: fixed regex bugs below: changed all 's#' to 's#^' if ($key =~ s#^\\C-\\M-(.)##) { push(@keys, ord("\e"), &ctrl(ord($1))); } elsif ($key =~ s#^\\(M-|e)##) { push(@keys, ord("\e")); } elsif ($key =~ s#^\\C-(.)##) { push(@keys, &ctrl(ord($1))); } elsif ($key =~ s#^\\x([0-9a-fA-F]{2})##) { push(@keys, eval('0x'.$1)); } elsif ($key =~ s#^\\([0-7]{3})##) { push(@keys, eval('0'.$1)); } elsif ($key =~ s#^\\\*$##) { # JP: added push(@keys, 'default'); } elsif ($key =~ s#^\\([afnrtv])##) { push(@keys, ord(eval(qq("\\$1")))); } elsif ($key =~ s#^\\d##) { push(@keys, 4); # C-d } elsif ($key =~ s#^\\b##) { push(@keys, 0x7f); # Backspace } elsif ($key =~ s#^\\(.)##) { push(@keys, ord($1)); } else { push(@keys, ord($key)); substr($key,0,1) = ''; } } @keys } sub RL_func ($) { my $name_or_macro = shift; if ($name_or_macro =~ /^"((?:\\.|[^\\\"])*)"|^'((?:\\.|[^\\\'])*)'/s) { filler_Pending [_unescape "$+"]; } else { "F_$name_or_macro"; } } sub actually_do_binding { ## ## actually_do_binding($function1, \@sequence1, ...) ## ## Actually inserts the binding for @sequence to $function into the ## current map. @sequence is an array of character ordinals. ## ## If @sequence is more than one element long, all but the last will ## cause meta maps to be created. ## ## $Function will have an implicit "F_" prepended to it. ## while (@_) { my $func = shift; my ($key, @keys) = @{shift()}; $key += 0; local(*KeyMap) = *KeyMap; my $map; while (@keys) { if (defined($KeyMap[$key]) && ($KeyMap[$key] ne 'F_PrefixMeta')) { warn "Warning$InputLocMsg: ". "Re-binding char #$key from [$KeyMap[$key]] to meta for [@keys] => $func.\n" if $^W; } $KeyMap[$key] = 'F_PrefixMeta'; $map = "$KeyMap{'name'}_$key"; InitKeymap(*$map, '', $map) if !(%$map); *KeyMap = *$map; $key = shift @keys; #&actually_do_binding($func, \@keys); } my $name = $KeyMap{'name'}; if ($key eq 'default') { # JP: added warn "Warning$InputLocMsg: ". " changing default action to $func in $name key map\n" if $^W && defined $KeyMap{'default'}; $KeyMap{'default'} = RL_func $func; } else { if (defined($KeyMap[$key]) && $KeyMap[$key] eq 'F_PrefixMeta' && $func ne 'PrefixMeta') { warn "Warning$InputLocMsg: ". " Re-binding char #$key to non-meta ($func) in $name key map\n" if $^W; } $KeyMap[$key] = RL_func $func; } } } # These functions are custom for TTYtter and are used by the client. sub rl_removereadline # call to remove the readline from the screen temporarily. { my $out = "\r" . (" " x ($rl_screen_width || 79)) . "\r"; print $term_OUT $out; } sub rl_redisplay # call to force a repaint. won't respond if we're not displaying a prompt. { return unless ($in_readline); $force_redraw = 1; redisplay(); } sub rl_hook_background_control # call to bind background control to a pid (USR1 = halt output, USR2 = ok). { $background_control = $main::child; } sub rl_hook_use_ansi # call to synchronize internal use of ANSI with the user's { $use_ansi = $main::ansi; } sub rl_hook_no_counter # call to synchronize user preferences for counter (and prompts) { $dont_use_counter = $main::dont_use_counter; } sub rl_hook_no_tco # call to synchronize using t.co length computations. this is a little # different. by default we do NOT so this can be used for other applications. # if TTYtter has notco NOT set, then we turn on t.co length computations when # this is called (and vice versa). if this is never called, t.co length # computation is never used (so don't call it if this is not a Twitter client). # we then use TTYtter's internal tco logic so upgrading that doesn't need # a T:RL:T update too. { $do_tco = ($main::notco) ? 0 : $main::tco_sub; } sub rl_bind { my (@keys, $key, $func, $ord, @arr); while (defined($key = shift(@_)) && defined($func = shift(@_))) { ## ## Change the function name from something like ## backward-kill-line ## to ## BackwardKillLine ## if not already there. ## unless ($func =~ /^[\"\']/) { $func = "\u$func"; $func =~ s/-(.)/\u$1/g; # Temporary disabled if (!$autoload_broken and !defined($ {'readline::'}{"F_$func"})) { warn "Warning$InputLocMsg: bad bind function [$func]\n" if $^W; next; } } ## print "sequence [$key] func [$func]\n"; ##DEBUG @keys = (); ## See if it's a new-style binding. if ($key =~ m/"((?:\\.|[^\\])*)"/s) { @keys = _unescape "$1"; } else { ## ol-dstyle binding... only one key (or Meta+key) my ($isctrl, $orig) = (0, $key); $isctrl = $key =~ s/\b(C|Control|CTRL)-//i; push(@keys, ord("\e")) if $key =~ s/\b(M|Meta)-//i; ## is meta? ## Isolate key part. This matches GNU's implementation. ## If the key is '-', be careful not to delete it! $key =~ s/.*-(.)/$1/; if ($key =~ /^(space|spc)$/i) { $key = ' '; } elsif ($key =~ /^(rubout|del)$/i) { $key = "\x7f"; } elsif ($key =~ /^tab$/i) { $key = "\t"; } elsif ($key =~ /^(return|ret)$/i) { $key = "\r"; } elsif ($key =~ /^(newline|lfd)$/i) { $key = "\n"; } elsif ($key =~ /^(escape|esc)$/i) { $key = "\e"; } elsif (length($key) > 1) { warn "Warning$InputLocMsg: strange binding [$orig]\n" if $^W; } $key = ord($key); $key = &ctrl($key) if $isctrl; push(@keys, $key); } # ## Now do the mapping of the sequence represented in @keys # # print "&actually_do_binding($func, @keys)\n"; ##DEBUG push @arr, $func, [@keys]; #&actually_do_binding($func, \@keys); } &actually_do_binding(@arr); } sub read_an_init_file { my $file = shift; my $include_depth = shift; local *RC; $file =~ s/^~([\\\/])/$ENV{HOME}$1/ if not -f $file and exists $ENV{HOME}; return unless open RC, "< $file"; my (@action) = ('exec'); ## exec, skip, ignore (until appropriate endif) my (@level) = (); ## if, else local $/ = "\n"; while () { s/^\s+//; next if m/^\s*(#|$)/; $InputLocMsg = " [$file line $.]"; if (/^\$if\s+(.*)/) { my($test) = $1; push(@level, 'if'); if ($action[$#action] ne 'exec') { ## We're supposed to be skipping or ignoring this level, ## so for subsequent levels we really ignore completely. push(@action, 'ignore'); } else { ## We're executing this IF... do the test. ## The test is either "term=xxxx", or just a string that ## we compare to $rl_readline_name; if ($test =~ /term=([a-z0-9]+)/) { $test = ($ENV{'TERM'} && $1 eq $ENV{'TERM'}); } else { $test = $test =~ /^(perl|$rl_readline_name)\s*$/i; } push(@action, $test ? 'exec' : 'skip'); } next; } elsif (/^\$endif\b/) { die qq/\rWarning$InputLocMsg: unmatched endif\n/ if @level == 0; pop(@level); pop(@action); next; } elsif (/^\$else\b/) { die qq/\rWarning$InputLocMsg: unmatched else\n/ if @level == 0 || $level[$#level] ne 'if'; $level[$#level] = 'else'; ## an IF turns into an ELSE if ($action[$#action] eq 'skip') { $action[$#action] = 'exec'; ## if were SKIPing, now EXEC } else { $action[$#action] = 'ignore'; ## otherwise, just IGNORE. } next; } elsif (/^\$include\s+(\S+)/) { if ($include_depth > $max_include_depth) { warn "Deep recursion in \$include directives in $file.\n"; } else { read_an_init_file($1, $include_depth + 1); } } elsif ($action[$#action] ne 'exec') { ## skipping this one.... # readline permits trailing comments in inputrc # this seems to solve the warnings caused by trailing comments in the # default /etc/inputrc on Mandrake Linux boxes. } elsif (m/\s*set\s+(\S+)\s+(\S*)/) { # Allow trailing comment &rl_set($1, $2, $file); } elsif (m/^\s*(\S+):\s+("(?:\\.|[^\\\"])*"|'(\\.|[^\\\'])*')/) { # Allow trailing comment &rl_bind($1, $2); } elsif (m/^\s*(\S+):\s+(\S+)/) { # Allow trailing comment &rl_bind($1, $2); } else { chomp; warn "\rWarning$InputLocMsg: Bad line [$_]\n" if $^W; } } close(RC); } sub F_ReReadInitFile { my ($file) = $ENV{'TRP_INPUTRC'}; $file = $ENV{'INPUTRC'} unless defined $file; unless (defined $file) { return unless defined $ENV{'HOME'}; $file = "$ENV{'HOME'}/.inputrc"; } read_an_init_file($file, 0); } sub get_ornaments_selected { return if @$rl_term_set >= 6; local $^W=0; my $Orig = $Term::ReadLine::TTYtter::term->ornaments(); eval { # Term::ReadLine does not expose its $terminal, so make another require Term::Cap; my $terminal = Tgetent Term::Cap ({OSPEED=>9600}); # and be sure the terminal supports highlighting $terminal->Trequire('mr'); }; if (!$@ and $Orig ne ',,,'){ my @set = @$rl_term_set; $Term::ReadLine::TTYtter::term->ornaments (join(',', (split(/,/, $Orig))[0,1]) . ',mr,me') ; @set[4,5] = @$rl_term_set[2,3]; $Term::ReadLine::TTYtter::term->ornaments($Orig); @$rl_term_set = @set; } else { @$rl_term_set[4,5] = @$rl_term_set[2,3]; } } sub readline_dumb { local $\ = ''; print $term_OUT $prompt; local $/ = "\n"; return undef if !defined($line = $Term::ReadLine::TTYtter::term->get_line); chomp($line); $| = $oldbar; select $old; return $line; } ## ## This is it. Called as &readline'readline($prompt, $default), ## (DEFAULT can be omitted) the next input line is returned (undef on EOF). ## sub readline { # UTF-8 locale? if so, prepare for Unicode from the keyboard (incomplete) # nasty kludge for accounting for all the places this could be $LANG = $ENV{'LANG'} || $ENV{'GDM_LANG'} || $ENV{'LC_CTYPE'} || $ENV{'ALL'} || ''; $UUTF8 = ($LANG =~ /UTF-?8/i) ? 1 : 0; $ULATIN1 = ($LANG =~ /8859/) ? 1 : 0; $Term::ReadLine::TTYtter::term->register_Tk if not $Term::ReadLine::registered and $Term::ReadLine::toloop and defined &Tk::DoOneEvent; if ($stdin_not_tty) { local $/ = "\n"; return undef if !defined($line = <$term_IN>); chomp($line); return $line; } $old = select $term_OUT; $oldbar = $|; local($|) = 1; local($input); ## prompt should be given to us.... $prompt = defined($_[0]) ? $_[0] : 'INPUT> '; # Try to move cursor to the beginning of the next line if this line # contains anything. # On DOSish 80-wide console # perl -we "print 1 x shift, qq(\b2\r3); sleep 2" 79 # prints 3 on the same line, # perl -we "print 1 x shift, qq(\b2\r3); sleep 2" 80 # on the next; $rl_screen_width is 79. # on XTerm one needs to increase the number by 1. print $term_OUT ' ' x ($rl_screen_width - !$rl_last_pos_can_backspace) . "\b \r" if $rl_scroll_nextline; if ($dumb_term) { return readline_dumb; } # test if we resume an 'Operate' command if ($rl_OperateCount > 0 && (!defined $_[1] || $_[1] eq '')) { ## it's from a valid previous 'Operate' command and ## user didn't give a default line ## we leave $rl_HistoryIndex untouched $line = $rl_History[$rl_HistoryIndex]; } else { ## set history pointer at the end of history $rl_HistoryIndex = $#rl_History + 1; $rl_OperateCount = 0; $line = defined $_[1] ? $_[1] : ''; } $rl_OperateCount-- if $rl_OperateCount > 0; $line_for_revert = $line; # I don't think we need to do this, actually... # while (&ioctl(STDIN,$FIONREAD,$fion)) # { # local($n_chars_available) = unpack ($fionread_t, $fion); # ## print "n_chars = $n_chars_available\n"; # last if $n_chars_available == 0; # $line .= getc_with_pending; # should we prepend if $rl_start_default_at_beginning? # } $D = $rl_start_default_at_beginning ? 0 : length($line); ## set dot. $LastCommandKilledText = 0; ## heck, was no last command. $lastcommand = ''; ## Well, there you go. $line_rl_mark = -1; ## ## some stuff for &redisplay. ## $lastredisplay = ''; ## Was no last redisplay for this time. $lastlen = length($lastredisplay); $lastpromptlen = 0; $lastdelta = 0; ## Cursor was nowhere $si = 0; ## Want line to start left-justified $force_redraw = 1; ## Want to display with brute force. $in_readline = 1; $dont_use_counter ||= 0; $do_tco ||= 0; $ansi ||= 0; if (!eval {SetTTY()}) { ## Put into raw mode. warn $@ if $@; $dumb_term = 1; return readline_dumb; } *KeyMap = $var_EditingMode; undef($AcceptLine); ## When set, will return its value. undef($ReturnEOF); ## ...unless this on, then return undef. @Pending = (); ## Contains characters to use as input. @undo = (); ## Undo history starts empty for each line. @undoGroupS = (); ## Undo groups start empty for each line. undef $memorizedArg; ## No digitArgument memorized undef $memorizedPos; ## No position memorized undef $Vi_undo_state; undef $Vi_undo_all_state; # We need to do some additional initialization for vi mode. # RS: bug reports/platform issues are welcome: russ@dvns.com if ($KeyMap{'name'} eq 'vi_keymap'){ &F_ViInput(); if ($rl_vi_replace_default_on_insert){ local $^W=0; my $Orig = $Term::ReadLine::TTYtter::term->ornaments(); eval { # Term::ReadLine does not expose its $terminal, so make another require Term::Cap; my $terminal = Tgetent Term::Cap ({OSPEED=>9600}); # and be sure the terminal supports highlighting $terminal->Trequire('mr'); }; if (!$@ and $Orig ne ',,,'){ $Term::ReadLine::TTYtter::term->ornaments (join(',', (split(/,/, $Orig))[0,1]) . ',mr,me') } my $F_SelfInsert_Real = \&F_SelfInsert; *F_SelfInsert = sub { $Term::ReadLine::TTYtter::term->ornaments($Orig); &F_ViChangeEntireLine; local $^W=0; *F_SelfInsert = $F_SelfInsert_Real; &F_SelfInsert; }; my $F_ViEndInsert_Real = \&F_ViEndInsert; *F_ViEndInsert = sub { $Term::ReadLine::TTYtter::term->ornaments($Orig); local $^W=0; *F_SelfInsert = $F_SelfInsert_Real; *F_ViEndInsert = $F_ViEndInsert_Real; &F_ViEndInsert; $force_redraw = 1; redisplay(); }; } } if ($rl_default_selected) { redisplay_high(); } else { &redisplay(); ## Show the line (prompt+default at this point). } # pretend input if we 'Operate' on more than one line &F_OperateAndGetNext($rl_OperateCount) if $rl_OperateCount > 0; $rl_first_char = 1; while (!defined($AcceptLine)) { ## get a character of input (this can be UTF-8 now) $input = &getc_with_pending(); # bug in debugger, returns 42. - No more! if (unpack("H*", $input) eq '04' && $rl_first_char) { # CTRL-D $AcceptLine = $ReturnEOF = 1; last; } unless (defined $input) { # XXX What to do??? Until this is clear, just pretend we got EOF $AcceptLine = $ReturnEOF = 1; last; } preserve_state(); $ThisCommandKilledText = 0; ##print "\n\rline is @$D:[$line]\n\r"; ##DEBUG kill($SIGUSR1, $background_control) if ($background_control); my $cmd = get_command($var_EditingMode, ord($input)); if ( $rl_first_char && $cmd =~ /^F_(SelfInsert$|Yank)/ && length $line && $rl_default_selected ) { # (Backward)?DeleteChar specialcased in the code $line = ''; $D = 0; $cmd = 'F_BackwardDeleteChar' if $cmd eq 'F_DeleteChar'; } undef $doingNumArg; &$cmd(1, ord($input)); ## actually execute input $rl_first_char = 0; $lastcommand = $cmd; *KeyMap = $var_EditingMode; # JP: added # In Vi command mode, don't position the cursor beyond the last # character of the line buffer. &F_BackwardChar(1) if $Vi_mode and $line ne '' and &at_end_of_line and $KeyMap{'name'} eq 'vicmd_keymap'; &redisplay(); $LastCommandKilledText = $ThisCommandKilledText; kill($SIGUSR1, $background_control) if ($background_control); } $in_readline = 0; undef @undo; ## Release the memory. undef @undoGroupS; ## Release the memory. &ResetTTY; ## Restore the tty state. $| = $oldbar; select $old; return undef if defined($ReturnEOF); $AcceptLine = "\x{263A}".$AcceptLine; #print STDOUT "hex line is ", unpack("H*", $AcceptLine), "\n"; $AcceptLine = pack("U0H*", substr(unpack("U0H*", $AcceptLine), 6)); #print STDOUT "line is ",unpack("H*", $AcceptLine), "\n"; #print STDOUT "|al=`$AcceptLine'"; $AcceptLine; ## return the line accepted. } ## ctrl(ord('a')) will return the ordinal for Ctrl-A. sub ctrl { $_[0] ^ (($_[0]>=ord('a') && $_[0]<=ord('z')) ? 0x60 : 0x40); } sub SetTTY { return if $dumb_term || $stdin_not_tty; #return system 'stty raw -echo' if defined &DB::DB; if (defined $term_readkey) { Term::ReadKey::ReadMode(4, $term_IN); if ($^O eq 'MSWin32') { # If we reached this, Perl isn't cygwin; Enter sends \r; thus we need binmode # XXXX Do we need to undo??? $term_IN is most probably private now... binmode $term_IN; } return 1; } # system 'stty raw -echo'; $sgttyb = ''; ## just to quiet "perl -w"; if ($useioctl && $^O ne 'solaris' && defined $TIOCGETP && &ioctl($term_IN,$TIOCGETP,$sgttyb)) { @tty_buf = unpack($sgttyb_t,$sgttyb); if (defined $ENV{OS2_SHELL}) { $tty_buf[3] &= ~$mode; $tty_buf[3] &= ~$ECHO; } else { $tty_buf[4] |= $mode; $tty_buf[4] &= ~$ECHO; } $sgttyb = pack($sgttyb_t,@tty_buf); &ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!"; } elsif (!$usestty) { return 0; } else { warn < cygwin # The symptoms: now Enter sends \r; thus we need binmode # XXXX Do we need to undo??? $term_IN is most probably private now... binmode $term_IN; } } return 1; } sub ResetTTY { return if $dumb_term || $stdin_not_tty; #return system 'stty -raw echo' if defined &DB::DB; if (defined $term_readkey) { return Term::ReadKey::ReadMode(0, $term_IN); } # system 'stty -raw echo'; if ($useioctl) { &ioctl($term_IN,$TIOCGETP,$sgttyb) || die "Can't ioctl TIOCGETP: $!"; @tty_buf = unpack($sgttyb_t,$sgttyb); if (defined $ENV{OS2_SHELL}) { $tty_buf[3] |= $mode; $tty_buf[3] |= $ECHO; } else { $tty_buf[4] &= ~$mode; $tty_buf[4] |= $ECHO; } $sgttyb = pack($sgttyb_t,@tty_buf); &ioctl($term_IN,$TIOCSETP,$sgttyb) || die "Can't ioctl TIOCSETP: $!"; } elsif ($usestty) { system 'stty -raw echo' and die "Cannot call `stty': $!"; } } # Substr_with_props: gives the substr of prompt+string with embedded # face-change commands sub substr_with_props { my ($p, $s, $from, $len, $ket, $bsel, $esel) = @_; my $lp = length $p; defined $from or $from = 0; defined $len or $len = length($p) + length($s) - $from; unless (defined $ket) { warn 'bug in Term::ReadLine::Perl, please report to its author cpan@ilyaz.org'; $ket = ''; } # We may draw over to put cursor in a correct position: $ket = '' if $len < length($p) + length($s) - $from; # Not redrawn if ($from >= $lp) { $p = ''; $s = substr $s, $from - $lp; $lp = 0; } else { $p = substr $p, $from; $lp -= $from; $from = 0; } $s = substr $s, 0, $len - $lp; $p =~ s/^(\s*)//; my $bs = $1; $p =~ s/(\s*)$//; my $as = $1; $p = $rl_term_set->[0] . $p . $rl_term_set->[1] if (length($p) && $use_ansi) ; $p = "$bs$p$as"; $ket = chop $s if $ket; if (defined $bsel and $bsel != $esel) { $bsel = $len if $bsel > $len; $esel = $len if $esel > $len; } if (defined $bsel and $bsel != $esel) { get_ornaments_selected; $bsel -= $lp; $esel -= $lp; my ($pre, $sel, $post) = (substr($s, 0, $bsel), substr($s, $bsel, $esel-$bsel), substr($s, $esel)); if ($use_ansi) { $pre = $rl_term_set->[2] . $pre . $rl_term_set->[3] if length $pre; $sel = $rl_term_set->[4] . $sel . $rl_term_set->[5] if length $sel; $post = $rl_term_set->[2] . $post . $rl_term_set->[3] if length $post; } $s = "$pre$sel$post" } else { $s = $rl_term_set->[2] . $s . $rl_term_set->[3] if (length($s) && $use_ansi); } if (!$lp) { # Should not happen... return $s; } elsif (!length $s) { # Should not happen return $p; } else { # Do not underline spaces in the prompt return ("$p$s" . (length $ket ? ($rl_term_set->[0] . $ket . $rl_term_set->[1]) : '')) if ($use_ansi); return "$p$s$ket"; } } sub redisplay_high { get_ornaments_selected(); @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3]; &redisplay(); ## Show the line, default inverted. @$rl_term_set[2,3,4,5] = @$rl_term_set[4,5,2,3]; $force_redraw = 1; } ## compute the displayed length of the line. affected by $do_tco. sub dlength { my $x = shift; return ($do_tco) ? length(&$do_tco($x)) : length($x); } ## ## redisplay() ## ## Updates the screen to reflect the current $line. ## ## For the purposes of this routine, we prepend the prompt to a local copy of ## $line so that we display the prompt as well. We then modify it to reflect ## that some characters have different sizes (i.e. control-C is represented ## as ^C, tabs are expanded, etc.) ## ## This routine is somewhat complicated by two-byte characters.... must ## make sure never to try do display just half of one. ## ## NOTE: If an argument is given, it is used instead of the prompt. ## ## This is some nasty code. ## sub redisplay { ## local $line has prompt also; take that into account with $D. local($prompt) = defined($_[0]) ? $_[0] : $prompt; my ($thislen, $have_bra); my($dline) = $prompt . $line; local($D) = $D + length($prompt); my ($bsel, $esel); if (defined pos $line) { $bsel = (pos $line) + length $prompt; } my ($have_ket) = ''; ## ## If the line contains anything that might require special processing ## for displaying (such as tabs, control characters, etc.), we will ## take care of that now.... # not UTF-8 safe? ## if ($dline =~ m/[^\x20-\x7e]/) { local($new, $Dinc, $c) = ('', 0); ## Look at each character of $dline in turn..... for ($i = 0; $i < length($dline); $i++) { $c = substr($dline, $i, 1); ## A tab to expand... if ($c eq "\t") { $c = ' ' x (8 - (($i-length($prompt)) % 8)); ## A control character.... } elsif ($c =~ tr/\000-\037//) { $c = sprintf("^%c", ord($c)+ord('@')); ## the delete character.... } elsif (ord($c) == 127) { $c = '^?'; } $new .= $c; ## Bump over $D if this char is expanded and left of $D. $Dinc += length($c) - 1 if (length($c) > 1 && $i < $D); ## Bump over $bsel if this char is expanded and left of $bsel. $bsel += length($c) - 1 if (defined $bsel && length($c) > 1 && $i < $bsel); } $dline = $new; $D += $Dinc; } ## ## Now $dline is what we'd like to display. ## ## If it's too long to fit on the line, we must decide what we can fit. ## ## If we end up moving the screen index ($si) [index of the leftmost ## character on the screen], to some place other than the front of the ## the line, we'll have to make sure that it's not on the first byte of ## a 2-byte character, 'cause we'll be placing a '<' marker there, and ## that would screw up the 2-byte character. ## ## $si is preserved between several displays (if possible). ## ## Similarly, if the line needs chopped off, we make sure that the ## placement of the tailing '>' won't screw up any 2-byte character in ## the vicinity. ## if ($D == length($prompt)) { $si = 0; ## display from the beginning.... } elsif ($si >= $D) { # point to the left $si = &max(0, $D - $rl_margin - 7); $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si); } elsif ($si + $rl_screen_width - 7 <= $D) { # Point to the right $si = &min(length($dline), ($D - $rl_screen_width) + $rl_margin); $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si); } elsif (length($dline) - $si < $rl_screen_width - $rl_margin and $si) { # Too little of the line shown $si = &max(0, length($dline) - $rl_screen_width + 3); $si-- if $si > 0 && $si != length($prompt) && !&OnSecondByte($si); } else { ## Fine as-is.... don't need to change $si. } $have_bra = 1 if $si != 0; # Need the "chopped-off" marker $thislen = &min(length($dline) - $si, $rl_screen_width - 7); # lengthy if ($si + $thislen < length($dline)) { ## need to place a '>'... make sure to place on first byte. $thislen-- if &OnSecondByte($si+$thislen-1); substr($dline, $si+$thislen-1,1) = '>'; $have_ket = 1; } ## ## Now know what to display. ## Must get substr($dline, $si, $thislen) on the screen, ## with the cursor at $D-$si characters from the left edge. ## $dline = substr($dline, $si, $thislen); $delta = $D - $si; ## delta is cursor distance from beginning of $dline. if (defined $bsel) { $bsel -= $si; $esel = $delta; ($bsel, $esel) = ($esel, $bsel) if $bsel > $esel; $bsel = 0 if $bsel < 0; if ($have_ket) { $esel = $thislen - 1 if $esel > $thislen - 1; } else { $esel = $thislen if $esel > $thislen; } } if ($si >= length($prompt)) { # Keep $dline for $lastredisplay... $prompt = ($have_bra ? "<" : ""); $dline = substr $dline, 1; # After prompt $bsel = 1 if defined $bsel and $bsel == 0; } else { $dline = substr($dline, (length $prompt) - $si); $prompt = substr($prompt,$si); substr($prompt, 0, 1) = '<' if $si > 0; } # Now $dline is the part after the prompt... # add our character counter, plus padding if we deleted a wide character $dline = $dline.($dont_use_counter ? ' ' : (' <'.sprintf("%03i", &dlength($line)))) . " "; ## ## Now must output $dline, with cursor $delta spaces from left of TTY ## local ($\, $,) = ('',''); #print $term_OUT "xyz" . $prompt . $dline; #$force_redraw = 1; ## ## If $force_redraw is not set, we can attempt to optimize the redisplay ## However, if we don't happen to find an easy way to optimize, we just ## fall through to the brute-force method of re-drawing the whole line. ## if (not $force_redraw and not defined $bsel) { ## can try to optimize here a bit. ## For when we only need to move the cursor if ($lastredisplay eq $dline and $lastpromptlen == length $prompt) { ## If we need to move forward, just overwrite as far as we need. if ($lastdelta < $delta) { print $term_OUT substr_with_props($prompt, $dline, $lastdelta, $delta-$lastdelta, $have_ket); ## Need to move back. } elsif($lastdelta > $delta) { ## Two ways to move back... use the fastest. One is to just ## backspace the proper amount. The other is to jump to the ## the beginning of the line and overwrite from there.... my $out = substr_with_props($prompt, $dline, 0, $delta, $have_ket); if ($lastdelta - $delta <= length $out) { print $term_OUT "\b" x ($lastdelta - $delta); } else { print $term_OUT "\r", $out; } } ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen) = ($thislen, $dline, $delta, length $prompt); # print $term_OUT "\a"; # Debugging return; } ## for when we've just added stuff to the end if ($thislen > $lastlen && $lastdelta == $lastlen && $delta == $thislen && $lastpromptlen == length($prompt) && substr($dline, 0, $lastlen - $lastpromptlen) eq $lastredisplay) { print $term_OUT substr_with_props($prompt, $dline, $lastdelta, undef, $have_ket); # print $term_OUT "\a"; # Debugging ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen) = ($thislen, $dline, $delta, length $prompt); return; } ## There is much more opportunity for optimizing..... ## something to work on later..... } ## ## Brute force method of redisplaying... redraw the whole thing. ## print $term_OUT "\r" . substr_with_props($prompt, $dline, 0, undef, $have_ket, $bsel, $esel); my $back = length ($dline) + length ($prompt) - $delta; $back += $lastlen - $thislen, print $term_OUT ' ' x ($lastlen - $thislen) if $lastlen > $thislen; if ($back) { my $out = substr_with_props($prompt, $dline, 0, $delta, $have_ket, $bsel, $esel); if ($back <= length $out and not defined $bsel) { print $term_OUT "\b" x $back; } else { print $term_OUT "\r" . $out; } } ($lastlen, $lastredisplay, $lastdelta, $lastpromptlen) = ($thislen, $dline, $delta, length $prompt); $force_redraw = 0; } sub min { $_[0] < $_[1] ? $_[0] : $_[1]; } sub getc_hex { # this is definitely the WRONG WAY to fix this non-UTF-8 safe code, but # it works with the really old moldy code and new stuff, so there it is. # we use U0 when in a UTF-8 locale to help us on other systems like Ubuntu # and 10.6. systems like 10.4 (mostly) pass us UTF-8 regardless of locale. # we can't trust what we get from @Pending *or* rl_getc, so we need to # parse it all out. # my $w = (unpack( (($UUTF8) ? "U0H*" : "H*"), (@Pending ? shift(@Pending) : &$rl_getc))); #print $term_OUT "\nsequence: $w\n"; # Mac OS X 10.4 keeps inserting these spurious $16 characters. return &getc_hex if ($w eq '16'); # recursive call return $w if (length($w) == 2); # UNICODE my $i; my $j = ''; for($i=0; $i= 194 && $i <= 223) ? 4 : ($i >= 224 && $i <= 239) ? 6 : ($i >= 240 && $i <= 244) ? 8 : 2; while (length($key) < $chars_in_seq) { # this is a gross hack to deal with ISO-8859-1 getting in our # stream. it should work even if we get multiple Latin-1 chars # back to back, but could spew invalid UTF-8, so deal or fix your # keymap locale, beyotches. my $i = &getc_hex; last if (hex($i) < 128 || hex($i) > 191); $key .= $i; } $key = (length($key) == 2) ? ((hex($key) < 128) ? pack("H*", $key) : pack("U*", unpack("C*", pack("H*", $key)))) # AUGH THE PAIN THE PAIN : pack("U0H*", $key); #print STDOUT "result = ", unpack("H*", $key), "\n"; # Save keystrokes for vi '.' command push(@$Dot_buf, $key) if $Dot_buf; $key; } sub rl_getc { my $key; # JP: Added missing declaration if (defined $term_readkey) { # XXXX ??? $Term::ReadLine::TTYtter::term->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; $key = Term::ReadKey::ReadKey(0, $term_IN); } else { $key = $Term::ReadLine::TTYtter::term->get_c; } } ## ## get_command(keymap, ord_command_char) ## ## If the KEYMAP has an entry for COMMAND, it is returned. ## Otherwise, the default command is returned. ## sub get_command { local *KeyMap = shift; my ($key) = @_; my $cmd = defined($KeyMap[$key]) ? $KeyMap[$key] : ($KeyMap{'default'} || 'F_Ding'); if (!defined($cmd) || $cmd eq ''){ warn "internal error (key=$key)"; $cmd = 'F_Ding'; } $cmd } ## ## do_command(keymap, numericarg, command) ## ## If the KEYMAP has an entry for COMMAND, it is executed. ## Otherwise, the default command for the keymap is executed. ## sub do_command { my ($keymap, $count, $key) = @_; my $cmd = get_command($keymap, $key); local *KeyMap = $keymap; # &$cmd may expect it... &$cmd($count, $key); $lastcommand = $cmd; } ## ## Save whatever state we wish to save as an anonymous array. ## The only other function that needs to know about its encoding is getstate/preserve_state. ## sub savestate { [$D, $si, $LastCommandKilledText, $KillBuffer, $line, @_]; } # consolidate only-movement changes together... sub preserve_state { return if $Vi_mode; push(@undo, savestate()), return unless @undo; my $last = $undo[-1]; my @only_movement; if ( #$last->[1] == $si and $last->[2] eq $LastCommandKilledText # and $last->[3] eq $KillBuffer and $last->[4] eq $line ) { # Only position changed; remove old only-position-changed records pop @undo if $undo[-1]->[5]; @only_movement = 1; } push(@undo, savestate(@only_movement)); } ## ## $_[1] is an ASCII ordinal; inserts as per $count. ## sub F_SelfInsert { remove_selection(); my ($count, $ord) = @_; #my $text2add = pack('C', $ord) x $count; my $text2add = chr($ord) x $count; if ($InsertMode) { substr($line,$D,0) .= $text2add; } else { ## note: this can screw up with 2-byte characters. substr($line,$D,length($text2add)) = $text2add; } $D += length($text2add); } ## ## Return the line as-is to the user. ## sub F_AcceptLine { &add_line_to_history; $AcceptLine = $line; local $\ = ''; print $term_OUT "\r\n"; $force_redraw = 0; (pos $line) = undef; # Another way to force redraw... } sub add_line_to_history { ## Insert into history list if: ## * bigger than the minimal length ## * not same as last entry ## if (length($line) >= $minlength && (!@rl_History || $rl_History[$#rl_History] ne $line) ) { ## if the history list is full, shift out an old one first.... while (@rl_History >= $rl_MaxHistorySize) { shift(@rl_History); $rl_HistoryIndex--; } push(@rl_History, $line); ## tack new one on the end } } sub remove_selection { if ( $rl_first_char && length $line && $rl_default_selected ) { $line = ''; $D = 0; return 1; } if ($rl_delete_selection and defined pos $line and $D != pos $line) { kill_text(pos $line, $D); return 1; } return; } #sub F_ReReadInitFile; #sub rl_getc; sub F_ForwardChar; sub F_BackwardChar; sub F_BeginningOfLine; sub F_EndOfLine; sub F_ForwardWord; sub F_BackwardWord; sub F_RedrawCurrentLine; sub F_ClearScreen; # sub F_SelfInsert; sub F_QuotedInsert; sub F_TabInsert; #sub F_AcceptLine; sub F_OperateAndGetNext; sub F_BackwardDeleteChar; sub F_DeleteChar; sub F_UnixWordRubout; sub F_UnixLineDiscard; sub F_UpcaseWord; sub F_DownCaseWord; sub F_CapitalizeWord; sub F_TransposeWords; sub F_TransposeChars; sub F_PreviousHistory; sub F_NextHistory; sub F_BeginningOfHistory; sub F_EndOfHistory; sub F_ReverseSearchHistory; sub F_ForwardSearchHistory; sub F_HistorySearchBackward; sub F_HistorySearchForward; sub F_KillLine; sub F_BackwardKillLine; sub F_Yank; sub F_YankPop; sub F_YankNthArg; sub F_KillWord; sub F_BackwardKillWord; sub F_Abort; sub F_DoLowercaseVersion; sub F_DoMetaVersion; sub F_DoControlVersion; sub F_Undo; sub F_RevertLine; sub F_EmacsEditingMode; sub F_Interrupt; sub F_PrefixMeta; sub F_UniversalArgument; sub F_DigitArgument; sub F_OverwriteMode; sub F_InsertMode; sub F_ToggleInsertMode; sub F_Suspend; sub F_Ding; sub F_PossibleCompletions; sub F_Complete; sub F_YankClipboard; sub F_CopyRegionAsKillClipboard; sub F_KillRegionClipboard; sub clipboard_set; sub F_BeginUndoGroup; sub F_EndUndoGroup; sub F_DoNothing; sub F_ForceMemorizeDigitArgument; sub F_MemorizeDigitArgument; sub F_UnmemorizeDigitArgument; sub F_ResetDigitArgument; sub F_MergeInserts; sub F_MemorizePos; sub F_BeginPasteGroup; sub F_EndPasteGroup; sub F_BeginEditGroup; sub F_EndEditGroup; sub F_Repaint; # Comment next line and __DATA__ line below to disable the selfloader. use SelfLoader; 1; __DATA__ # From here on anything may be autoloaded sub max { $_[0] > $_[1] ? $_[0] : $_[1]; } sub isupper { ord($_[0]) >= ord('A') && ord($_[0]) <= ord('Z'); } sub islower { ord($_[0]) >= ord('a') && ord($_[0]) <= ord('z'); } sub toupper { &islower ? pack('c', ord($_[0])-ord('a')+ord('A')) : $_[0];} sub tolower { &isupper ? pack('c', ord($_[0])-ord('A')+ord('a')) : $_[0];} ## ## rl_set(var_name, value_string) ## ## Sets the named variable as per the given value, if both are appropriate. ## Allows the user of the package to set such things as HorizontalScrollMode ## and EditingMode. Value_string may be of the form ## HorizontalScrollMode ## horizontal-scroll-mode ## ## Also called during the parsing of ~/.inputrc for "set var value" lines. ## ## The previous value is returned, or undef on error. ########################################################################### ## Consider the following example for how to add additional variables ## accessible via rl_set (and hence via ~/.inputrc). ## ## Want: ## We want an external variable called "FooTime" (or "foo-time"). ## It may have values "January", "Monday", or "Noon". ## Internally, we'll want those values to translate to 1, 2, and 12. ## ## How: ## Have an internal variable $var_FooTime that will represent the current ## internal value, and initialize it to the default value. ## Make an array %var_FooTime whose keys and values are are the external ## (January, Monday, Noon) and internal (1, 2, 12) values: ## ## $var_FooTime = $var_FooTime{'January'} = 1; #default ## $var_FooTime{'Monday'} = 2; ## $var_FooTime{'Noon'} = 12; ## sub rl_set { local($var, $val) = @_; # &preinit's keys are all Capitalized $val = ucfirst lc $val if $val =~ /^(on|off)$/i; $var = 'CompleteAddsuffix' if $var eq 'visible-stats'; ## if the variable is in the form "some-name", change to "SomeName" local($_) = "\u$var"; local($return) = undef; s/-(.)/\u$1/g; # Skip unknown variables: return unless defined $ {'readline::'}{"var_$_"}; local(*V) = $ {'readline::'}{"var_$_"}; if (!defined($V)) { # XXX Duplicate check? warn("Warning$InputLocMsg:\n". " Invalid variable `$var'\n") if $^W; } elsif (!defined($V{$val})) { local(@selections) = keys(%V); warn("Warning$InputLocMsg:\n". " Invalid value `$val' for variable `$var'.\n". " Choose from [@selections].\n") if $^W; } else { $return = $V; $V = $V{$val}; ## make the setting } $return; } ## ## OnSecondByte($index) ## ## Returns true if the byte at $index into $line is the second byte ## of a two-byte character. ## sub OnSecondByte { return 0 if !$_rl_japanese_mb || $_[0] == 0 || $_[0] == length($line); die 'internal error' if $_[0] > length($line); ## ## must start looking from the beginning of the line .... can ## have one- and two-byte characters interspersed, so can't tell ## without starting from some know location..... ## local($i); for ($i = 0; $i < $_[0]; $i++) { next if ord(substr($line, $i, 1)) < 0x80; ## We have the first byte... must bump up $i to skip past the 2nd. ## If that one we're skipping past is the index, it should be changed ## to point to the first byte of the pair (therefore, decremented). return 1 if ++$i == $_[0]; } 0; ## seemed to be OK. } ## ## CharSize(index) ## ## Returns the size of the character at the given INDEX in the ## current line. Most characters are just one byte in length, ## but if the byte at the index and the one after has the high ## bit set those two bytes are one character of size=2. ## ## Assumes that index points to the first of a 2-byte char if not ## pointing to a 2-byte char. ## sub CharSize { return 2 if $_rl_japanese_mb && ord(substr($line, $_[0], 1)) >= 0x80 && ord(substr($line, $_[0]+1, 1)) >= 0x80; 1; } sub GetTTY { $base_termios = $termios; # make it long enough &ioctl($term_IN,$TCGETS,$base_termios) || die "Can't ioctl TCGETS: $!"; } sub XonTTY { # I don't know which of these I actually need to do this to, so we'll # just cover all bases. &ioctl($term_IN,$TCXONC,$TCOON); # || die "Can't ioctl TCXONC STDIN: $!"; &ioctl($term_OUT,$TCXONC,$TCOON); # || die "Can't ioctl TCXONC STDOUT: $!"; } sub ___SetTTY { # print "before SetTTY\n\r"; # system 'stty -a'; &XonTTY; &GetTTY if !defined($base_termios); @termios = unpack($termios_t,$base_termios); $termios[$TERMIOS_IFLAG] |= $TERMIOS_READLINE_ION; $termios[$TERMIOS_IFLAG] &= ~$TERMIOS_READLINE_IOFF; $termios[$TERMIOS_OFLAG] |= $TERMIOS_READLINE_OON; $termios[$TERMIOS_OFLAG] &= ~$TERMIOS_READLINE_OOFF; $termios[$TERMIOS_LFLAG] |= $TERMIOS_READLINE_LON; $termios[$TERMIOS_LFLAG] &= ~$TERMIOS_READLINE_LOFF; $termios[$TERMIOS_VMIN] = 1; $termios[$TERMIOS_VTIME] = 0; $termios = pack($termios_t,@termios); &ioctl($term_IN,$TCSETS,$termios) || die "Can't ioctl TCSETS: $!"; # print "after SetTTY\n\r"; # system 'stty -a'; } sub normal_tty_mode { return if $stdin_not_tty || $dumb_term || !$initialized; &XonTTY; &GetTTY if !defined($base_termios); &ResetTTY; } sub ___ResetTTY { # print "before ResetTTY\n\r"; # system 'stty -a'; @termios = unpack($termios_t,$base_termios); $termios[$TERMIOS_IFLAG] |= $TERMIOS_NORMAL_ION; $termios[$TERMIOS_IFLAG] &= ~$TERMIOS_NORMAL_IOFF; $termios[$TERMIOS_OFLAG] |= $TERMIOS_NORMAL_OON; $termios[$TERMIOS_OFLAG] &= ~$TERMIOS_NORMAL_OOFF; $termios[$TERMIOS_LFLAG] |= $TERMIOS_NORMAL_LON; $termios[$TERMIOS_LFLAG] &= ~$TERMIOS_NORMAL_LOFF; $termios = pack($termios_t,@termios); &ioctl($term_IN,$TCSETS,$termios) || die "Can't ioctl TCSETS: $!"; # print "after ResetTTY\n\r"; # system 'stty -a'; } ## ## WordBreak(index) ## ## Returns true if the character at INDEX into $line is a basic word break ## character, false otherwise. ## sub WordBreak { index($rl_basic_word_break_characters, substr($line,$_[0],1)) != -1; } sub getstate { ($D, $si, $LastCommandKilledText, $KillBuffer, $line) = @{$_[0]}; $ThisCommandKilledText = $LastCommandKilledText; } ## ## kills from D=$_[0] to $_[1] (to the killbuffer if $_[2] is true) ## sub kill_text { my($from, $to, $save) = (&min($_[0], $_[1]), &max($_[0], $_[1]), $_[2]); my $len = $to - $from; if ($save) { $KillBuffer = '' if !$LastCommandKilledText; if ($from < $LastCommandKilledText - 1) { $KillBuffer = substr($line, $from, $len) . $KillBuffer; } else { $KillBuffer .= substr($line, $from, $len); } $ThisCommandKilledText = 1 + $from; } substr($line, $from, $len) = ''; ## adjust $D if ($D > $from) { $D -= $len; $D = $from if $D < $from; } &rl_redisplay; } ########################################################################### ## Bindable functions... pretty much in the same order as in readline.c ### ########################################################################### ## ## Returns true if $D at the end of the line. ## sub at_end_of_line { ($D + &CharSize($D)) == (length($line) + 1); } ## ## Move forward (right) $count characters. ## sub F_ForwardChar { my $count = shift; return &F_BackwardChar(-$count) if $count < 0; while (!&at_end_of_line && $count-- > 0) { $D += &CharSize($D); } } ## ## Move backward (left) $count characters. ## sub F_BackwardChar { my $count = shift; return &F_ForwardChar(-$count) if $count < 0; while (($D > 0) && ($count-- > 0)) { $D--; ## Move back one regardless, $D-- if &OnSecondByte($D); ## another if over a big char. } } ## ## Go to beginning of line. ## sub F_BeginningOfLine { $D = 0; } ## ## Move to the end of the line. ## sub F_EndOfLine { &F_ForwardChar(100) while !&at_end_of_line; } ## ## Move to the end of this/next word. ## Done as many times as $count says. ## sub F_ForwardWord { my $count = shift; return &F_BackwardWord(-$count) if $count < 0; while (!&at_end_of_line && $count-- > 0) { ## skip forward to the next word (if not already on one) &F_ForwardChar(1) while !&at_end_of_line && &WordBreak($D); ## skip forward to end of word &F_ForwardChar(1) while !&at_end_of_line && !&WordBreak($D); } } ## ## ## Move to the beginning of this/next word. ## Done as many times as $count says. ## sub F_BackwardWord { my $count = shift; return &F_ForwardWord(-$count) if $count < 0; while ($D > 0 && $count-- > 0) { ## skip backward to the next word (if not already on one) &F_BackwardChar(1) while (($D > 0) && &WordBreak($D-1)); ## skip backward to start of word &F_BackwardChar(1) while (($D > 0) && !&WordBreak($D-1)); } } ## ## Refresh the input line. ## sub F_RedrawCurrentLine { $force_redraw = 1; } ## ## Clear the screen and refresh the line. ## If given a numeric arg other than 1, simply refreshes the line. ## sub F_ClearScreen { my $count = shift; return &F_RedrawCurrentLine if $count != 1; $rl_CLEAR = `clear` if !defined($rl_CLEAR); local $\ = ''; print $term_OUT $rl_CLEAR; $force_redraw = 1; } ## ## Insert the next character read verbatim. ## sub F_QuotedInsert { my $count = shift; &F_SelfInsert($count, ord(&getc_with_pending)); } ## ## Insert a tab. ## sub F_TabInsert { my $count = shift; &F_SelfInsert($count, ord("\t")); } ## Operate - accept the current line and fetch from the ## history the next line relative to current line for default. sub F_OperateAndGetNext { my $count = shift; &F_AcceptLine; my $remainingEntries = $#rl_History - $rl_HistoryIndex; if ($count > 0 && $remainingEntries >= 0) { # there is something to repeat if ($remainingEntries > 0) { # if we are not on last line $rl_HistoryIndex++; # fetch next one $count = $remainingEntries if $count > $remainingEntries; } $rl_OperateCount = $count; } } ## ## Removes $count chars to left of cursor (if not at beginning of line). ## If $count > 1, deleted chars saved to kill buffer. ## sub F_BackwardDeleteChar { return if remove_selection(); my $count = shift; return F_DeleteChar(-$count) if $count < 0; my $oldD = $D; &F_BackwardChar($count); return if $D == $oldD; &kill_text($oldD, $D, $count > 1); } ## ## Removes the $count chars from under the cursor. ## If there is no line and the last command was different, tells ## readline to return EOF. ## If there is a line, and the cursor is at the end of it, and we're in ## tcsh completion mode, then list possible completions. ## If $count > 1, deleted chars saved to kill buffer. ## sub F_DeleteChar { return if remove_selection(); my $count = shift; return F_DeleteBackwardChar(-$count) if $count < 0; if (length($line) == 0) { # EOF sent (probably OK in DOS too) # I hate this and it annoys people, so I'm turning it off. Cameron #$AcceptLine = $ReturnEOF = 1 if $lastcommand ne 'F_DeleteChar'; return; } if ($D == length ($line)) { &complete_internal('?') if $var_TcshCompleteMode; return; } my $oldD = $D; &F_ForwardChar($count); return if $D == $oldD; &kill_text($oldD, $D, $count > 1); } ## ## Kill to previous whitespace. ## sub F_UnixWordRubout { return &F_Ding if $D == 0; (my $oldD, local $rl_basic_word_break_characters) = ($D, "\t "); # JP: Fixed a bug here - both were 'my' F_BackwardWord(1); kill_text($D, $oldD, 1); } ## ## Kill line from cursor to beginning of line. ## sub F_UnixLineDiscard { return &F_Ding if $D == 0; kill_text(0, $D, 1); } sub F_UpcaseWord { &changecase($_[0], 'up'); } sub F_DownCaseWord { &changecase($_[0], 'down'); } sub F_CapitalizeWord { &changecase($_[0], 'cap'); } ## ## Translated from GNUs readline.c ## One arg is 'up' to upcase $_[0] words, ## 'down' to downcase them, ## or something else to capitolize them. ## If $_[0] is negative, the dot is not moved. ## sub changecase { my $op = $_[1]; my ($start, $state, $c, $olddot) = ($D, 0); if ($_[0] < 0) { $olddot = $D; $_[0] = -$_[0]; } &F_ForwardWord; ## goes forward $_[0] words. while ($start < $D) { $c = substr($line, $start, 1); if ($op eq 'up') { $c = &toupper($c); } elsif ($op eq 'down') { $c = &tolower($c); } else { ## must be 'cap' if ($state == 1) { $c = &tolower($c); } else { $c = &toupper($c); $state = 1; } $state = 0 if $c !~ tr/a-zA-Z//; } substr($line, $start, 1) = $c; $start++; } $D = $olddot if defined($olddot); } sub F_TransposeWords { my $c = shift; return F_Ding() unless $c; # Find "this" word F_BackwardWord(1); my $p0 = $D; F_ForwardWord(1); my $p1 = $D; return F_Ding() if $p1 == $p0; my ($p2, $p3) = ($p0, $p1); if ($c > 0) { F_ForwardWord($c); $p3 = $D; F_BackwardWord(1); $p2 = $D; } else { F_BackwardWord(1 - $c); $p0 = $D; F_ForwardWord(1); $p1 = $D; } return F_Ding() if $p3 == $p2 or $p2 < $p1; my $r = substr $line, $p2, $p3 - $p2; substr($line, $p2, $p3 - $p2) = substr $line, $p0, $p1 - $p0; substr($line, $p0, $p1 - $p0) = $r; $D = $c > 0 ? $p3 : $p0 + $p3 - $p2; # End of "this" word after edit return 1; ## Exchange words: C-Left, C-right, C-right, C-left. If positions do ## not overlap, we get two things to transpose. Repeat count? } ## ## Switch char at dot with char before it. ## If at the end of the line, switch the previous two... ## (NOTE: this could screw up multibyte characters.. should do correctly) sub F_TransposeChars { if ($D == length($line) && $D >= 2) { substr($line,$D-2,2) = substr($line,$D-1,1).substr($line,$D-2,1); } elsif ($D >= 1) { substr($line,$D-1,2) = substr($line,$D,1) .substr($line,$D-1,1); } else { &F_Ding; } } sub F_PreviousHistory { &get_line_from_history($rl_HistoryIndex - shift); } sub F_NextHistory { &get_line_from_history($rl_HistoryIndex + shift); } sub F_BeginningOfHistory { &get_line_from_history(0); } sub F_EndOfHistory { &get_line_from_history(@rl_History); } sub F_ReverseSearchHistory { &DoSearch($_[0] >= 0 ? 1 : 0); } sub F_ForwardSearchHistory { &DoSearch($_[0] >= 0 ? 0 : 1); } sub F_HistorySearchBackward { &DoSearchStart(($_[0] >= 0 ? 1 : 0),substr($line,0,$D)); } sub F_HistorySearchForward { &DoSearchStart(($_[0] >= 0 ? 0 : 1),substr($line,0,$D)); } ## returns a new $i or -1 if not found. sub search { my ($i, $str) = @_; return -1 if $i < 0 || $i > $#rl_History; ## for safety while (1) { return $i if rindex($rl_History[$i], $str) >= 0; if ($reverse) { return -1 if $i-- == 0; } else { return -1 if $i++ == $#rl_History; } } } sub DoSearch { local $reverse = shift; # Used in search() my $oldline = $line; my $oldD = $D; my $searchstr = ''; ## string we're searching for my $I = -1; ## which history line $si = 0; while (1) { if ($I != -1) { $line = $rl_History[$I]; $D += index($rl_History[$I], $searchstr); } &redisplay( '('.($reverse?'reverse-':'') ."i-search) `$searchstr': "); $c = &getc_with_pending; if ($KeyMap[ord($c)] eq 'F_ReverseSearchHistory') { if ($reverse && $I != -1) { if ($tmp = &search($I-1,$searchstr), $tmp >= 0) { $I = $tmp; } else { &F_Ding; } } $reverse = 1; } elsif ($KeyMap[ord($c)] eq 'F_ForwardSearchHistory') { if (!$reverse && $I != -1) { if ($tmp = &search($I+1,$searchstr), $tmp >= 0) { $I = $tmp; } else { &F_Ding; } } $reverse = 0; } elsif ($c eq "\007") { ## abort search... restore line and return $line = $oldline; $D = $oldD; return; } elsif (ord($c) < 32 || ord($c) > 126) { push(@Pending, $c) if $c ne "\e"; if ($I < 0) { ## just restore $line = $oldline; $D = $oldD; } else { #chose this line $line = $rl_History[$I]; $D = index($rl_History[$I], $searchstr); } &redisplay(); last; } else { ## Add this character to the end of the search string and ## see if that'll match anything. $tmp = &search($I < 0 ? $rl_HistoryIndex-$reverse: $I, $searchstr.$c); if ($tmp == -1) { &F_Ding; } else { $searchstr .= $c; $I = $tmp; } } } } ## returns a new $i or -1 if not found. sub searchStart { my ($i, $reverse, $str) = @_; $i += $reverse ? - 1: +1; return -1 if $i < 0 || $i > $#rl_History; ## for safety while (1) { return $i if index($rl_History[$i], $str) == 0; if ($reverse) { return -1 if $i-- == 0; } else { return -1 if $i++ == $#rl_History; } } } sub DoSearchStart { my ($reverse,$what) = @_; my $i = searchStart($rl_HistoryIndex, $reverse, $what); return if $i == -1; $rl_HistoryIndex = $i; ($D, $line) = (0, $rl_History[$rl_HistoryIndex]); F_BeginningOfLine(); F_ForwardChar(length($what)); } ########################################################################### ########################################################################### ## ## Kill from cursor to end of line. ## sub F_KillLine { my $count = shift; return F_BackwardKillLine(-$count) if $count < 0; kill_text($D, length($line), 1); } ## ## Delete from cursor to beginning of line. ## sub F_BackwardKillLine { my $count = shift; return F_KillLine(-$count) if $count < 0; return F_Ding if $D == 0; kill_text(0, $D, 1); } ## ## TextInsert(count, string) ## sub TextInsert { my $count = shift; my $text2add = shift(@_) x $count; if ($InsertMode) { substr($line,$D,0) .= $text2add; } else { substr($line,$D,length($text2add)) = $text2add; } $D += length($text2add); } sub F_Yank { remove_selection(); &TextInsert($_[0], $KillBuffer); } sub F_YankPop { 1; ## not implemented yet } sub F_YankNthArg { 1; ## not implemented yet } ## ## Kill to the end of the current word. If not on a word, kill to ## the end of the next word. ## sub F_KillWord { my $count = shift; return &F_BackwardKillWord(-$count) if $count < 0; my $oldD = $D; &F_ForwardWord($count); ## moves forward $count words. kill_text($oldD, $D, 1); } ## ## Kill backward to the start of the current word, or, if currently ## not on a word (or just at the start of a word), to the start of the ## previous word. ## sub F_BackwardKillWord { my $count = shift; return F_KillWord(-$count) if $count < 0; my $oldD = $D; &F_BackwardWord($count); ## moves backward $count words. kill_text($D, $oldD, 1); } ########################################################################### ########################################################################### ## ## Abort the current input. ## sub F_Abort { &F_Ding; } ## ## If the character that got us here is upper case, ## do the lower-case equiv... ## sub F_DoLowercaseVersion { if ($_[1] >= ord('A') && $_[1] <= ord('Z')) { &do_command(*KeyMap, $_[0], $_[1] - ord('A') + ord('a')); } else { &F_Ding; } } ## ## do the equiv with control key... ## sub F_DoControlVersion { local *KeyMap = $var_EditingMode; my $key = $_[1]; if ($key == ord('?')) { $key = 0x7F; } else { $key &= ~(0x80 | 0x60); } &do_command(*KeyMap, $_[0], $key); } ## ## do the equiv with meta key... ## sub F_DoMetaVersion { local *KeyMap = $var_EditingMode; unshift @Pending, chr $_[1]; &do_command(*KeyMap, $_[0], ord "\e"); } ## ## If the character that got us here is Alt-Char, ## do the Esc Char equiv... ## sub F_DoEscVersion { my ($ord, $t) = $_[1]; &F_Ding unless $KeyMap{'Esc'}; for $t (([ord 'w', '`1234567890-='], [ord ',', 'zxcvbnm,./\\'], [16, 'qwertyuiop[]'], [ord(' ') - 2, 'asdfghjkl;\''])) { next unless $ord >= $t->[0] and $ord < $t->[0] + length($t->[1]); $ord = ord substr $t->[1], $ord - $t->[0], 1; return &do_command($KeyMap{'Esc'}, $_[0], $ord); } &F_Ding; } ## ## Undo one level. ## sub F_Undo { pop(@undo); # unless $undo[-1]->[5]; ## get rid of the state we just put on, so we can go back one. if (@undo) { &getstate(pop(@undo)); } else { &F_Ding; } } ## ## Replace the current line to some "before" state. ## sub F_RevertLine { if ($rl_HistoryIndex >= $#rl_History+1) { $line = $line_for_revert; } else { $line = $rl_History[$rl_HistoryIndex]; } $D = length($line); } sub F_EmacsEditingMode { $var_EditingMode = $var_EditingMode{'emacs'}; $Vi_mode = 0; } ########################################################################### ########################################################################### ## ## (Attempt to) interrupt the current program. ## sub F_Interrupt { local $\ = ''; print $term_OUT "\r\n"; &ResetTTY; kill ("INT", 0); ## We're back.... must not have died. $force_redraw = 1; } ## ## Execute the next character input as a command in a meta keymap. ## sub F_PrefixMeta { my($count, $keymap) = ($_[0], "$KeyMap{'name'}_$_[1]"); ##print "F_PrefixMeta [$keymap]\n\r"; die "" unless %$keymap; do_command(*$keymap, $count, ord(&getc_with_pending)); } sub F_UniversalArgument { &F_DigitArgument; } ## ## For typing a numeric prefix to a command.... ## sub F_DigitArgument { my $in = chr $_[1]; my ($NumericArg, $sawDigit) = (1, 0); my ($increment, $ord); ($NumericArg, $sawDigit) = ($_[0], $_[0] !~ /e0$/i) if $doingNumArg; # XXX What if Esc-- 1 ? do { $ord = ord $in; if (defined($KeyMap[$ord]) && $KeyMap[$ord] eq 'F_UniversalArgument') { $NumericArg *= 4; } elsif ($ord == ord('-') && !$sawDigit) { $NumericArg = -$NumericArg; } elsif ($ord >= ord('0') && $ord <= ord('9')) { $increment = ($ord - ord('0')) * ($NumericArg < 0 ? -1 : 1); if ($sawDigit) { $NumericArg = $NumericArg * 10 + $increment; } else { $NumericArg = $increment; $sawDigit = 1; } } else { local(*KeyMap) = $var_EditingMode; &redisplay(); $doingNumArg = 1; # Allow NumArg inside NumArg &do_command(*KeyMap, $NumericArg . ($sawDigit ? '': 'e0'), $ord); return; } ## make sure it's not toooo big. if ($NumericArg > $rl_max_numeric_arg) { $NumericArg = $rl_max_numeric_arg; } elsif ($NumericArg < -$rl_max_numeric_arg) { $NumericArg = -$rl_max_numeric_arg; } &redisplay(sprintf("(arg %d) ", $NumericArg)); } while defined($in = &getc_with_pending); } sub F_OverwriteMode { $InsertMode = 0; } sub F_InsertMode { $InsertMode = 1; } sub F_ToggleInsertMode { $InsertMode = !$InsertMode; } ## ## (Attempt to) suspend the program. ## sub F_Suspend { if ($inDOS && length($line)==0) { # EOF sent $AcceptLine = $ReturnEOF = 1 if $lastcommand ne 'F_DeleteChar'; return; } local $\ = ''; print $term_OUT "\r\n"; &ResetTTY; eval { kill ("TSTP", 0) }; ## We're back.... &SetTTY; $force_redraw = 1; } ## ## Ring the bell. ## Should do something with $var_PreferVisibleBell here, but what? ## sub F_Ding { local $\ = ''; print $term_OUT "\007"; return; # Undefined return value } ########################################################################## #### command/file completion ############################################ ########################################################################## ## ## How Command Completion Works ## ## When asked to do a completion operation, readline isolates the word ## to the immediate left of the cursor (i.e. what's just been typed). ## This information is then passed to some function (which may be supplied ## by the user of this package) which will return an array of possible ## completions. ## ## If there is just one, that one is used. Otherwise, they are listed ## in some way (depends upon $var_TcshCompleteMode). ## ## The default is to do filename completion. The function that performs ## this task is readline'rl_filename_list. ## ## A minimal-trouble way to have command-completion is to call ## readline'rl_basic_commands with an array of command names, such as ## &readline'rl_basic_commands('quit', 'run', 'set', 'list') ## Those command names will then be used for completion if the word being ## completed begins the line. Otherwise, completion is disallowed. ## ## The way to have the most power is to provide a function to readline ## which will accept information about a partial word that needs completed, ## and will return the appropriate list of possibilities. ## This is done by setting $readline'rl_completion_function to the name of ## the function to run. ## ## That function will be called with three args ($text, $line, $start). ## TEXT is the partial word that should be completed. LINE is the entire ## input line as it stands, and START is the index of the TEXT in LINE ## (i.e. zero if TEXT is at the beginning of LINE). ## ## A cool completion function will look at LINE and START and give context- ## sensitive completion lists. Consider something that will do completion ## for two commands ## cat FILENAME ## finger USERNAME ## status [this|that|other] ## ## It (untested) might look like: ## ## $readline'rl_completion_function = "main'complete"; ## sub complete { local($text, $_, $start) = @_; ## ## return commands which may match if at the beginning.... ## return grep(/^$text/, 'cat', 'finger') if $start == 0; ## return &rl_filename_list($text) if /^cat\b/; ## return &my_namelist($text) if /^finger\b/; ## return grep(/^text/, 'this', 'that','other') if /^status\b/; ## (); ## } ## Of course, a real completion function would be more robust, but you ## get the idea (I hope). ## ## ## List possible completions ## sub F_PossibleCompletions { &complete_internal('?'); } ## ## List possible completions ## sub F_InsertPossibleCompletions { &complete_internal('*'); } ## ## Do a completion operation. ## If the last thing we did was a completion operation, we'll ## now list the options available (under normal emacs mode). ## ## Under TcshCompleteMode, each contiguous subsequent completion operation ## lists another of the possible options. ## ## Returns true if a completion was done, false otherwise, so vi completion ## routines can test it. ## sub F_Complete { if ($lastcommand eq 'F_Complete') { if ($var_TcshCompleteMode && @tcsh_complete_selections > 0) { substr($line, $tcsh_complete_start, $tcsh_complete_len) = $tcsh_complete_selections[0]; $D -= $tcsh_complete_len; $tcsh_complete_len = length($tcsh_complete_selections[0]); $D += $tcsh_complete_len; push(@tcsh_complete_selections, shift(@tcsh_complete_selections)); } else { &complete_internal('?') or return; } } else { @tcsh_complete_selections = (); &complete_internal("\t") or return; } 1; } ## ## The meat of command completion. Patterned closely after GNU's. ## ## The supposedly partial word at the cursor is "completed" as per the ## single argument: ## "\t" complete as much of the word as is unambiguous ## "?" list possibilities. ## "*" replace word with all possibilities. (who would use this?) ## ## A few notable variables used: ## $rl_completer_word_break_characters ## -- characters in this string break a word. ## $rl_special_prefixes ## -- but if in this string as well, remain part of that word. ## ## Returns true if a completion was done, false otherwise, so vi completion ## routines can test it. ## sub complete_internal { my $what_to_do = shift; my ($point, $end) = ($D, $D); # In vi mode, complete if the cursor is at the *end* of a word, not # after it. ($point++, $end++) if $Vi_mode; if ($point) { ## Not at the beginning of the line; Isolate the word to be completed. 1 while (--$point && (-1 == index($rl_completer_word_break_characters, substr($line, $point, 1)))); # Either at beginning of line or at a word break. # If at a word break (that we don't want to save), skip it. $point++ if ( (index($rl_completer_word_break_characters, substr($line, $point, 1)) != -1) && (index($rl_special_prefixes, substr($line, $point, 1)) == -1) ); } my $text = substr($line, $point, $end - $point); $rl_completer_terminator_character = ' '; @matches = &completion_matches($rl_completion_function,$text,$line,$point); if (@matches == 0) { return &F_Ding; } elsif ($what_to_do eq "\t") { my $replacement = shift(@matches); $replacement .= $rl_completer_terminator_character if @matches == 1; &F_Ding if @matches != 1; if ($var_TcshCompleteMode) { @tcsh_complete_selections = (@matches, $text); $tcsh_complete_start = $point; $tcsh_complete_len = length($replacement); } if ($replacement ne '') { substr($line, $point, $end-$point) = $replacement; $D = $D - ($end - $point) + length($replacement); } } elsif ($what_to_do eq '?') { shift(@matches); ## remove prepended common prefix local $\ = ''; print $term_OUT "\n\r"; # print "@matches\n\r"; &pretty_print_list (@matches); $force_redraw = 1; } elsif ($what_to_do eq '*') { shift(@matches); ## remove common prefix. local $" = $rl_completer_terminator_character; my $replacement = "@matches$rl_completer_terminator_character"; substr($line, $point, $end-$point) = $replacement; ## insert all. $D = $D - ($end - $point) + length($replacement); } else { warn "\r\n[Internal error]"; return &F_Ding; } 1; } ## ## completion_matches(func, text, line, start) ## ## FUNC is a function to call as FUNC(TEXT, LINE, START) ## where TEXT is the item to be completed ## LINE is the whole command line, and ## START is the starting index of TEXT in LINE. ## The FUNC should return a list of items that might match. ## ## completion_matches will return that list, with the longest common ## prefix prepended as the first item of the list. Therefor, the list ## will either be of zero length (meaning no matches) or of 2 or more..... ## ## Works with &rl_basic_commands. Return items from @rl_basic_commands ## that start with the pattern in $text. sub use_basic_commands { my ($text, $line, $start) = @_; return () if $start != 0; grep(/^$text/, @rl_basic_commands); } sub completion_matches { my ($func, $text, $line, $start) = @_; ## get the raw list my @matches; #print qq/\r\neval("\@matches = &$func(\$text, \$line, \$start)\n\r/;#DEBUG #eval("\@matches = &$func(\$text, \$line, \$start);1") || warn "$@ "; @matches = &$func($text, $line, $start); ## if anything returned , find the common prefix among them if (@matches) { my $prefix = $matches[0]; my $len = length($prefix); for ($i = 1; $i < @matches; $i++) { next if substr($matches[$i], 0, $len) eq $prefix; $prefix = substr($prefix, 0, --$len); last if $len == 0; $i--; ## retry this one to see if the shorter one matches. } unshift(@matches, $prefix); ## make common prefix the first thing. } @matches; } ## ## For use in passing to completion_matches(), returns a list of ## filenames that begin with the given pattern. The user of this package ## can set $rl_completion_function to 'rl_filename_list' to restore the ## default of filename matching if they'd changed it earlier, either ## directly or via &rl_basic_commands. ## sub rl_filename_list { my $pattern = $_[0]; my @files = (<$pattern*>); if ($var_CompleteAddsuffix) { foreach (@files) { if (-l $_) { $_ .= '@'; } elsif (-d _) { $_ .= '/'; } elsif (-x _) { $_ .= '*'; } elsif (-S _ || -p _) { $_ .= '='; } } } return @files; } ## ## For use by the user of the package. Called with a list of possible ## commands, will allow command completion on those commands, but only ## for the first word on a line. ## For example: &rl_basic_commands('set', 'quit', 'type', 'run'); ## ## This is for people that want quick and simple command completion. ## A more thoughtful implementation would set $rl_completion_function ## to a routine that would look at the context of the word being completed ## and return the appropriate possibilities. ## sub rl_basic_commands { @rl_basic_commands = @_; $rl_completion_function = 'use_basic_commands'; } ## ## Print an array in columns like ls -C. Originally based on stuff ## (lsC2.pl) by utashiro@sran230.sra.co.jp (Kazumasa Utashiro). ## sub pretty_print_list { my @list = @_; return unless @list; my ($lines, $columns, $mark, $index); ## find width of widest entry my $maxwidth = 0; grep(length > $maxwidth && ($maxwidth = length), @list); $maxwidth++; $columns = $maxwidth >= $rl_screen_width ? 1 : int($rl_screen_width / $maxwidth); ## if there's enough margin to interspurse among the columns, do so. $maxwidth += int(($rl_screen_width % $maxwidth) / $columns); $lines = int((@list + $columns - 1) / $columns); $columns-- while ((($lines * $columns) - @list + 1) > $lines); $mark = $#list - $lines; local $\ = ''; for ($l = 0; $l < $lines; $l++) { for ($index = $l; $index <= $mark; $index += $lines) { printf("%-$ {maxwidth}s", $list[$index]); } print $term_OUT $list[$index] if $index <= $#list; print $term_OUT "\n\r"; } } ##----------------- Vi Routines -------------------------------- sub F_ViAcceptLine { &F_AcceptLine(); &F_ViInput(); } # Repeat the most recent one of these vi commands: # # a A c C d D i I p P r R s S x X ~ # sub F_ViRepeatLastCommand { my($count) = @_; return &F_Ding if !$Last_vi_command; my @lastcmd = @$Last_vi_command; # Multiply @lastcmd's numeric arg by $count. unless ($count == 1) { my $n = ''; while (@lastcmd and $lastcmd[0] =~ /^\d$/) { $n *= 10; $n += shift(@lastcmd); } $count *= $n unless $n eq ''; unshift(@lastcmd, split(//, $count)); } push(@Pending, @lastcmd); } sub F_ViMoveCursor { my($count, $ord) = @_; my $new_cursor = &get_position($count, $ord, undef, $Vi_move_patterns); return &F_Ding if !defined $new_cursor; $D = $new_cursor; } sub F_ViFindMatchingParens { # Move to the first parens at or after $D my $old_d = $D; &forward_scan(1, q/[^[\](){}]*/); my $parens = substr($line, $D, 1); my $mate_direction = { '(' => [ ')', 1 ], '[' => [ ']', 1 ], '{' => [ '}', 1 ], ')' => [ '(', -1 ], ']' => [ '[', -1 ], '}' => [ '{', -1 ], }->{$parens}; return &F_Ding() unless $mate_direction; my($mate, $direction) = @$mate_direction; my $lvl = 1; while ($lvl) { last if !$D && ($direction < 0); &F_ForwardChar($direction); last if &at_end_of_line; my $c = substr($line, $D, 1); if ($c eq $parens) { $lvl++; } elsif ($c eq $mate) { $lvl--; } } if ($lvl) { # We didn't find a match $D = $old_d; return &F_Ding(); } } sub F_ViForwardFindChar { &do_findchar(1, 1, @_); } sub F_ViBackwardFindChar { &do_findchar(-1, 0, @_); } sub F_ViForwardToChar { &do_findchar(1, 0, @_); } sub F_ViBackwardToChar { &do_findchar(-1, 1, @_); } sub F_ViMoveCursorTo { &do_findchar(1, -1, @_); } sub F_ViMoveCursorFind { &do_findchar(1, 0, @_); } sub F_ViRepeatFindChar { my($n) = @_; return &F_Ding if !defined $Last_findchar; &findchar(@$Last_findchar, $n); } sub F_ViInverseRepeatFindChar { my($n) = @_; return &F_Ding if !defined $Last_findchar; my($c, $direction, $offset) = @$Last_findchar; &findchar($c, -$direction, $offset, $n); } sub do_findchar { my($direction, $offset, $n) = @_; my $c = &getc_with_pending; $c = &getc_with_pending if $c eq "\cV"; return &F_ViCommandMode if $c eq "\e"; $Last_findchar = [$c, $direction, $offset]; &findchar($c, $direction, $offset, $n); } sub findchar { my($c, $direction, $offset, $n) = @_; my $old_d = $D; while ($n) { last if !$D && ($direction < 0); &F_ForwardChar($direction); last if &at_end_of_line; my $char = substr($line, $D, 1); $n-- if substr($line, $D, 1) eq $c; } if ($n) { # Not found $D = $old_d; return &F_Ding; } &F_ForwardChar($offset); } sub F_ViMoveToColumn { my($n) = @_; $D = 0; my $col = 1; while (!&at_end_of_line and $col < $n) { my $c = substr($line, $D, 1); if ($c eq "\t") { $col += 7; $col -= ($col % 8) - 1; } else { $col++; } $D += &CharSize($D); } } sub start_dot_buf { my($count, $ord) = @_; $Dot_buf = [pack('c', $ord)]; unshift(@$Dot_buf, split(//, $count)) if $count > 1; $Dot_state = savestate(); } sub end_dot_buf { # We've recognized an editing command # Save the command keystrokes for use by '.' $Last_vi_command = $Dot_buf; undef $Dot_buf; # Save the pre-command state for use by 'u' and 'U'; $Vi_undo_state = $Dot_state; $Vi_undo_all_state = $Dot_state if !$Vi_undo_all_state; # Make sure the current line is treated as new line for history purposes. $rl_HistoryIndex = $#rl_History + 1; } sub save_dot_buf { &start_dot_buf(@_); &end_dot_buf; } sub F_ViUndo { return &F_Ding unless defined $Vi_undo_state; my $state = savestate(); &getstate($Vi_undo_state); $Vi_undo_state = $state; } sub F_ViUndoAll { $Vi_undo_state = $Vi_undo_all_state; &F_ViUndo; } sub F_ViChange { my($count, $ord) = @_; &start_dot_buf(@_); &do_delete($count, $ord, $Vi_change_patterns) || return(); &vi_input_mode; } sub F_ViDelete { my($count, $ord) = @_; &start_dot_buf(@_); &do_delete($count, $ord, $Vi_delete_patterns); &end_dot_buf; } sub do_delete { my($count, $ord, $poshash) = @_; my $other_end = &get_position($count, undef, $ord, $poshash); return &F_Ding if !defined $other_end; if ($other_end < 0) { # dd - delete entire line &kill_text(0, length($line), 1); } else { &kill_text($D, $other_end, 1); } 1; # True return value } sub F_ViDeleteChar { my($count) = @_; &save_dot_buf(@_); my $other_end = $D + $count; $other_end = length($line) if $other_end > length($line); &kill_text($D, $other_end, 1); } sub F_ViBackwardDeleteChar { my($count) = @_; &save_dot_buf(@_); my $other_end = $D - $count; $other_end = 0 if $other_end < 0; &kill_text($other_end, $D, 1); $D = $other_end; } ## ## Prepend line with '#', add to history, and clear the input buffer ## (this feature was borrowed from ksh). ## sub F_SaveLine { local $\ = ''; $line = '#'.$line; &redisplay(); print $term_OUT "\r\n"; &add_line_to_history; $line_for_revert = ''; &get_line_from_history(scalar @rl_History); &F_ViInput() if $Vi_mode; } # # Come here if we see a non-positioning keystroke when a positioning # keystroke is expected. # sub F_ViNonPosition { # Not a positioning command - undefine the cursor to indicate the error # to get_position(). undef $D; } # # Come here if we see , but *not* an arrow key or other # mapped sequence, when a positioning keystroke is expected. # sub F_ViPositionEsc { my($count, $ord) = @_; # We got in vipos mode. Put back onto the # input stream and terminate the positioning command. unshift(@Pending, pack('c', $ord)); &F_ViNonPosition; } # Interpret vi positioning commands sub get_position { my ($count, $ord, $fullline_ord, $poshash) = @_; # Manipulate a copy of the cursor, not the real thing local $D = $D; # $ord (first character of positioning command) is an optional argument. $ord = ord(&getc_with_pending) if !defined $ord; # Detect double character (for full-line operation, e.g. dd) return -1 if defined $fullline_ord and $ord == $fullline_ord; my $re = $poshash->{$ord}; if ($re) { my $c = pack('c', $ord); if (lc($c) eq 'b') { &backward_scan($count, $re); } else { &forward_scan($count, $re); } } else { # Move the local copy of the cursor &do_command($var_EditingMode{'vipos'}, $count, $ord); } # Return the new cursor (undef if illegal command) $D; } ## ## Go to first non-space character of line. ## sub F_ViFirstWord { $D = 0; &forward_scan(1, q{\s+}); } sub forward_scan { my($count, $re) = @_; while ($count--) { last unless substr($line, $D) =~ m{^($re)}; $D += length($1); } } sub backward_scan { my($count, $re) = @_; while ($count--) { last unless substr($line, 0, $D) =~ m{($re)$}; $D -= length($1); } } # Note: like the emacs case transforms, this doesn't work for # two-byte characters. sub F_ViToggleCase { my($count) = @_; &save_dot_buf(@_); while ($count-- > 0) { substr($line, $D, 1) =~ tr/A-Za-z/a-zA-Z/; &F_ForwardChar(1); if (&at_end_of_line) { &F_BackwardChar(1); last; } } } # Go to the numbered history line, as listed by the 'H' command, i.e. the # current $line is line 1, the youngest line in @rl_History is 2, etc. sub F_ViHistoryLine { my($n) = @_; &get_line_from_history(@rl_History - $n + 1); } sub get_line_from_history { my($n) = @_; return &F_Ding if $n < 0 or $n > @rl_History; return if $n == $rl_HistoryIndex; # If we're moving from the currently-edited line, save it for later. $line_for_revert = $line if $rl_HistoryIndex == @rl_History; # Get line from history buffer (or from saved edit line). $line = ($n == @rl_History) ? $line_for_revert : $rl_History[$n]; $D = $Vi_mode ? 0 : length $line; # Subsequent 'U' will bring us back to this point. $Vi_undo_all_state = savestate() if $Vi_mode; $rl_HistoryIndex = $n; } sub F_PrintHistory { my($count) = @_; $count = 20 if $count == 1; # Default - assume 'H', not '1H' my $end = $rl_HistoryIndex + $count/2; $end = @rl_History if $end > @rl_History; my $start = $end - $count + 1; $start = 0 if $start < 0; my $lmh = length $rl_MaxHistorySize; my $lspace = ' ' x ($lmh+3); my $hdr = "$lspace-----"; $hdr .= " (Use ESC UP to retrieve command ) -----" unless $Vi_mode; $hdr .= " (Use 'G' to retrieve command ) -----" if $Vi_mode; local ($\, $,) = ('',''); print "\n$hdr\n"; print $lspace, ". . .\n" if $start > 0; my $i; my $shift = ($Vi_mode != 0); for $i ($start .. $end) { print + ($i == $rl_HistoryIndex) ? '>' : ' ', sprintf("%${lmh}d: ", @rl_History - $i + $shift), ($i < @rl_History) ? $rl_History[$i] : ($i == $rl_HistoryIndex) ? $line : $line_for_revert, "\n"; } print $lspace, ". . .\n" if $end < @rl_History; print "$hdr\n"; &force_redisplay(); &F_ViInput() if $line eq '' && $Vi_mode; } # Redisplay the line, without attempting any optimization sub force_redisplay { local $force_redraw = 1; &redisplay(@_); } # Search history for matching string. As with vi in nomagic mode, the # ^, $, \<, and \> positional assertions, the \* quantifier, the \. # character class, and the \[ character class delimiter all have special # meaning here. sub F_ViSearch { my($n, $ord) = @_; my $c = pack('c', $ord); my $str = &get_vi_search_str($c); if (!defined $str) { # Search aborted by deleting the '/' at the beginning of the line return &F_ViInput() if $line eq ''; return(); } # Null string repeats last search if ($str eq '') { return &F_Ding unless defined $Vi_search_re; } else { # Convert to a regular expression. Interpret $str Like vi in nomagic # mode: '^', '$', '\<', and '\>' positional assertions, '\*' # quantifier, '\.' and '\[]' character classes. my @chars = ($str =~ m{(\\?.)}g); my(@re, @tail); unshift(@re, shift(@chars)) if @chars and $chars[0] eq '^'; push (@tail, pop(@chars)) if @chars and $chars[-1] eq '$'; my $in_chclass; my %chmap = ( '\<' => '\b(?=\w)', '\>' => '(?<=\w)\b', '\*' => '*', '\[' => '[', '\.' => '.', ); my $ch; foreach $ch (@chars) { if ($in_chclass) { # Any backslashes in vi char classes are literal push(@re, "\\") if length($ch) > 1; push(@re, $ch); $in_chclass = 0 if $ch =~ /\]$/; } else { push(@re, (length $ch == 2) ? ($chmap{$ch} || $ch) : ($ch =~ /^\w$/) ? $ch : ("\\", $ch)); $in_chclass = 1 if $ch eq '\['; } } my $re = join('', @re, @tail); $Vi_search_re = q{$re}; } local $reverse = $Vi_search_reverse = ($c eq '/') ? 1 : 0; &do_vi_search(); } sub F_ViRepeatSearch { my($n, $ord) = @_; my $c = pack('c', $ord); return &F_Ding unless defined $Vi_search_re; local $reverse = $Vi_search_reverse; $reverse ^= 1 if $c eq 'N'; &do_vi_search(); } ## returns a new $i or -1 if not found. sub vi_search { my ($i) = @_; return -1 if $i < 0 || $i > $#rl_History; ## for safety while (1) { return $i if $rl_History[$i] =~ /$Vi_search_re/; if ($reverse) { return -1 if $i-- == 0; } else { return -1 if $i++ == $#rl_History; } } } sub do_vi_search { my $incr = $reverse ? -1 : 1; my $i = &vi_search($rl_HistoryIndex + $incr); return &F_Ding if $i < 0; # Not found. $rl_HistoryIndex = $i; ($D, $line) = (0, $rl_History[$rl_HistoryIndex]); } # Using local $line, $D, and $prompt, get and return the string to search for. sub get_vi_search_str { my($c) = @_; local $prompt = $prompt . $c; local ($line, $D) = ('', 0); &redisplay(); # Gather a search string in our local $line. while ($lastcommand ne 'F_ViEndSearch') { &do_command($var_EditingMode{'visearch'}, 1, ord(&getc_with_pending)); &redisplay(); # We've backspaced past beginning of line return undef if !defined $line; } $line; } sub F_ViEndSearch {} sub F_ViSearchBackwardDeleteChar { if ($line eq '') { # Backspaced past beginning of line - terminate search mode undef $line; } else { &F_BackwardDeleteChar(@_); } } ## ## Kill entire line and enter input mode ## sub F_ViChangeEntireLine { &start_dot_buf(@_); kill_text(0, length($line), 1); &vi_input_mode; } ## ## Kill characters and enter input mode ## sub F_ViChangeChar { &start_dot_buf(@_); &F_DeleteChar(@_); &vi_input_mode; } sub F_ViReplaceChar { &start_dot_buf(@_); my $c = &getc_with_pending; $c = &getc_with_pending if $c eq "\cV"; # ctrl-V return &F_ViCommandMode if $c eq "\e"; &end_dot_buf; local $InsertMode = 0; local $D = $D; # Preserve cursor position &F_SelfInsert(1, ord($c)); } ## ## Kill from cursor to end of line and enter input mode ## sub F_ViChangeLine { &start_dot_buf(@_); &F_KillLine(@_); &vi_input_mode; } sub F_ViDeleteLine { &save_dot_buf(@_); &F_KillLine(@_); } sub F_ViPut { my($count) = @_; &save_dot_buf(@_); my $text2add = $KillBuffer x $count; my $ll = length($line); $D++; $D = $ll if $D > $ll; substr($line, $D, 0) = $KillBuffer x $count; $D += length($text2add) - 1; } sub F_ViPutBefore { &save_dot_buf(@_); &TextInsert($_[0], $KillBuffer); } sub F_ViYank { my($count, $ord) = @_; my $pos = &get_position($count, undef, $ord, $Vi_yank_patterns); &F_Ding if !defined $pos; if ($pos < 0) { # yy &F_ViYankLine; } else { my($from, $to) = ($pos > $D) ? ($D, $pos) : ($pos, $D); $KillBuffer = substr($line, $from, $to-$from); } } sub F_ViYankLine { $KillBuffer = $line; } sub F_ViInput { @_ = (1, ord('i')) if !@_; &start_dot_buf(@_); &vi_input_mode; } sub F_ViBeginInput { &start_dot_buf(@_); &F_BeginningOfLine; &vi_input_mode; } sub F_ViReplaceMode { &start_dot_buf(@_); $InsertMode = 0; $var_EditingMode = $var_EditingMode{'vi'}; $Vi_mode = 1; } sub vi_input_mode { $InsertMode = 1; $var_EditingMode = $var_EditingMode{'vi'}; $Vi_mode = 1; } # The previous keystroke was an escape, but the sequence was not recognized # as a mapped sequence (like an arrow key). Enter vi comand mode and # process this keystroke. sub F_ViAfterEsc { my($n, $ord) = @_; &F_ViCommandMode; &do_command($var_EditingMode, 1, $ord); } sub F_ViAppend { &start_dot_buf(@_); &vi_input_mode; &F_ForwardChar; } sub F_ViAppendLine { &start_dot_buf(@_); &vi_input_mode; &F_EndOfLine; } sub F_ViCommandMode { $var_EditingMode = $var_EditingMode{'vicmd'}; $Vi_mode = 1; } sub F_ViAcceptInsert { local $in_accept_line = 1; &F_ViEndInsert; &F_ViAcceptLine; } sub F_ViEndInsert { if ($Dot_buf) { if ($line eq '' and $Dot_buf->[0] eq 'i') { # We inserted nothing into an empty $line - assume it was a # &F_ViInput() call with no arguments, and don't save command. undef $Dot_buf; } else { # Regardless of which keystroke actually terminated this insert # command, replace it with an in the dot buffer. @{$Dot_buf}[-1] = "\e"; &end_dot_buf; } } &F_ViCommandMode; # Move cursor back to the last inserted character, but not when # we're about to accept a line of input &F_BackwardChar(1) unless $in_accept_line; } sub F_ViDigit { my($count, $ord) = @_; my $n = 0; my $ord0 = ord('0'); while (1) { $n *= 10; $n += $ord - $ord0; my $c = &getc_with_pending; return unless defined $c; $ord = ord($c); last unless $c =~ /^\d$/; } $n *= $count; # So 2d3w deletes six words $n = $rl_max_numeric_arg if $n > $rl_max_numeric_arg; &do_command($var_EditingMode, $n, $ord); } sub F_ViComplete { my($n, $ord) = @_; $Dot_state = savestate(); # Completion is undo-able undef $Dot_buf; # but not redo-able my $ch; while (1) { &F_Complete() or return; # Vi likes the cursor one character right of where emacs like it. &F_ForwardChar(1); &force_redisplay(); # Look ahead to the next input keystroke. $ch = &getc_with_pending(); last unless ord($ch) == $ord; # Not a '\' - quit. # Another '\' was typed - put the cursor back where &F_Complete left # it, and try again. &F_BackwardChar(1); $lastcommand = 'F_Complete'; # Play along with &F_Complete's kludge } unshift(@Pending, $ch); # Unget the lookahead keystroke # Successful completion - enter input mode with cursor beyond end of word. &vi_input_mode; } sub F_ViInsertPossibleCompletions { $Dot_state = savestate(); # Completion is undo-able undef $Dot_buf; # but not redo-able &complete_internal('*') or return; # Successful completion - enter input mode with cursor beyond end of word. &F_ForwardChar(1); &vi_input_mode; } sub F_ViPossibleCompletions { # List possible completions &complete_internal('?'); # Enter input mode with cursor where we left off. &F_ForwardChar(1); &vi_input_mode; } sub F_SetMark { $rl_mark = $D; pos $line = $rl_mark; $line_rl_mark = $rl_HistoryIndex; $force_redraw = 1; } sub F_ExchangePointAndMark { return F_Ding unless $line_rl_mark == $rl_HistoryIndex; ($rl_mark, $D) = ($D, $rl_mark); pos $line = $rl_mark; $D = length $line if $D > length $line; $force_redraw = 1; } sub F_KillRegion { return F_Ding unless $line_rl_mark == $rl_HistoryIndex; $rl_mark = length $line if $rl_mark > length $line; kill_text($rl_mark, $D, 1); $line_rl_mark = -1; # Disable mark } sub F_CopyRegionAsKill { return F_Ding unless $line_rl_mark == $rl_HistoryIndex; $rl_mark = length $line if $rl_mark > length $line; my ($s, $e) = ($rl_mark, $D); ($s, $e) = ($e, $s) if $s > $e; $ThisCommandKilledText = 1 + $s; $KillBuffer = '' if !$LastCommandKilledText; $KillBuffer .= substr($line, $s, $e - $s); } sub clipboard_set { my $in = shift; if ($^O eq 'os2') { eval { require OS2::Process; OS2::Process::ClipbrdText_set($in); # Do not disable \r\n-conversion 1 } and return; } elsif ($^O eq 'MSWin32') { eval { require Win32::Clipboard; Win32::Clipboard::Set($in); 1 } and return; } my $mess; if ($ENV{RL_CLCOPY_CMD}) { $mess = "Writing to pipe `$ENV{RL_CLCOPY_CMD}'"; open COPY, "| $ENV{RL_CLCOPY_CMD}" or warn("$mess: $!"), return; } elsif (defined $ENV{HOME}) { $mess = "Writing to file `$ENV{HOME}/.rl_cutandpaste'"; open COPY, "> $ENV{HOME}/.rl_cutandpaste" or warn("$mess: $!"), return; } else { return; } print COPY $in; close COPY or warn("$mess: closing $!"); } sub F_CopyRegionAsKillClipboard { return clipboard_set($line) unless $line_rl_mark == $rl_HistoryIndex; &F_CopyRegionAsKill; clipboard_set($KillBuffer); } sub F_KillRegionClipboard { &F_KillRegion; clipboard_set($KillBuffer); } sub F_YankClipboard { remove_selection(); my $in; if ($^O eq 'os2') { eval { require OS2::Process; $in = OS2::Process::ClipbrdText(); $in =~ s/\r\n/\n/g; # With old versions, or what? } } elsif ($^O eq 'MSWin32') { eval { require Win32::Clipboard; $in = Win32::Clipboard::GetText(); $in =~ s/\r\n/\n/g; # is this needed? } } else { my $mess; if ($ENV{RL_PASTE_CMD}) { $mess = "Reading from pipe `$ENV{RL_PASTE_CMD}'"; open PASTE, "$ENV{RL_PASTE_CMD} |" or warn("$mess: $!"), return; } elsif (defined $ENV{HOME}) { $mess = "Reading from file `$ENV{HOME}/.rl_cutandpaste'"; open PASTE, "< $ENV{HOME}/.rl_cutandpaste" or warn("$mess: $!"), return; } if ($mess) { local $/; $in = ; close PASTE or warn("$mess, closing: $!"); } } if (defined $in) { $in =~ s/\n+$//; return &TextInsert($_[0], $in); } &TextInsert($_[0], $KillBuffer); } sub F_BeginUndoGroup { push @undoGroupS, $#undo; } sub F_EndUndoGroup { return F_Ding unless @undoGroupS; my $last = pop @undoGroupS; return unless $#undo > $last + 1; my $now = pop @undo; $#undo = $last; push @undo, $now; } sub F_DoNothing { # E.g., reset digit-argument 1; } sub F_ForceMemorizeDigitArgument { $memorizedArg = shift; } sub F_MemorizeDigitArgument { return if defined $memorizedArg; $memorizedArg = shift; } sub F_UnmemorizeDigitArgument { $memorizedArg = undef; } sub F_MemorizePos { $memorizedPos = $D; } # It is assumed that F_MemorizePos was called, then something was inserted, # then F_MergeInserts is called with a prefix argument to multiply # insertion by sub F_MergeInserts { my $n = shift; return F_Ding unless defined $memorizedPos and $n > 0; my ($b, $e) = ($memorizedPos, $D); ($b, $e) = ($e, $b) if $e < $b; if ($n) { substr($line, $e, 0) = substr($line, $b, $e - $b) x ($n - 1); } else { substr($line, $b, $e - $b) = ''; } $D = $b + ($e - $b) * $n; } sub F_ResetDigitArgument { return F_Ding unless defined $memorizedArg; my $in = &getc_with_pending; return unless defined $in; my $ord = ord $in; local(*KeyMap) = $var_EditingMode; &do_command(*KeyMap, $memorizedArg, $ord); } sub F_BeginPasteGroup { my $c = shift; $memorizedArg = $c unless defined $memorizedArg; F_BeginUndoGroup(1); $memorizedPos = $D; } sub F_EndPasteGroup { my $c = $memorizedArg; undef $memorizedArg; $c = 1 unless defined $c; F_MergeInserts($c); F_EndUndoGroup(1); } sub F_BeginEditGroup { $memorizedArg = shift; F_BeginUndoGroup(1); } sub F_EndEditGroup { undef $memorizedArg; F_EndUndoGroup(1); } sub F_Repaint { rl_redisplay(); } 1; __END__