10673 lines
328 KiB
Perl
Executable File
10673 lines
328 KiB
Perl
Executable File
#!/usr/bin/perl -s
|
|
#########################################################################
|
|
#
|
|
# TTYverse - A command-line fediverse client
|
|
# Originally based on TTYtter by Cameron Kaiser
|
|
#
|
|
# DERIVATIVE WORK: This is a derivative work of TTYtter v2.1
|
|
# Original TTYtter (c)2007-2012 Cameron Kaiser (and contributors)
|
|
# Original source: http://www.floodgap.com/software/ttytter/
|
|
#
|
|
# Fediverse modifications and migration from Twitter to Mastodon/ActivityPub/fediverse
|
|
# This derivative work distributed under the Floodgap Free Software License
|
|
# http://www.floodgap.com/software/ffsl/
|
|
#
|
|
# If you like and want to support TTYverse, please consider becoming a patron:
|
|
# https://patreon.com/stormux
|
|
#
|
|
# 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;
|
|
|
|
use File::Path qw(make_path);
|
|
|
|
|
|
# XDG configuration will be set up in the BEGIN block
|
|
|
|
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 = "TTYverse";
|
|
$TTYverse_VERSION = "2025.07.29";
|
|
# this is kludgy, yes.
|
|
$LANG = $ENV{'LANG'} || $ENV{'GDM_LANG'} || $ENV{'LC_CTYPE'} ||
|
|
$ENV{'ALL'};
|
|
$my_version_string = $TTYverse_VERSION;
|
|
(warn ("$my_version_string\n"), exit) if ($version);
|
|
|
|
# Set up XDG directories early for -create-rc and extensions
|
|
our $config = ($ENV{'XDG_CONFIG_HOME'} || "$ENV{'HOME'}/.config") . '/ttyverse';
|
|
our $data = ($ENV{'XDG_DATA_HOME'} || "$ENV{'HOME'}/.local/share") . '/ttyverse';
|
|
|
|
# Check if directories exist; if not, create them
|
|
unless (-d $config) {
|
|
eval { require File::Path; File::Path::make_path($config) };
|
|
if ($@) {
|
|
die "Failed to create config directory: $@";
|
|
}
|
|
}
|
|
|
|
unless (-d $data) {
|
|
eval { require File::Path; File::Path::make_path("$data/extensions", "$data/sounds/default") };
|
|
if ($@) {
|
|
die "Failed to create data directory: $@";
|
|
}
|
|
}
|
|
|
|
# Handle -createrc option early
|
|
if ($createrc) {
|
|
my $rc_path = "$config/ttyverserc";
|
|
|
|
if (-e $rc_path) {
|
|
print STDERR "-- RC file already exists: $rc_path\n";
|
|
print STDERR "-- Remove it first or use a different RC filename\n";
|
|
exit 0;
|
|
}
|
|
|
|
print STDERR "-- Creating default RC file: $rc_path\n";
|
|
|
|
open(my $rc_fh, '>', $rc_path) or die "-- Can't create RC file: $!\n";
|
|
|
|
print $rc_fh <<'EOF';
|
|
# TTYverse Configuration File
|
|
# Uncomment and modify any option you want to change from the default
|
|
# For boolean options, use 1 to enable, 0 to disable
|
|
# Lines starting with # are ignored
|
|
|
|
# === CONNECTION SETTINGS ===
|
|
# fediverseserver=mastodon.social # Your fediverse server
|
|
# ssl=1 # Use SSL/HTTPS (recommended)
|
|
# authtype=oauth2 # Always oauth2 (fediverse standard)
|
|
# apibase= # Custom API base URL (auto-detected)
|
|
# oauthbase= # Custom OAuth base URL (auto-detected)
|
|
|
|
# === AUTHENTICATION ===
|
|
# keyfile=~/.config/ttyverse/key # Path to OAuth key file
|
|
# anonymous=0 # Anonymous mode (not supported for fediverse)
|
|
|
|
# === TIMELINE SETTINGS ===
|
|
# pause=auto # Auto-refresh rate (seconds, or 'auto')
|
|
# backload=30 # Number of posts to load initially
|
|
# wrap=120 # Text wrapping width
|
|
# timestamp=0 # Show timestamps (0=off, 1=on, format string for custom)
|
|
# noreblogs=0 # Hide boost/reblog posts
|
|
# notimeline=0 # Disable timeline display
|
|
# searchhits=20 # Number of search results to show
|
|
|
|
# === DISPLAY SETTINGS ===
|
|
# ansi=1 # Use ANSI colors
|
|
# noansi=0 # Force disable colors
|
|
# verbose=0 # Show debug information
|
|
# superverbose=0 # Even more debug information
|
|
# silent=0 # Reduce output messages
|
|
# readline=0 # Disable readline for input (enabled by default)
|
|
# readlinerepaint=0 # Repaint readline on signals
|
|
# vcheck=1 # Check for updates on startup
|
|
# noprompt=0 # Disable interactive prompts
|
|
# newline=0 # Add extra newlines
|
|
|
|
# === POST SETTINGS ===
|
|
# post_visibility=public # Default post visibility (public, unlisted, private, direct)
|
|
# linelength=5000 # Maximum post length
|
|
# autosplit=0 # Auto-split long posts
|
|
# slowpost=0 # Slower posting for rate limiting
|
|
# verify=0 # Verify posts before sending
|
|
|
|
# === COLORS ===
|
|
# colourprompt=CYAN # Prompt color
|
|
# colourme=YELLOW # Your posts color
|
|
# colourdm=GREEN # Direct message color
|
|
# colourreply=RED # Reply posts color
|
|
# colourwarn=MAGENTA # Warning message color
|
|
# coloursearch=CYAN # Search result color
|
|
# colourlist=OFF # List posts color
|
|
# colourdefault=OFF # Default text color
|
|
|
|
# === STREAMING API ===
|
|
# dostream=0 # Enable streaming API (real-time updates)
|
|
# nostreamreplies=0 # Don't stream replies
|
|
# streamallreplies=0 # Stream all replies (not just to you)
|
|
# eventbuf=0 # Event buffer size for streaming
|
|
|
|
# === DIRECT MESSAGES ===
|
|
# dmpause=0 # DM refresh rate (0=use main pause)
|
|
|
|
# === INTERACTION ===
|
|
# mentions=0 # Show mentions in timeline
|
|
# synch=0 # Synchronous mode (blocks on requests)
|
|
# maxhist=19 # Command history size
|
|
# hold=0 # Hold mode for piped input
|
|
# daemon=0 # Run as daemon (background)
|
|
# script=0 # Script mode (non-interactive)
|
|
|
|
# === LOCATION ===
|
|
# location=0 # Include location in posts
|
|
# lat= # Latitude for location
|
|
# long= # Longitude for location
|
|
|
|
# === NOTIFICATIONS ===
|
|
# notifies= # Comma-separated list of notification types
|
|
# notifyquiet=0 # Quiet notifications
|
|
# notifytype= # Type of notifications to send
|
|
|
|
# === FILTERING ===
|
|
# track= # Track keywords (space-separated)
|
|
# filter= # Filter out posts containing these terms
|
|
# notrack=0 # Disable tracking
|
|
# filterusers= # Filter posts from specific users
|
|
# filterats= # Filter posts with specific @mentions
|
|
# filterrts= # Filter boosts
|
|
# filteratonly= # Only show posts with @mentions
|
|
# filterflags= # Filter flags
|
|
# nofilter=0 # Disable all filtering
|
|
|
|
# === LISTS ===
|
|
# lists= # Comma-separated list of lists to follow
|
|
|
|
# === URL HANDLING ===
|
|
# urlopen=echo %U # Command to open URLs (%U = URL) - deprecated, use cli_browser/gui_browser
|
|
# cli_browser= # CLI browser (w3m, elinks, lynx) - auto-detected if empty
|
|
# gui_browser= # GUI browser (xdg-open, firefox, etc) - auto-detected if empty
|
|
# shoreblogurl=http://is.gd/api.php?longurl= # URL shortening service
|
|
|
|
# === SYSTEM SETTINGS ===
|
|
# seven=0 # 7-bit mode for older terminals
|
|
# oldperl=0 # Compatibility mode for old Perl
|
|
# signals_use_posix=0 # Use POSIX signals (auto-detected)
|
|
# nocounter=0 # Disable character counter
|
|
# exception_is_maskable=0 # Allow masking exceptions
|
|
# simplestart=0 # Simple startup mode
|
|
# noratelimit=0 # Ignore rate limiting
|
|
# notco=0 # Disable t.co URL expansion
|
|
|
|
# === ADVANCED/TECHNICAL ===
|
|
# runcommand= # Command to run on startup
|
|
# twarg= # Legacy argument (unused)
|
|
# user= # Username override
|
|
# leader= # Command leader character
|
|
|
|
# === EXTENSION SETTINGS ===
|
|
# Extensions can be loaded with the -exts option
|
|
# Extension preferences use the extpref_ prefix:
|
|
# extpref_sound_command=paplay # Sound system command
|
|
# extpref_tts_synthesizer=espeak # Text-to-speech engine
|
|
# extpref_tts_language=en-US # TTS language
|
|
# extpref_tts_rate=175 # TTS speaking rate
|
|
# extpref_tts_variant= # TTS voice variant
|
|
EOF
|
|
|
|
close($rc_fh);
|
|
print STDERR "-- RC file created successfully!\n";
|
|
print STDERR "-- Edit $rc_path to customize your settings\n";
|
|
print STDERR "-- Restart TTYverse to use the new settings\n";
|
|
exit 0;
|
|
}
|
|
|
|
$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;
|
|
|
|
|
|
%opts_boolean = map { $_ => 1 } qw(
|
|
ansi noansi verbose superverbose ttytteristas noprompt
|
|
seven silent hold daemon script anonymous readline ssl
|
|
newline vcheck verify noratelimit notrack noreblogs 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 shoreblogurl
|
|
apibase fediverseserver 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 reblogurl boostsbyurl dmidurl
|
|
statusliurl followliurl leaveliurl followersurl
|
|
oauthurl oauthauthurl oauthaccurl oauthbase wtrendurl
|
|
atrendurl lookupidurl
|
|
); %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 dmmarkread superverbose ansi verbose
|
|
update uurl rurl wurl avatar ttytteristas frurl track
|
|
rlurl noprompt shoreblogurl newline wrap verify autosplit
|
|
notimeline queryurl fediverseserver colourprompt colourme
|
|
colourdm colourreply colourwarn coloursearch colourlist idurl
|
|
urlopen cli_browser gui_browser 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 reblogurl boostsbyurl wtrendurl
|
|
statusliurl followliurl leaveliurl dmidurl nostreamreplies
|
|
frupdurl filterusers filterats filterrts filterflags
|
|
filteratonly nofilter
|
|
); %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
|
|
noreblogs 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
|
|
createrc
|
|
); %valid = (%opts_can_set, %opts_others);
|
|
$rc = (defined($rc) && length($rc)) ? $rc : "";
|
|
unless ($norc) {
|
|
my $rcf =
|
|
($rc =~ m#^/#) ? $rc : "$config/ttyverserc${rc}";
|
|
if (open(W, $rcf)) {
|
|
# 5.14 sets this lazily, so this gives us a way out
|
|
eval 'binmode(W, ":utf8")' unless ($seven);
|
|
while(<W>) {
|
|
chomp;
|
|
next if (/^\s*$/ || /^#/);
|
|
s/^-//;
|
|
($key, $value) = split(/\=/, $_, 2);
|
|
if ($key eq 'rc') {
|
|
warn "** that's stupid, setting rc in an rc file\n";
|
|
} elsif ($key eq 'norc') {
|
|
warn "** that's dumb, using norc in an rc file\n";
|
|
} elsif (length $$key) {
|
|
; # carry on
|
|
} elsif ($valid{$key} && !length($$key)) {
|
|
$$key = $value;
|
|
} elsif ($key =~ /^extpref_/) {
|
|
$$key = $value;
|
|
} elsif (!$valid{$key}) {
|
|
warn "** setting $key not supported in this version\n";
|
|
}
|
|
}
|
|
close(W);
|
|
} elsif (length($rc)) {
|
|
die("couldn't access rc file $rcf: $!\n".
|
|
"to use defaults, use -norc or don't specify the -rc option.\n\n");
|
|
}
|
|
}
|
|
warn "** -twarg is deprecated\n" if (length($twarg));
|
|
$seven ||= 0;
|
|
$oldperl ||= 0;
|
|
$parent = $$;
|
|
$script = 1 if (length($runcommand));
|
|
$supreturnto = $verbose + 0;
|
|
$postbreak_time = 0;
|
|
$postbreak_count = 0;
|
|
|
|
# our minimum official support is now 5.8.6.
|
|
if ($] < 5.008006 && !$oldperl) {
|
|
die(<<"EOF");
|
|
|
|
*** you are using a version of Perl in "extended" support: $] ***
|
|
the minimum tested version of Perl now required by TTYverse is 5.8.6.
|
|
|
|
Perl 5.005 thru 5.8.5 probably can still run TTYverse, 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 TTYverse 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;
|
|
|
|
# Initialize SSL and HTTP protocol early for endpoint configuration
|
|
$ssl ||= 1;
|
|
$http_proto = ($ssl) ? 'https' : 'http';
|
|
|
|
# Configure all API endpoints for a specific fediverse server
|
|
sub configure_fediverse_endpoints {
|
|
my $server = shift;
|
|
|
|
# Update base URLs
|
|
$oauthbase = "${http_proto}://${server}";
|
|
$apibase = "${http_proto}://${server}/api/v1";
|
|
|
|
# Update all API endpoints to use the new server
|
|
$url = "${apibase}/timelines/home";
|
|
$oauthurl = "${oauthbase}/api/v1/apps";
|
|
$oauthauthurl = "${oauthbase}/oauth/authorize";
|
|
$oauthaccurl = "${oauthbase}/oauth/token";
|
|
$credurl = "${apibase}/accounts/verify_credentials";
|
|
$update = "${apibase}/statuses";
|
|
$rurl = "${apibase}/timelines/home";
|
|
$uurl = "${apibase}/accounts/%I/statuses";
|
|
$idurl = "${apibase}/statuses/%I";
|
|
$delurl = "${apibase}/statuses/%I";
|
|
$reblogurl = "${apibase}/statuses/%I/reblog";
|
|
$wurl = "${apibase}/accounts/%I";
|
|
$followurl = "${apibase}/accounts/%I/follow";
|
|
$leaveurl = "${apibase}/accounts/%I/unfollow";
|
|
$blockurl = "${apibase}/accounts/%I/block";
|
|
$blockdelurl = "${apibase}/accounts/%I/unblock";
|
|
$favurl = "${apibase}/statuses/%I/favourite";
|
|
$favdelurl = "${apibase}/statuses/%I/unfavourite";
|
|
$blockingurl = "${apibase}/accounts/relationships?id[]=%I";
|
|
$dmurl = "${apibase}/conversations";
|
|
$directurl = "${apibase}/conversations";
|
|
$listurl = "${apibase}/lists/%I/accounts";
|
|
$murl = "${apibase}/timelines/home";
|
|
$streamurl = "${oauthbase}/api/v1/streaming/user";
|
|
$publicurl = "${apibase}/timelines/public";
|
|
$searchurl = "${oauthbase}/api/v2/search";
|
|
$trendsurl = "${apibase}/trends";
|
|
}
|
|
|
|
|
|
# XDG config directory already set up earlier
|
|
|
|
# Check for deprecated -keyf parameter and error out
|
|
if (defined($keyf)) {
|
|
die("** Error: -keyf is deprecated. Use -keyfile instead.\n** Example: ./ttyverse.pl -keyfile test -oauthwizard\n");
|
|
}
|
|
|
|
# Handle command line argument parsing for keyfile
|
|
# Perl's -s flag makes -keyfile without = set $keyfile=1, so fix this
|
|
if (defined($keyfile) && $keyfile eq '1' && @ARGV && $ARGV[0] !~ /^-/) {
|
|
$keyfile = shift @ARGV; # Take the next argument as the keyfile path
|
|
# If it's a relative path, put it in the config directory
|
|
if ($keyfile !~ m|^/|) { # Not an absolute path
|
|
$keyfile = "$config/$keyfile";
|
|
}
|
|
# Process remaining flags that Perl's -s might have missed
|
|
while (@ARGV && $ARGV[0] =~ /^-(\w+)$/) {
|
|
my $flag = $1;
|
|
shift @ARGV;
|
|
if ($flag eq 'oauthwizard') { $oauthwizard = 1; }
|
|
elsif ($flag eq 'retoke') { $retoke = 1; }
|
|
elsif ($flag eq 'verbose') { $verbose = 1; }
|
|
# Add other flags as needed
|
|
}
|
|
}
|
|
|
|
# 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
|
|
my $user_specified_keyfile = length($keyfile) ? 1 : 0;
|
|
# Only set default keyfile path if none specified
|
|
if (!$keyfile) {
|
|
$keyfile = "$config/key";
|
|
}
|
|
$whine = $user_specified_keyfile;
|
|
$attempted_keyfile = $keyfile;
|
|
if (!length($oauthkey) && !length($oauthsecret) # set later
|
|
&& !length($tokenkey)
|
|
&& !length($tokensecret) && !$oauthwizard) {
|
|
my $keybuf = '';
|
|
if(open(W, $keyfile)) {
|
|
while(<W>) {
|
|
chomp;
|
|
s/\s+//g;
|
|
$keybuf .= $_;
|
|
}
|
|
close(W);
|
|
my (@pairs) = split(/\&/, $keybuf);
|
|
foreach(@pairs) {
|
|
my (@pair) = split(/\=/, $_, 2);
|
|
# OAuth 1.0a format (fediverse legacy)
|
|
$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');
|
|
# OAuth 2.0 format (Mastodon/fediverse)
|
|
$oauthkey = $pair[1]
|
|
if ($pair[0] eq 'client_id');
|
|
$oauthsecret = $pair[1]
|
|
if ($pair[0] eq 'client_secret');
|
|
$tokenkey = $pair[1]
|
|
if ($pair[0] eq 'access_token');
|
|
$oauth2_refresh_token = $pair[1]
|
|
if ($pair[0] eq 'refresh_token');
|
|
# Load the server from keyfile for OAuth 2.0
|
|
if ($pair[0] eq 'server') {
|
|
$fediverseserver = $pair[1];
|
|
&configure_fediverse_endpoints($fediverseserver);
|
|
}
|
|
}
|
|
# Validate OAuth credentials - OAuth 2.0 doesn't need tokensecret
|
|
my $oauth_valid = 0;
|
|
if (length($oauthkey) && length($oauthsecret) && length($tokenkey)) {
|
|
# Fediverse uses OAuth 2.0 format (no token secret needed)
|
|
$oauth_valid = 1;
|
|
$authtype = 'oauth2';
|
|
}
|
|
die("** tried to load OAuth tokens from $keyfile\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")
|
|
unless ($oauth_valid);
|
|
} else {
|
|
die("** couldn't open keyfile $keyfile: $!\n".
|
|
"if you want to run the OAuth wizard to create this file, add ".
|
|
"-oauthwizard\n")
|
|
if ($whine);
|
|
$keyfile = ''; # 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)
|
|
our %readline_completion = ();
|
|
$readline = 1 if (!defined $readline); # Enable readline by default
|
|
print STDOUT "-- DEBUG: readline=$readline, silent=$silent, script=$script\n" if ($verbose);
|
|
if ($readline && !$silent && !$script) {
|
|
$ENV{"PERL_RL"} = "Gnu" if (!length($ENV{'PERL_RL'}));
|
|
print STDOUT "-- DEBUG: PERL_RL set to: $ENV{'PERL_RL'}\n" if ($verbose);
|
|
print STDOUT "-- DEBUG: TERM environment: $ENV{'TERM'}\n" if ($verbose);
|
|
eval
|
|
'use Term::ReadLine; $termrl = new Term::ReadLine ("TTYverse", \*STDIN, \*STDOUT)';
|
|
if ($@) {
|
|
print STDOUT "-- ReadLine not available, disabling readline features\n" if ($verbose);
|
|
$readline = 0;
|
|
$termrl = undef;
|
|
} else {
|
|
$stdout = $termrl->OUT || \*STDOUT;
|
|
$stdin = $termrl->IN || \*STDIN;
|
|
print $stdout "-- DEBUG: ReadLine implementation: " . $termrl->ReadLine . "\n" if ($verbose);
|
|
print $stdout "-- DEBUG: ReadLine features: " . join(", ", $termrl->Features) . "\n" if ($verbose);
|
|
}
|
|
}
|
|
if (!$readline || $silent || $script || !$termrl) {
|
|
$stdout = \*STDOUT;
|
|
$stdin = \*STDIN;
|
|
} else {
|
|
$readline = '' if ($readline eq '1');
|
|
$readline =~ s/^"//; # for optimizer
|
|
$readline =~ s/"$//;
|
|
#$termrl->Attribs()->{'autohistory'} = undef; # not yet
|
|
# Merge readline config completions with existing completions (don't overwrite)
|
|
my %config_completions = map {$_ => 1} split(/\s+/, $readline);
|
|
%original_readline = %config_completions;
|
|
# Add config completions to our existing hash instead of replacing it
|
|
my $before_count = scalar(keys %readline_completion);
|
|
%readline_completion = (%readline_completion, %config_completions);
|
|
my $after_count = scalar(keys %readline_completion);
|
|
print $stdout "-- merged " . scalar(keys %config_completions) . " config completions (before: $before_count, after: $after_count)\n" if ($verbose);
|
|
# readline repaint can't be tested here. we cache our
|
|
# result later.
|
|
}
|
|
$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 fediverse'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.
|
|
|
|
TTYverse 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 TTYverse. run one of
|
|
|
|
export PERL_SIGNALS=unsafe # sh, bash, ksh, etc.
|
|
setenv PERL_SIGNALS unsafe # csh, tcsh, etc.
|
|
|
|
and restart TTYverse, 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);
|
|
|
|
# Term::ReadLine::Gnu is well-maintained and compatible
|
|
if ($termrl && $termrl->ReadLine eq 'Term::ReadLine::Gnu') {
|
|
print $stdout "-- using Term::ReadLine::Gnu for enhanced readline support\n" if ($verbose);
|
|
|
|
# Set up comprehensive tab completion
|
|
my $attribs = $termrl->Attribs;
|
|
|
|
# Dynamically extract all commands from the source code
|
|
my @commands = ();
|
|
{
|
|
# Read our own source file to extract commands
|
|
# Try multiple possible filenames
|
|
my $source_file = $0;
|
|
$source_file = 'ttyverse.pl' if (!-f $source_file && -f 'ttyverse.pl');
|
|
$source_file = './ttyverse.pl' if (!-f $source_file && -f './ttyverse.pl');
|
|
|
|
my $source = '';
|
|
if (-f $source_file) {
|
|
open(my $fh, '<', $source_file) or warn "Cannot read source file ($source_file): $!";
|
|
if ($fh) {
|
|
$source = do { local $/; <$fh> };
|
|
close($fh);
|
|
}
|
|
}
|
|
|
|
# If we couldn't read the source file (packaged installation), fall back to manual list
|
|
my %seen_commands = ();
|
|
if (!$source || length($source) < 1000) {
|
|
print $stdout "-- using fallback command list (source file not accessible)\n" if ($verbose);
|
|
%seen_commands = map { $_ => 1 } qw(
|
|
/help /? /quit /q /bye /end /e /exit
|
|
/refresh /r /thump /again /a
|
|
/dm /dmr /dmrefresh /dms /dmsent /dmagain
|
|
/replies /re /reply /timeline /timelines
|
|
/media /visibility /search /se
|
|
/history /h /print /p /verbose /ve
|
|
/ruler /ru /cls /clear /url /open
|
|
/short /sh /rate /ratelimit
|
|
/track /tron /troff /trends /woeids
|
|
/notrack /set /unset /add /del
|
|
/push /pop /list /lists /listfollowers
|
|
/listfriends /dump /du /eval /ev
|
|
/version /update /versioncheck /updatecheck
|
|
/thread /th /entities /ent /delete
|
|
/deletelast /rtsof /vote /whois /w /me
|
|
);
|
|
} else {
|
|
# Dynamic extraction from source code
|
|
# Pattern 1: if ($_ eq '/command' || $_ eq '/alias')
|
|
while ($source =~ /if\s*\(\s*\$_\s+eq\s+['"]([\/][a-z?]+)['"](?:\s*\|\|\s*\$_\s+eq\s+['"]([\/][a-z?]+)['"])?/gi) {
|
|
$seen_commands{$1}++ if defined $1;
|
|
$seen_commands{$2}++ if defined $2;
|
|
}
|
|
|
|
# Pattern 2: if (m#^/command# or similar regex patterns
|
|
while ($source =~ /if\s*\(\s*[^)]*m#?\^([\/][a-z?]+)/gi) {
|
|
$seen_commands{$1}++;
|
|
}
|
|
|
|
# Pattern 3: return -1 if ($_ eq '/quit' patterns
|
|
while ($source =~ /return\s+-1\s+if\s*\(\s*\$_\s+eq\s+['"]([\/][a-z?]+)['"](?:\s*\|\|\s*\$_\s+eq\s+['"]([\/][a-z?]+)['"])?/gi) {
|
|
$seen_commands{$1}++ if defined $1;
|
|
$seen_commands{$2}++ if defined $2;
|
|
}
|
|
|
|
# Some manual additions for complex patterns we might miss
|
|
$seen_commands{'/reply'}++; # Often has complex parsing
|
|
$seen_commands{'/me'}++;
|
|
$seen_commands{'/url'}++;
|
|
$seen_commands{'/open'}++;
|
|
}
|
|
|
|
@commands = sort keys %seen_commands;
|
|
print $stdout "-- extracted " . scalar(@commands) . " commands for tab completion\n" if ($verbose);
|
|
print $stdout "-- commands: " . join(" ", @commands) . "\n" if ($verbose);
|
|
}
|
|
|
|
# Custom completion function
|
|
$attribs->{attempted_completion_function} = sub {
|
|
my ($text, $line, $start, $end) = @_;
|
|
|
|
# Debug output
|
|
print STDERR "COMPLETION DEBUG: text='$text' line='$line' start=$start end=$end\n" if ($verbose);
|
|
my $hash_size = scalar(keys %readline_completion);
|
|
my @hash_keys = keys %readline_completion;
|
|
print STDERR "COMPLETION DEBUG: Hash has $hash_size entries: " . join(", ", @hash_keys) . "\n" if ($verbose);
|
|
|
|
# Command completion at start of line or after whitespace
|
|
if ($line =~ /^\s*\/\w*$/ || ($start == 0 && $text =~ /^\//) ||
|
|
($line =~ /^\s+$/ && $text =~ /^\//)) {
|
|
|
|
print STDERR "COMPLETION: Trying command completion\n" if ($verbose);
|
|
my @matches = grep { index($_, $text) == 0 } @commands;
|
|
print STDERR "COMPLETION: Found " . scalar(@matches) . " command matches: " . join(", ", @matches) . "\n" if ($verbose);
|
|
|
|
if (@matches) {
|
|
return $termrl->completion_matches($text, sub {
|
|
my ($text, $state) = @_;
|
|
return $matches[$state] // undef;
|
|
});
|
|
}
|
|
}
|
|
|
|
# @mention completion - check if line has @ and we're completing after it
|
|
if ($line =~ /\@/ && $start >= 1 && substr($line, $start-1, 1) eq '@') {
|
|
print STDERR "COMPLETION: Trying \@mention completion for '$text' (line: '$line', start: $start)\n" if ($verbose);
|
|
print STDERR "COMPLETION: Hash reference check: " . \%readline_completion . "\n" if ($verbose);
|
|
my @mentions = keys %readline_completion;
|
|
print STDERR "COMPLETION: Total readline_completion keys: " . scalar(@mentions) . "\n" if ($verbose);
|
|
print STDERR "COMPLETION: All keys: " . join(", ", @mentions) . "\n" if ($verbose);
|
|
@mentions = grep { /^@/ } @mentions; # Only @mentions
|
|
|
|
# If no @mentions in completion hash, try to extract from timeline cache
|
|
if (!@mentions && %tl) {
|
|
print STDERR "COMPLETION: No mentions in cache, extracting from timeline\n" if ($verbose);
|
|
foreach my $post_id (keys %tl) {
|
|
my $post = $tl{$post_id};
|
|
if ($post && $post->{'user'}) {
|
|
my $user = $post->{'user'};
|
|
my $username = $user->{'acct'} || $user->{'username'} || $user;
|
|
if ($username) {
|
|
my $mention = '@' . $username;
|
|
push @mentions, $mention;
|
|
# Also add to completion hash for future use
|
|
$readline_completion{$mention}++;
|
|
}
|
|
# Also check for boost attribution
|
|
if ($post->{'boost_attribution'}) {
|
|
my $booster = '@' . $post->{'boost_attribution'};
|
|
push @mentions, $booster;
|
|
$readline_completion{$booster}++;
|
|
}
|
|
}
|
|
}
|
|
# Remove duplicates
|
|
my %seen = ();
|
|
@mentions = grep { !$seen{$_}++ } @mentions;
|
|
print STDERR "COMPLETION: Extracted " . scalar(@mentions) . " mentions from timeline\n" if ($verbose);
|
|
&save_completion_cache if (@mentions > 0);
|
|
}
|
|
|
|
print STDERR "COMPLETION: Available mentions: " . join(", ", @mentions) . "\n" if ($verbose);
|
|
|
|
# Filter matches based on what user has typed (text doesn't include @)
|
|
# We need to match against the part after @ in the mention
|
|
my @matches = ();
|
|
foreach my $mention (@mentions) {
|
|
my $username = $mention;
|
|
$username =~ s/^@//; # Remove @ prefix for matching
|
|
if ($text eq '' || index(lc($username), lc($text)) == 0) {
|
|
push @matches, $username; # Return without @ since completion will add it
|
|
}
|
|
}
|
|
print STDERR "COMPLETION: Filtered matches: " . join(", ", @matches) . "\n" if ($verbose);
|
|
|
|
if (@matches) {
|
|
return $termrl->completion_matches($text, sub {
|
|
my ($text, $state) = @_;
|
|
return $matches[$state] // undef;
|
|
});
|
|
}
|
|
}
|
|
|
|
# Try @ completion when user types @ anywhere
|
|
if ($text eq '@' || ($line =~ /\@$/ && $text eq '')) {
|
|
print STDERR "COMPLETION: Trying bare \@ completion\n" if ($verbose);
|
|
my @mentions = keys %readline_completion;
|
|
@mentions = grep { /^@/ } @mentions;
|
|
print STDERR "COMPLETION: Available mentions: " . join(", ", @mentions) . "\n" if ($verbose);
|
|
|
|
if (@mentions) {
|
|
return $termrl->completion_matches('@', sub {
|
|
my ($text, $state) = @_;
|
|
return $mentions[$state] // undef;
|
|
});
|
|
}
|
|
}
|
|
|
|
# File path completion for /media command
|
|
if ($line =~ /^\/media\s+/ && $start > 7) {
|
|
print STDERR "COMPLETION: Using file completion for /media\n" if ($verbose);
|
|
# Let default filename completion handle this
|
|
return ();
|
|
}
|
|
|
|
# Username completion for commands that take usernames
|
|
if ($line =~ /^\/(?:whois|w|again|a|list|lists|reply)\s+/ && $text !~ /^[\/@]/) {
|
|
print STDERR "COMPLETION: Trying username completion\n" if ($verbose);
|
|
my @mentions = keys %readline_completion;
|
|
@mentions = grep { /^@/ } @mentions;
|
|
|
|
# Remove @ prefix for username-only completion
|
|
my @usernames = map { substr($_, 1) } @mentions;
|
|
@usernames = grep { index(lc($_), lc($text)) == 0 } @usernames if $text;
|
|
print STDERR "COMPLETION: Username matches: " . join(", ", @usernames) . "\n" if ($verbose);
|
|
|
|
if (@usernames) {
|
|
return $termrl->completion_matches($text, sub {
|
|
my ($text, $state) = @_;
|
|
return $usernames[$state] // undef;
|
|
});
|
|
}
|
|
}
|
|
|
|
print STDERR "COMPLETION: No completion available\n" if ($verbose);
|
|
# No completion
|
|
return ();
|
|
};
|
|
|
|
# Load persistent completion cache
|
|
my $completion_cache_file = "$config/completion_cache";
|
|
if (-f $completion_cache_file) {
|
|
if (open(my $cache_fh, '<', $completion_cache_file)) {
|
|
my $read_count = 0;
|
|
my $validated_count = 0;
|
|
while (my $line = <$cache_fh>) {
|
|
chomp $line;
|
|
$read_count++;
|
|
print STDERR "CACHE_LOAD: Read line $read_count: '$line'\n" if ($verbose);
|
|
next unless $line;
|
|
# Validate username format before adding
|
|
if ($line =~ /^@[a-zA-Z0-9_.-]+(?:@[a-zA-Z0-9.-]+)?$/) {
|
|
print STDERR "CACHE_LOAD: Validated and adding: '$line'\n" if ($verbose);
|
|
$readline_completion{$line}++;
|
|
$validated_count++;
|
|
} else {
|
|
print STDERR "CACHE_LOAD: Failed validation: '$line'\n" if ($verbose);
|
|
}
|
|
}
|
|
close($cache_fh);
|
|
my $loaded_count = scalar(grep { /^@/ } keys %readline_completion);
|
|
print STDERR "CACHE_LOAD: Read $read_count lines, validated $validated_count, hash has $loaded_count entries\n" if ($verbose);
|
|
my @loaded_keys = sort(grep { /^@/ } keys %readline_completion);
|
|
print STDERR "CACHE_LOAD: Loaded keys: " . join(", ", @loaded_keys) . "\n" if ($verbose);
|
|
print $stdout "-- loaded $loaded_count cached usernames for tab completion\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
# Populate completion cache from existing timeline cache
|
|
if (%tl) {
|
|
print $stdout "-- populating completion cache from existing timeline data\n" if ($verbose);
|
|
my $added_count = 0;
|
|
foreach my $post_id (keys %tl) {
|
|
my $post = $tl{$post_id};
|
|
if ($post && $post->{'user'}) {
|
|
my $user = $post->{'user'};
|
|
# Extract username from user object
|
|
my $username = $user->{'acct'} || $user->{'username'} || $user;
|
|
if ($username) {
|
|
$readline_completion{'@'.$username}++;
|
|
$added_count++;
|
|
}
|
|
# Also check for boost attribution
|
|
if ($post->{'boost_attribution'}) {
|
|
$readline_completion{'@'.$post->{'boost_attribution'}}++;
|
|
$added_count++;
|
|
}
|
|
}
|
|
}
|
|
print $stdout "-- added $added_count usernames from cached timeline to completion\n" if ($verbose);
|
|
&save_completion_cache if ($added_count > 0);
|
|
}
|
|
|
|
print $stdout "-- tab completion enabled for commands, @mentions, and file paths\n" if ($verbose);
|
|
}
|
|
|
|
# Save completion cache to disk (with rate limiting)
|
|
our $last_cache_save = 0;
|
|
sub save_completion_cache {
|
|
return unless ($termrl && $termrl->ReadLine eq 'Term::ReadLine::Gnu');
|
|
|
|
# Rate limit saves to every 30 seconds to avoid excessive disk I/O
|
|
my $now = time();
|
|
return if ($now - $last_cache_save < 30);
|
|
$last_cache_save = $now;
|
|
|
|
my $completion_cache_file = "$config/completion_cache";
|
|
|
|
# Create config directory if it doesn't exist
|
|
unless (-d $config) {
|
|
mkdir($config, 0700) or return;
|
|
}
|
|
|
|
# Get all @mentions, validate them, and save
|
|
my @mentions = grep { /^@/ } keys %readline_completion;
|
|
@mentions = grep { /^@[a-zA-Z0-9_.-]+(?:@[a-zA-Z0-9.-]+)?$/ } @mentions; # Validate format
|
|
|
|
if (open(my $cache_fh, '>', $completion_cache_file)) {
|
|
print $cache_fh "$_\n" for sort @mentions;
|
|
close($cache_fh);
|
|
print $stdout "-- saved " . scalar(@mentions) . " usernames to completion cache: " . join(", ", sort @mentions) . "\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
# try to get signal numbers for SIG* from POSIX. use internals if failed.
|
|
eval 'use POSIX; $SIGUSR1 = POSIX::SIGUSR1; $SIGUSR2 = POSIX::SIGUSR2; $SIGHUP = POSIX::SIGHUP; $SIGTERM = POSIX::SIGTERM';
|
|
# from <sys/signal.h>
|
|
$SIGHUP ||= 1;
|
|
$SIGTERM ||= 15;
|
|
$SIGUSR1 ||= 30;
|
|
$SIGUSR2 ||= 31;
|
|
|
|
# set default wrap if not specified - try multiple methods to get terminal width
|
|
unless ($wrap) {
|
|
# Try multiple methods to detect terminal width
|
|
$wrap = $ENV{'COLUMNS'};
|
|
if (!$wrap) {
|
|
$wrap = `tput cols 2>/dev/null`;
|
|
chomp($wrap) if $wrap;
|
|
}
|
|
if (!$wrap || $wrap !~ /^\d+$/) {
|
|
my $stty_output = `stty size 2>/dev/null`;
|
|
if ($stty_output =~ /\d+\s+(\d+)/) {
|
|
$wrap = $1;
|
|
}
|
|
}
|
|
# Use a more generous default for wide terminals
|
|
$wrap ||= 120; # Better default for modern wide terminals
|
|
|
|
# If we detected a wide terminal (>100 cols), account for wrapping quirks
|
|
# by reducing by 2 to avoid edge cases in the wwrap function
|
|
if ($wrap > 100) {
|
|
$wrap -= 2;
|
|
print $stdout "-- adjusted wrap width to $wrap for wide terminal compatibility\n" if ($verbose);
|
|
}
|
|
}
|
|
$wrap = 80 if ($wrap !~ /^\d+$/ || $wrap < 20); # Sanity check
|
|
print $stdout "-- terminal width detected: $wrap columns\n" if ($verbose);
|
|
|
|
# wrap warning
|
|
die(
|
|
"** dude, what the hell kind of terminal can't handle a 5 character line?\n")
|
|
if ($wrap > 1 && $wrap < 5);
|
|
print $stdout "** warning: prompts not wrapped for wrap < 70\n"
|
|
if ($wrap > 1 && $wrap < 70);
|
|
|
|
# reject stupid combinations
|
|
die("you can't use automatic ratelimits with -noratelimit.\nuse -pause=#sec\n")
|
|
if ($noratelimit && $pause eq 'auto');
|
|
die("you can't use -synch with -script or -daemon.\n")
|
|
if ($synch && ($script || $daemon));
|
|
die("-script and -daemon cannot be used together.\n")
|
|
if ($script && $daemon);
|
|
|
|
# set up menu codes and caches
|
|
$is_background = 0;
|
|
$alphabet = "abcdefghijkLmnopqrstuvwxyz";
|
|
%store_hash = ();
|
|
$mini_split = 250; # i.e., 10 posts for the mini-menu (/th)
|
|
# leaving 50 posts for the foreground temporary menus
|
|
$post_counter = 0;
|
|
%dm_store_hash = ();
|
|
$dm_counter = 0;
|
|
%id_cache = ();
|
|
%filter_next = ();
|
|
|
|
# set up threading management
|
|
$in_reply_to = 0;
|
|
$expected_post_ref = undef;
|
|
|
|
# interpret -script at this level
|
|
if ($script) {
|
|
$noansi = $noprompt = 1;
|
|
$silent = ($verbose) ? 0 : 1;
|
|
$pause = $vcheck = $slowpost = $verify = 0;
|
|
}
|
|
|
|
### now instantiate the TTYverse dynamic API ###
|
|
### based off the defaults later in script. ####
|
|
|
|
# resolve extension path using XDG directory only
|
|
sub resolve_extension_path {
|
|
my $name = shift;
|
|
|
|
# If absolute path, check if it exists
|
|
if ($name =~ m{^/}) {
|
|
return $name if (-r $name);
|
|
return undef;
|
|
}
|
|
|
|
# If relative path (./... or ../...), use as-is if readable
|
|
if ($name =~ m{^\.\.?/}) {
|
|
return $name if (-r $name);
|
|
return undef;
|
|
}
|
|
|
|
# Only location: XDG user extensions directory
|
|
my $ext_path = "$data/extensions/$name";
|
|
return $ext_path if (-r $ext_path);
|
|
|
|
# If name doesn't end in .pl, try adding it
|
|
unless ($name =~ /\.pl$/) {
|
|
my $pl_path = "$data/extensions/$name.pl";
|
|
return $pl_path if (-r $pl_path);
|
|
}
|
|
|
|
return undef; # Not found
|
|
}
|
|
|
|
# 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;
|
|
my $original_file = $file;
|
|
|
|
# Resolve extension path using XDG + submodule locations
|
|
my $extension_path = &resolve_extension_path($file);
|
|
die("** extension '$original_file' not found in any search path\n")
|
|
unless ($extension_path);
|
|
|
|
print "** loading $extension_path\n" unless ($silent);
|
|
|
|
die("** sorry, you cannot load the same extension twice.\n")
|
|
if ($master_store->{$original_file}->{'loaded'});
|
|
|
|
# prepare its working space in $store and load the module
|
|
$master_store->{$original_file} = { 'loaded' => 1 };
|
|
$store = \%{ $master_store->{$original_file} };
|
|
$EM_DONT_CARE = 0;
|
|
$EM_SCRIPT_ON = 1;
|
|
$EM_SCRIPT_OFF = -1;
|
|
$extension_mode = $EM_DONT_CARE;
|
|
require $extension_path; # and die if bad
|
|
die("** $file failed to load: $@\n") if ($@);
|
|
die("** consistency failure: reference failure on $file\n")
|
|
if (!$store->{'loaded'});
|
|
|
|
# check type of extension (interactive or non-interactive). if
|
|
# we are in the wrong mode, bail out.
|
|
if ($extension_mode) {
|
|
die(
|
|
"** this extension requires -script. this may conflict with other extensions\n".
|
|
" you are loading, which may have their own requirements.\n")
|
|
if ($extension_mode == $EM_SCRIPT_ON && !$script);
|
|
die(
|
|
"** this extension cannot work with -script. this may conflict with other\n".
|
|
" extensions you are loading, which may have their own requirements.\n")
|
|
if ($extension_mode == $EM_SCRIPT_OFF && $script);
|
|
}
|
|
|
|
# pick off all the subroutine references it makes for storage
|
|
# in an array to iterate and chain over later.
|
|
|
|
# these methods are multi-module safe
|
|
foreach $arry (qw(
|
|
handle exception posttype conclude 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;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Show summary of loaded extensions
|
|
unless ($silent) {
|
|
my @loaded_extensions = ();
|
|
foreach my $ext_name (keys %$master_store) {
|
|
push @loaded_extensions, $ext_name if $master_store->{$ext_name}->{'loaded'};
|
|
}
|
|
if (@loaded_extensions) {
|
|
my $ext_list = join(', ', @loaded_extensions);
|
|
print "** loaded extensions: $ext_list\n";
|
|
}
|
|
}
|
|
|
|
# success! enable multi-module support in the TTYverse API and then
|
|
# dispatch calls through the multi-module system instead.
|
|
$multi_module_mode = 1; # mark as completed loader
|
|
|
|
$handle = \&multihandle;
|
|
$exception = \&multiexception;
|
|
$posttype = \&multiposttype;
|
|
$conclude = \&multiconclude;
|
|
$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;
|
|
$posttype = \&defaultposttype;
|
|
$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 = ();
|
|
|
|
# Initialize flag to suppress notifications during initial timeline load
|
|
$initial_load_in_progress = 1;
|
|
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
|
|
# Fediverse uses OAuth 2.0 exclusively
|
|
$authtype = "oauth2";
|
|
die("** TTYverse only supports OAuth 2.0 (fediverse standard)\n")
|
|
if ($authtype ne 'oauth2');
|
|
|
|
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;
|
|
$vcheck ||= 1; # Enable version checking by default
|
|
die("** -anonymous is not supported with fediverse authentication\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 ||= 5000; # Generous default, will be updated from server
|
|
$post_visibility ||= "public"; # Default post visibility: public, unlisted, private, direct
|
|
# Fediverse server configuration - defaults to mastodon.social
|
|
$fediverseserver ||= "mastodon.social";
|
|
$oauthbase ||= $apibase || "${http_proto}://${fediverseserver}";
|
|
# this needs to be AFTER oauthbase so that apibase can set oauthbase.
|
|
$apibase ||= "${http_proto}://${fediverseserver}/api/v1";
|
|
$noreblogs ||= 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}/timelines/home";
|
|
|
|
# Mastodon OAuth 2.0 endpoints (not OAuth 1.0a like fediverse)
|
|
$oauthurl ||= "${oauthbase}/api/v1/apps";
|
|
$oauthauthurl ||= "${oauthbase}/oauth/authorize";
|
|
$oauthaccurl ||= "${oauthbase}/oauth/token";
|
|
|
|
$credurl ||= "${apibase}/accounts/verify_credentials";
|
|
$update ||= "${apibase}/statuses";
|
|
$rurl ||= "${apibase}/timelines/home"; # mentions are in home timeline
|
|
$uurl ||= "${apibase}/accounts/%I/statuses";
|
|
$idurl ||= "${apibase}/statuses/%I";
|
|
$delurl ||= "${apibase}/statuses/%I";
|
|
|
|
$reblogurl ||= "${apibase}/statuses/%I/reblog";
|
|
# Twitter endpoints removed - not available in fediverse
|
|
# $boostsbyurl: Use /api/v1/statuses/%I/reblogged_by instead
|
|
# $boostsofmeurl: No direct equivalent in fediverse (privacy feature)
|
|
|
|
$wurl ||= "${apibase}/accounts/%I";
|
|
|
|
# Twitter friendships API removed - use /api/v1/accounts/relationships instead
|
|
$followurl ||= "${apibase}/accounts/%I/follow";
|
|
$leaveurl ||= "${apibase}/accounts/%I/unfollow";
|
|
$blockurl ||= "${apibase}/accounts/%I/block";
|
|
$blockdelurl ||= "${apibase}/accounts/%I/unblock";
|
|
$friendsurl ||= "${apibase}/accounts/%I/following";
|
|
$followersurl ||= "${apibase}/accounts/%I/followers";
|
|
# Twitter friendships/update removed - fediverse uses individual follow/unfollow endpoints
|
|
$lookupidurl ||= "${apibase}/accounts/lookup";
|
|
|
|
$rlurl ||= "${apibase}/instance"; # Mastodon instance info instead of rate limits
|
|
|
|
$dmurl ||= "${apibase}/conversations";
|
|
$dmsenturl ||= "${apibase}/conversations"; # Same endpoint in Mastodon
|
|
$dmupdate ||= "${apibase}/statuses"; # DMs are private statuses
|
|
$dmdelurl ||= "${apibase}/statuses/%I";
|
|
$dmidurl ||= "${apibase}/statuses/%I";
|
|
|
|
$favsurl ||= "${apibase}/favourites";
|
|
$favurl ||= "${apibase}/statuses/%I/favourite";
|
|
$favdelurl ||= "${apibase}/statuses/%I/unfavourite";
|
|
|
|
# Fediverse list APIs (simplified compared to Twitter)
|
|
$getlisurl ||= "${apibase}/lists"; # GET lists
|
|
$creliurl ||= "${apibase}/lists"; # POST create list
|
|
$delliurl ||= "${apibase}/lists/%I"; # DELETE list
|
|
$modifyliurl ||= "${apibase}/lists/%I"; # PUT update list
|
|
$getliurl ||= "${apibase}/lists/%I/accounts"; # GET list members
|
|
$adduliurl ||= "${apibase}/lists/%I/accounts"; # POST add members
|
|
$deluliurl ||= "${apibase}/lists/%I/accounts"; # DELETE remove members
|
|
$statusliurl ||= "${apibase}/lists/%I"; # GET list timeline
|
|
# Note: Fediverse doesn't have list subscriptions/followers like Twitter
|
|
|
|
$streamurl ||= "${http_proto}://${fediverseserver}/api/v1/streaming";
|
|
$dostream ||= 0;
|
|
$eventbuf ||= 0;
|
|
|
|
$queryurl ||= "${apibase}/../v2/search";
|
|
# no more $trendurl in 2.1.
|
|
$wtrendurl ||= "${apibase}/trends";
|
|
$atrendurl ||= "${apibase}/trends";
|
|
|
|
# pick ONE!
|
|
#$shoreblogurl ||= "http://api.tr.im/v1/trim_simple?url=";
|
|
$shoreblogurl ||= "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';
|
|
$cli_browser ||= '';
|
|
$gui_browser ||= '';
|
|
$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');
|
|
$dmmarkread = 1 if (!defined $dmmarkread); # Default to enabled
|
|
$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';
|
|
|
|
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 TTYverse 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 TTYverse 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 TTYverse.\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 (TTYverse 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', "TTYverse/$TTYverse_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 with OAuth 2.0 (fediverse standard)
|
|
unless ($dont_do_auth) {
|
|
# OAuth 2.0 Bearer token
|
|
my $bearer_header = &signrequest($resource, $data);
|
|
if ($bearer_header) {
|
|
$l .= $bearer_header . "\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');
|
|
$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 fediverse. 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' || $authtype eq 'oauth2') && (!length($keyfile) || $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 TTYverse without -script or -runcommand for help)
|
|
EOF
|
|
exit;
|
|
}
|
|
# run the wizard, which writes a keyfile for us
|
|
# restore keyfile path from attempted_keyfile for wizard use
|
|
$keyfile = $attempted_keyfile;
|
|
print $stdout <<"EOF";
|
|
|
|
+----------------------------------------------------------------------------+
|
|
|| WELCOME TO TTYverse: Authorize TTYverse by signing into your fediverse server ||
|
|
+----------------------------------------------------------------------------+
|
|
Looks like you're starting TTYverse for the first time, and/or creating a
|
|
keyfile. Welcome to the most user-hostile, highly obfuscated, spaghetti code
|
|
infested and obscenely obscure fediverse client that's out there. You'll love it.
|
|
|
|
TTYverse 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 TTYverse'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 TTYverse; only one account token can be stored per keyfile. If you
|
|
have multiple accounts, use -keyfile=... to specify different keyfiles. KEEP THESE
|
|
FILES SECRET.
|
|
|
|
** This wizard will overwrite $attempted_keyfile
|
|
** (Use -keyfile=path to specify a different location)
|
|
Press RETURN/ENTER to continue or CTRL-C NOW! to abort.
|
|
EOF
|
|
$j = <STDIN>;
|
|
if ($authtype eq 'oauth2') {
|
|
# OAuth 2.0 flow for Mastodon/fediverse
|
|
&oauth2_wizard;
|
|
} else {
|
|
# OAuth 1.0a flow for fediverse (legacy)
|
|
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
|
|
# fediverse: we know fediverse supports SSL
|
|
($oauthauthurl =~ /fediverse/) &&
|
|
($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 TTYverse 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 messages on your behalf and access your
|
|
direct messages). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW!
|
|
|
|
4. Click Authorize app.
|
|
|
|
5. A PIN will appear. Enter it below.
|
|
|
|
EOF
|
|
$j = '';
|
|
while(!(0+$j)) {
|
|
print $stdout "Enter PIN> ";
|
|
chomp($j = <STDIN>);
|
|
}
|
|
print $stdout "\nRequest from $oauthaccurl ...";
|
|
($tokenkey, $tokensecret) = &tryhardfortoken($oauthaccurl,
|
|
"oauth_verifier=$j");
|
|
|
|
$oauthkey = "X";
|
|
$oauthsecret = "X";
|
|
# Ensure the keyfile directory exists
|
|
my $keyfile_dir = $keyfile;
|
|
$keyfile_dir =~ s|[^/]*$||; # Remove filename, keep directory path
|
|
if ($keyfile_dir && !-d $keyfile_dir) {
|
|
eval { make_path($keyfile_dir) };
|
|
if ($@) {
|
|
die("Failed to create keyfile directory $keyfile_dir: $@\n");
|
|
}
|
|
}
|
|
open(W, ">$keyfile") ||
|
|
die("Failed to write keyfile $keyfile: $!\n");
|
|
print W <<"EOF";
|
|
ck=${oauthkey}&cs=${oauthsecret}&at=${tokenkey}&ats=${tokensecret}
|
|
EOF
|
|
close(W);
|
|
chmod(0600, $keyfile) || print $stdout
|
|
"Warning: could not change permissions on $keyfile : $!\n";
|
|
print $stdout <<"EOF";
|
|
Written keyfile $keyfile
|
|
|
|
Now, restart TTYverse to use this keyfile.
|
|
(To choose between multiple keyfiles other than the default .ttyversekey,
|
|
tell TTYverse where the key is using -keyfile=... .)
|
|
|
|
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 -keyfile=... or add these missing pieces:
|
|
$error
|
|
then restart TTYverse, or use -authtype=basic.
|
|
EOF
|
|
exit;
|
|
}
|
|
} # end OAuth 1.0a else block
|
|
}
|
|
} elsif ($retoke && length($attempted_keyfile)) {
|
|
# start the "re-toke" wizard to convert DM-less cloned app keys.
|
|
# restore keyfile path from attempted_keyfile for wizard use
|
|
$keyfile = $attempted_keyfile;
|
|
# 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 TTYverse keyfile for your app/token ||
|
|
+-------------------------------------------------------------------------+
|
|
fediverse 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 TTYverse for a purpose that does
|
|
not require direct message access. For example, if TTYverse 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 $attempted_keyfile
|
|
** To change this, restart TTYverse with -retoke -keyfile=/path/to/keyfile
|
|
Press RETURN/ENTER to continue, or CTRL-C NOW! to abort.
|
|
EOF
|
|
|
|
$j = <STDIN>;
|
|
print $stdout <<"EOF";
|
|
|
|
First: let's get your API key, consumer key and consumer secret.
|
|
Start your browser.
|
|
1. Log into your fediverse server with your desired account.
|
|
2. Go to this URL. You must be logged into fediverse FIRST!
|
|
|
|
your-server.com/settings/applications/new
|
|
|
|
3. Click the TTYverse cloned app key you need to regenerate or upgrade.
|
|
4. Click Edit Application Settings.
|
|
5. Make sure Read, Write & Private Message is selected, and click the
|
|
"Save application" button.
|
|
6. Select All (CTRL/Command-A) on the next screen, copy (CTRL/Command-C) it,
|
|
and paste (CTRL/Command-V) it into this window. (You can also cut and
|
|
paste a smaller section if I can't understand your browser's layout.)
|
|
7. Press ENTER/RETURN and CTRL-D when you have pasted the window contents.
|
|
EOF
|
|
|
|
$q = $/;
|
|
PASTE1LOOP: for(;;) {
|
|
print $stdout <<"EOF";
|
|
|
|
-- Press ENTER and CTRL-D AFTER you have pasted the window contents! ---------
|
|
Go ahead:
|
|
EOF
|
|
undef $/;
|
|
$j = <STDIN2>;
|
|
print $stdout <<"EOF";
|
|
|
|
-- EOF -----------------------------------------------------------------------
|
|
Processing ...
|
|
|
|
EOF
|
|
$j =~ s/[\r\n]/ /sg;
|
|
|
|
# process this. as a checksum, API key should == consumer key.
|
|
$ck = '';
|
|
$cs = '';
|
|
($j =~ /Consumer key\s+([-a-zA-Z0-9_]{10,})\s+/) && ($ck = $1);
|
|
($j =~ /Consumer secret\s+([-a-zA-Z0-9_]{10,})\s+/) &&
|
|
($cs = $1);
|
|
|
|
if (!length($ck) || !length($cs)) {
|
|
# escape hatch
|
|
print $stdout <<"EOF";
|
|
Something's wrong: I could not find your consumer key or consumer
|
|
secret in that text. If this was a misfired paste, please restart the wizard.
|
|
Otherwise, bug me at \@ttytter or ckaiser\@floodgap.com. Please don't send
|
|
keys or secrets to either address.
|
|
|
|
EOF
|
|
exit;
|
|
}
|
|
last PASTE1LOOP;
|
|
}
|
|
# this part is similar to the retoke.
|
|
$oauthkey = $ck;
|
|
$oauthsecret = $cs;
|
|
print $stdout "\nI'm testing this key to see if it works.\n";
|
|
print $stdout "Request from $oauthurl ...";
|
|
($tokenkey, $tokensecret) = &tryhardfortoken($oauthurl,
|
|
"oauth_callback=oob");
|
|
$mytoken = $tokenkey;
|
|
$mytokensecret = $tokensecret;
|
|
# kludge in case user does not specify SSL and this is
|
|
# fediverse: we know fediverse supports SSL
|
|
($oauthauthurl =~ /fediverse/) && ($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 messages on your behalf and access your
|
|
direct messages). IF THIS IS NOT CORRECT, PRESS CTRL-C NOW!
|
|
|
|
3. Click Authorize app.
|
|
|
|
4. A PIN will appear. Enter it below.
|
|
|
|
EOF
|
|
print $stdout "Enter PIN> ";
|
|
chomp($j = <STDIN>);
|
|
print $stdout "\nRequest from $oauthaccurl ...";
|
|
($at, $ats) = &tryhardfortoken($oauthaccurl, "oauth_verifier=$j");
|
|
|
|
print $stdout <<"EOF";
|
|
|
|
Consumer key =========> $ck
|
|
Consumer secret ======> $cs
|
|
Access token =========> $at
|
|
Access token secret ==> $ats
|
|
|
|
EOF
|
|
# Ensure the keyfile directory exists
|
|
my $keyfile_dir = $keyfile;
|
|
$keyfile_dir =~ s|[^/]*$||; # Remove filename, keep directory path
|
|
if ($keyfile_dir && !-d $keyfile_dir) {
|
|
eval { make_path($keyfile_dir) };
|
|
if ($@) {
|
|
die("Failed to create keyfile directory $keyfile_dir: $@\n");
|
|
}
|
|
}
|
|
open(W, ">$keyfile") || (print $stdout ("Unable to write to $keyfile: $!\n"),
|
|
exit);
|
|
print W "ck=$ck&cs=$cs&at=$at&ats=$ats\n";
|
|
close(W);
|
|
chmod(0600, $keyfile) || print $stdout
|
|
"Warning: could not change permissions on $keyfile : $!\n";
|
|
print $stdout "Keys written to regenerated keyfile $keyfile\n";
|
|
print $stdout "Now restart TTYverse.\n";
|
|
exit;
|
|
}
|
|
|
|
# now, get a token (either from Basic Auth, the keyfile or OAuth)
|
|
($mytoken, $mytokensecret) = &authtoken;
|
|
} # unless anonymous
|
|
|
|
# if we are testing the stream, this is where we split
|
|
if ($streamtest) {
|
|
print $stdout ">>> STREAMING CONNECT TEST <<< (kill process to end)\n";
|
|
&start_streaming; } # this never returns in this mode
|
|
|
|
# initial login tests and command line controls
|
|
if ($statusurl) {
|
|
$shorstatusturl = &urlshorten($statusurl);
|
|
$status = ((length($status)) ? "$status " : "") . $shorstatusturl;
|
|
}
|
|
$phase = 0;
|
|
$didhold = $hold;
|
|
$hold = -1 if ($hold == 1 && !$script);
|
|
$credentials = '';
|
|
$status = pack("U0C*", unpack("C*", $status))
|
|
unless ($seven || !length($status) || $LANG =~ /8859/); # kludgy also
|
|
if ($status eq '-') {
|
|
chomp(@status = <STDIN>);
|
|
$status = join("\n", @status);
|
|
}
|
|
for(;;) {
|
|
$rv = 0;
|
|
die(
|
|
"sorry, you can't post 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 fediverse. 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 $stdout "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 = &map_mastodon_fields(&parsejson($credentials));
|
|
$whoami = lc($my_json_ref->{'username'} || $my_json_ref->{'acct'});
|
|
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";
|
|
|
|
# Update server configuration (character limits, etc.)
|
|
&update_server_config;
|
|
}
|
|
|
|
#### 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;
|
|
# Move DM refresh after timeline refresh so timeline updates show even if no unread DMs
|
|
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(
|
|
&map_mastodon_fields(&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";
|
|
|
|
========================================
|
|
TTYverse ${TTYverse_VERSION} (c)2025 Storm Dragon
|
|
all rights reserved.
|
|
|
|
https://git.stormux.org/storm/ttyverse
|
|
|
|
freeware under the floodgap free software license.
|
|
http://www.floodgap.com/software/ffsl/
|
|
|
|
forked from TTYtter by Cameron Kaiser
|
|
http://www.floodgap.com/software/ttytter/
|
|
|
|
fediverse client for Mastodon/GoToSocial/etc
|
|
========================================
|
|
|
|
when ready, hit RETURN/ENTER for a prompt.
|
|
type /help for commands or /quit to quit.
|
|
starting background monitoring process.
|
|
|
|
EOF
|
|
} else {
|
|
print <<"EOF";
|
|
TTYverse ${TTYverse_VERSION} - A command-line fediverse client
|
|
Derivative of TTYtter (c)2012 Cameron Kaiser - Fediverse migration
|
|
Distributed under the Floodgap Free Software License.
|
|
http://www.floodgap.com/software/ffsl/
|
|
|
|
Original TTYtter: 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);
|
|
}
|
|
|
|
# Show donation message unless in silent mode
|
|
unless ($silent) {
|
|
print $stdout "-- If you like TTYverse, consider supporting development: https://patreon.com/stormux\n";
|
|
}
|
|
|
|
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) ? "" : "TTYverse> ";
|
|
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) {
|
|
print $stdout "-- DEBUG: Starting readline loop with implementation: " . $termrl->ReadLine . "\n" if ($verbose);
|
|
print $stdout "-- DEBUG: Terminal capability check - can cursor move: " . ($termrl->can('Attribs') ? "yes" : "no") . "\n" if ($verbose);
|
|
while(defined ($_ = $termrl->readline((&$prompt(1))[0]))) {
|
|
if ($verbose && /[\x1b\[\x5b]/) {
|
|
print $stdout "-- DEBUG: Arrow key detected in input: " . join("", map { sprintf("\\x%02x", ord($_)) } split(//, $_)) . "\n";
|
|
}
|
|
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
|
|
|
|
# Paste protection - detect multi-line input
|
|
if (!$script && $_ =~ /\n/) {
|
|
my @lines = split(/\n/, $_);
|
|
my $line_count = scalar(@lines);
|
|
|
|
if ($line_count > 3) {
|
|
print $stdout "-- PASTE PROTECTION: Detected $line_count lines of input!\n";
|
|
print $stdout "-- This looks like an accidental paste.\n";
|
|
print $stdout "-- First few lines:\n";
|
|
|
|
# Show first 3 lines as preview
|
|
for my $j (0..($line_count > 3 ? 2 : $line_count-1)) {
|
|
my $preview = substr($lines[$j], 0, 60);
|
|
$preview .= "..." if length($lines[$j]) > 60;
|
|
print $stdout " " . ($j+1) . ": $preview\n";
|
|
}
|
|
|
|
print $stdout "-- Type 'paste' to continue or anything else to cancel: ";
|
|
my $response = <STDIN>;
|
|
chomp($response);
|
|
|
|
if (lc($response) ne 'paste') {
|
|
print $stdout "-- Multi-line input cancelled.\n";
|
|
return 0;
|
|
}
|
|
|
|
print $stdout "-- Processing multi-line input...\n";
|
|
}
|
|
|
|
# Process each line separately with paste protection
|
|
my $processed = 0;
|
|
for my $line (@lines) {
|
|
next if $line =~ /^\s*$/; # Skip empty lines
|
|
my $result = &prinput($line);
|
|
if ($result < 0) {
|
|
return $result; # Propagate quit command (-1)
|
|
}
|
|
$processed++;
|
|
}
|
|
return $processed;
|
|
}
|
|
|
|
# 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' ||
|
|
/^TTYverse>/ || $_ eq 'ls' || $_ eq '?' ||
|
|
m#^help /# || $_ eq 'exit')) {
|
|
|
|
&add_history($_);
|
|
unless ($_ eq 'exit' || /^TTYverse>/ || $_ eq 'ls') {
|
|
print $stdout "*** did you mean /$_ ?\n";
|
|
print $stdout
|
|
"*** to send this as a command, type /%%\n";
|
|
} else {
|
|
print $stdout
|
|
"*** did you really mean to post \"$_\"?\n";
|
|
}
|
|
print $stdout "*** to post it anyway, type %%\n";
|
|
return 0;
|
|
}
|
|
|
|
if (/^\%(\%|-\d+):p$/) {
|
|
my $x = $1;
|
|
if ($x eq '%') {
|
|
print $stdout "=> \"$history[0]\"\n";
|
|
} else {
|
|
$x += 0;
|
|
if (!$x || $x < -(scalar(@history))) {
|
|
print $stdout "*** illegal index\n";
|
|
} else {
|
|
print $stdout "=> \"$history[-($x + 1)]\"\n";
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# handle history substitution (including /%%, %%--, %%*, etc.)
|
|
$i = 0; # flag
|
|
|
|
if (/^\%(\%|-\d+)(--|-\d+|\*)?/) {
|
|
($i, $proband, $r, $s) = &sub_helper($1, $2, $_);
|
|
return 0 if (!$i);
|
|
|
|
$s = quotemeta($s);
|
|
s/^\%${r}${s}/$proband/;
|
|
}
|
|
if (/[^\\]\%(\%|-\d+)(--|-\d+|\*)?$/) {
|
|
($i, $proband, $r, $s) = &sub_helper($1, $2, $_);
|
|
return 0 if (!$i);
|
|
|
|
$s = quotemeta($s);
|
|
s/\%${r}${s}$/$proband/;
|
|
}
|
|
# handle variables second, in case they got in history somehow ...
|
|
$i = 1 if (s/^\%URL\%/$urlshort/ || s/\%URL\%$/$urlshort/);
|
|
$i = 1 if (s/^\%RT\%/$repost/ || s/\%RT\%$/$repost/);
|
|
|
|
# and escaped history
|
|
s/^\\\%/%/;
|
|
|
|
if ($i) {
|
|
print $stdout "(expanded to \"$_\")\n" ;
|
|
$in_reply_to = $expected_post_ref->{'id_str'} || 0
|
|
if (defined $expected_post_ref &&
|
|
ref($expected_post_ref) eq 'HASH');
|
|
} else {
|
|
$expected_post_ref = undef;
|
|
}
|
|
|
|
return 0 unless length; # actually possible to happen
|
|
# with control char filters and history.
|
|
|
|
&add_history($_);
|
|
$shadow_history = $_;
|
|
|
|
# handle history display
|
|
if ($_ eq '/history' || $_ eq '/h') {
|
|
for ($i = scalar(@history); $i >= 1; $i--) {
|
|
print $stdout "\t$i\t$history[($i-1)]\n";
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
my $slash_first = ($_ =~ m#^/#);
|
|
|
|
return -1 if ($_ eq '/quit' || $_ eq '/q' || $_ eq '/bye' ||
|
|
$_ eq '/exit');
|
|
|
|
return 0 if (scalar(&$addaction($_)));
|
|
|
|
# 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 $post = &get_post($code);
|
|
my $k;
|
|
my $sn;
|
|
my $id;
|
|
my @superfields = (
|
|
[ "user", "username" ], # must always be first
|
|
[ "reblog", "id_str" ],
|
|
[ "user", "geo_enabled" ],
|
|
[ "place", "id" ],
|
|
[ "place", "country_code" ],
|
|
[ "place", "full_name" ],
|
|
[ "place", "place_type" ],
|
|
[ "tag", "type" ],
|
|
[ "tag", "payload" ],
|
|
);
|
|
my $superfield;
|
|
|
|
if (!defined($post)) {
|
|
print $stdout "-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
|
|
foreach $superfield (@superfields) {
|
|
my $sfn = join('->', @{ $superfield });
|
|
my $sfk = "{'" . join("'}->{'", @{ $superfield }) .
|
|
"'}";
|
|
my $sfv;
|
|
eval "\$sfv = &descape(\$post->$sfk);";
|
|
print $stdout
|
|
substr("$sfn ", 0, 25).
|
|
" $sfv\n";
|
|
$sn = $sfv if (!length($sn) && length($sfv));
|
|
}
|
|
# geo is special
|
|
print $stdout "geo->coordinates (" .
|
|
join(', ', @{ $post->{'geo'}->{'coordinates'} })
|
|
. ")\n";
|
|
foreach $k (sort keys %{ $post }) {
|
|
next if (ref($post->{$k}));
|
|
print $stdout
|
|
substr("$k ", 0, 25) .
|
|
" " . &descape($post->{$k}) . "\n";
|
|
}
|
|
# include a URL to the post per @augmentedfourth
|
|
# URL construction removed for fediverse compatibility
|
|
$urlshort = "";
|
|
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", "username" ], # 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;
|
|
|
|
# In fediverse, can only access your own lists (privacy feature)
|
|
if ($uname ne $whoami) {
|
|
print $stdout "-- Sorry, fediverse only allows access to your own lists (privacy feature)\n";
|
|
return 0;
|
|
}
|
|
|
|
# Look up list ID by title
|
|
my $list_id = &lookup_list_id($lname);
|
|
if (!$list_id) {
|
|
print $stdout "*** list '$lname' not found; use /lists to see available lists\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 ***
|
|
|
|
IMPORTANT: Anything without a leading / is sent as a post!
|
|
Just type to talk!
|
|
|
|
/refresh
|
|
Grabs the newest posts right away (or tells you if there
|
|
is nothing new) by checking the background process.
|
|
|
|
/again
|
|
Displays most recent posts, both old and new.
|
|
|
|
/dm and /dmagain
|
|
For direct messages.
|
|
|
|
/replies
|
|
Shows replies and mentions.
|
|
|
|
/timelines
|
|
Lists available timelines to view.
|
|
|
|
/timeline <name>
|
|
Switch to timeline (home, local, federated, notifications, etc.)
|
|
|
|
/visibility [level]
|
|
Show current post visibility or set to: public, unlisted, private, direct
|
|
|
|
/media /path/to/file
|
|
Upload media (images, video, audio) with accessibility features
|
|
|
|
/quit
|
|
Resumes your boring life.
|
|
|
|
REMEMBER: Many commands and all posts are ASYNCHRONOUS and might
|
|
not always respond immediately!
|
|
|
|
USE + FOR A COUNT: /re +30 => last 30 replies
|
|
|
|
EOF
|
|
&linein("PRESS RETURN/ENTER>");
|
|
print <<"EOF";
|
|
|
|
*** MORE COMMANDS ***
|
|
|
|
USER COMMANDS:
|
|
/whois username - displays info about username
|
|
/again username - views their most recent posts
|
|
/wagain username - combines them all
|
|
/follow username - follow a username
|
|
/leave username - stop following a username
|
|
/dm username message - send a username a DM
|
|
|
|
POST AND DM SELECTION:
|
|
All DMs and posts have menu codes (letters + number, d for DMs).
|
|
Example:
|
|
a5> <user> Send me Dr Pepper http://example.com
|
|
[DM da0][user/Sun Jan 32 1969] I think you are cute
|
|
|
|
/reply a5 message - replies to post a5
|
|
/thread a5 - show all posts in thread if a5 is threaded
|
|
/url a5 - opens all URLs in post a5
|
|
/delete a5 - deletes post a5, if it's your post
|
|
/boost a5 - boosts post a5
|
|
/vote a5 2 - vote for option 2 on poll in post a5
|
|
/vote a5 1,3 - vote for options 1 and 3 (if multiple choice)
|
|
/replyall a5 message - reply to all users mentioned in post a5
|
|
/ra a5 message - same as /replyall (shorter alias)
|
|
|
|
Abbreviations: /re, /th, /url, /del, /ra
|
|
Menu codes wrap around at end.
|
|
|
|
Note: /reply, /delete and /url work for direct message menu codes too!
|
|
|
|
EOF
|
|
&linein("PRESS RETURN/ENTER>");
|
|
print <<"EOF";
|
|
|
|
*** LISTS (FEDIVERSE PRIVACY-AWARE) ***
|
|
|
|
/lists - show your lists
|
|
/liston listname - add list to your timeline
|
|
/listoff listname - remove list from timeline
|
|
/again @me/listname - view posts from specific list
|
|
|
|
LIST MANAGEMENT:
|
|
/withlist listname create public - create new public list
|
|
/withlist listname create private - create new private list
|
|
/withlist listname delete - delete list (with confirmation)
|
|
/withlist listname add username - add user to list
|
|
/withlist listname delete username - remove user from list
|
|
/withlist listname desc "new description" - update description
|
|
/withlist listname name "new title" - rename list
|
|
|
|
FEDIVERSE PRIVACY: Lists respect ActivityPub privacy principles.
|
|
You can only access and manage your own lists (not other users' lists).
|
|
|
|
*** CONFIGURATION ***
|
|
|
|
Use /set to turn on options or set them at runtime.
|
|
|
|
EXAMPLES:
|
|
/set ansi 1 - Enable ANSI colors (or use -ansi command line option)
|
|
/set verify 1 - Verify posts before posting (or use -verify option)
|
|
|
|
For more options like readline support, UTF-8, SSL, proxies, etc.,
|
|
see the documentation.
|
|
|
|
*** ABOUT TTYverse ***
|
|
|
|
TTYverse $TTYverse_VERSION - Command-line fediverse client
|
|
Fediverse-only client for Mastodon, Pleroma, GoToSocial and other ActivityPub servers
|
|
Derived from TTYtter by Cameron Kaiser
|
|
|
|
This software is offered AS IS, with no guarantees.
|
|
It is not endorsed by any fediverse server operators or developers.
|
|
|
|
Supports: Mastodon, Pleroma, GoToSocial, and other ActivityPub-compatible servers
|
|
Privacy-focused: Respects fediverse privacy principles (own lists only, etc.)
|
|
Suggestions: mention \@stormux\@social.stormux.org
|
|
|
|
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;
|
|
&dmthump_no_skip if ($dmpause); # Also refresh DMs but don't skip timeline
|
|
return 0;
|
|
}
|
|
|
|
# Media upload command
|
|
if (m#^/media\s+(.+)$#) {
|
|
my $file_path = $1;
|
|
return &handle_media_upload($file_path);
|
|
}
|
|
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/^\@//;
|
|
if ($termrl) {
|
|
$readline_completion{'@'.$uname}++;
|
|
&save_completion_cache;
|
|
}
|
|
print $stdout
|
|
"-- synchronous /again command for $uname ($countmaybe)\n"
|
|
if ($verbose);
|
|
|
|
# Look up account ID for the username
|
|
my $account_id = &lookup_account_id($uname);
|
|
if (!$account_id) {
|
|
&report_account_not_found($uname, 1);
|
|
return 0;
|
|
}
|
|
|
|
# Use proper Mastodon API endpoint with account ID
|
|
my $user_statuses_url = $uurl;
|
|
$user_statuses_url =~ s/%I/$account_id/g;
|
|
my $my_json_ref = &grabjson($user_statuses_url, 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/^\@//;
|
|
if ($termrl) {
|
|
$readline_completion{'@'.$uname}++;
|
|
&save_completion_cache;
|
|
}
|
|
print $stdout "-- synchronous /whois command for $uname\n"
|
|
if ($verbose);
|
|
|
|
# Look up account ID for the username
|
|
my $account_id = &lookup_account_id($uname);
|
|
if (!$account_id) {
|
|
&report_account_not_found($uname, 1);
|
|
return 0;
|
|
}
|
|
|
|
# Use proper Mastodon API endpoint with account ID
|
|
my $user_info_url = $wurl;
|
|
$user_info_url =~ s/%I/$account_id/g;
|
|
my $my_json_ref = &grabjson($user_info_url, 0, 0, 0, undef, 1);
|
|
|
|
if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' &&
|
|
length($my_json_ref->{'username'} || $my_json_ref->{'acct'})) {
|
|
my $sturl = undef;
|
|
my $purl =
|
|
&descape($my_json_ref->{'profile_image_url'});
|
|
if ($avatar && length($purl) && $purl !~
|
|
m#^http://[^.]+\.(twimg\.com|fediverse\.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) {
|
|
# Use Mastodon relationships API with account ID
|
|
my $relationship_url = $blockingurl;
|
|
$relationship_url =~ s/%I/$account_id/g;
|
|
my $g = &grabjson($relationship_url, 0, 0, 0, undef, 1);
|
|
|
|
if (ref($g) eq 'ARRAY' && @$g > 0) {
|
|
my $rel = $g->[0]; # relationships API returns array
|
|
print $streamout &wwrap(
|
|
"${EM}Do you follow${OFF} this user? ... ${EM}$rel->{'following'}${OFF}\n");
|
|
print $streamout &wwrap(
|
|
"${EM}Does this user follow${OFF} you? ... ${EM}$rel->{'followed_by'}${OFF}\n");
|
|
}
|
|
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;
|
|
}
|
|
# Note: Fediverse APIs don't support checking arbitrary user relationships
|
|
# You can only check your own relationships via /api/v1/accounts/relationships
|
|
print $stdout "-- Sorry, /doesfollow is not supported in fediverse (privacy feature)\n";
|
|
print $stdout "-- You can only check your own relationships with /whois \@username\n";
|
|
return 0;
|
|
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 {
|
|
# List members/followers - fediverse only supports list members, not subscribers
|
|
if ($mode eq 'fos' || $mode eq 'followers') {
|
|
print $stdout "-- Sorry, fediverse lists don't have followers/subscribers (privacy feature)\n";
|
|
return 0;
|
|
}
|
|
|
|
# Check list ownership (fediverse privacy)
|
|
if ($who ne $whoami) {
|
|
print $stdout "-- Sorry, fediverse only allows access to your own list members (privacy feature)\n";
|
|
return 0;
|
|
}
|
|
|
|
# Look up list ID
|
|
my $list_id = &lookup_list_id($lname);
|
|
if (!$list_id) {
|
|
print $stdout "*** list '$lname' not found; use /lists to see available lists\n";
|
|
return 0;
|
|
}
|
|
|
|
$what = "list members";
|
|
$mode = $getliurl;
|
|
$mode =~ s/%I/$list_id/g;
|
|
$user = ""; # No additional parameters needed
|
|
$who = "list $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;
|
|
}
|
|
|
|
# Look up account ID for the username
|
|
my $account_id = &lookup_account_id($who);
|
|
if (!$account_id) {
|
|
&report_account_not_found($who, 1);
|
|
return 0;
|
|
}
|
|
|
|
# Use proper Mastodon API endpoint with account ID
|
|
my $followers_url = $mode;
|
|
$followers_url =~ s/%I/$account_id/g;
|
|
my $accounts_ref = &grabjson("$followers_url?limit=${countmaybe}", 0, 0, 0, undef, 1);
|
|
return 0 if (!$accounts_ref || ref($accounts_ref) ne 'ARRAY');
|
|
|
|
# Fediverse (Mastodon/Pleroma/etc) returns array of account objects, extract IDs
|
|
my @ids = map { $_->{'id'} } @{ $accounts_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}?limit=${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 $post = &get_post($code);
|
|
if (!defined($post)) {
|
|
print $stdout "-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
my $limit = 9;
|
|
my $id = $post->{'reblog'}->{'id_str'} ||
|
|
$post->{'in_reply_to_status_id_str'};
|
|
my $thread_ref = [ $post ];
|
|
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->{'reblog'}->{'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 posts.
|
|
# 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 post since we're going to fetch it anyway.
|
|
$hash = { "id_str" => $code };
|
|
$thing = "post";
|
|
$genurl = $idurl;
|
|
} elsif ($code =~ /^d.[0-9]+$/) {
|
|
$hash = &get_dm($code);
|
|
$thing = "DM";
|
|
$genurl = $dmidurl;
|
|
} else {
|
|
$hash = &get_post($code);
|
|
$thing = "post";
|
|
$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 reposted status, get the status.
|
|
$hash = $hash->{'reblog'}
|
|
if (defined($hash->{'reblog'}) &&
|
|
ref($hash->{'reblog'}) eq 'HASH');
|
|
|
|
my $didprint = 0;
|
|
# fediverse 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 $post;
|
|
my $genurl = undef;
|
|
$urlshort = undef;
|
|
|
|
if ($code =~ /^d/ && length($code) > 2) {
|
|
$post = &get_dm($code); # USO!
|
|
if (!defined($post)) {
|
|
print $stdout
|
|
"-- no such DM (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
$genurl = $dmidurl;
|
|
} else {
|
|
$post = &get_post($code);
|
|
if (!defined($post)) {
|
|
print $stdout
|
|
"-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
$genurl = $idurl;
|
|
}
|
|
|
|
# Extract URLs from Mastodon post content
|
|
my $didprint = 0;
|
|
|
|
# First, try to get the FULL post data from the API to access structured URL fields
|
|
my $full_post = undef;
|
|
if (defined($genurl) && defined($post->{'id_str'})) {
|
|
my $post_id = $post->{'id_str'};
|
|
# Replace %I placeholder with actual post ID
|
|
my $api_url = $genurl;
|
|
$api_url =~ s/%I/$post_id/g;
|
|
print STDERR "-- DEBUG: Fetching full post data from API for URL extraction: $api_url\n" if ($superverbose);
|
|
$full_post = &grabjson($api_url, 0, 0, 0, undef, 1);
|
|
}
|
|
|
|
# Use full post data if available, otherwise fall back to cached data
|
|
my $working_post = (defined($full_post) && ref($full_post) eq 'HASH') ? $full_post : $post;
|
|
|
|
# DEBUG: Show what we have in the post structure
|
|
print STDERR "-- DEBUG: URL parsing - using " . (defined($full_post) ? "FULL" : "CACHED") . " post data\n" if ($superverbose);
|
|
print STDERR "-- DEBUG: URL parsing - post keys: " . join(", ", keys %$working_post) . "\n" if ($superverbose);
|
|
print STDERR "-- DEBUG: URL parsing - content field: '" . ($working_post->{'content'} || 'UNDEFINED') . "'\n" if ($superverbose);
|
|
print STDERR "-- DEBUG: URL parsing - text field: '" . ($working_post->{'text'} || 'UNDEFINED') . "'\n" if ($superverbose);
|
|
|
|
# PRIORITY 1: Extract URLs from Mastodon's structured URL data (card/preview_url)
|
|
if (defined($working_post->{'card'}) && ref($working_post->{'card'}) eq 'HASH') {
|
|
my $card = $working_post->{'card'};
|
|
if (defined($card->{'url'}) && length($card->{'url'})) {
|
|
print STDERR "-- DEBUG: Found card URL: " . $card->{'url'} . "\n" if ($superverbose);
|
|
&openurl($card->{'url'});
|
|
$didprint++;
|
|
}
|
|
}
|
|
|
|
# PRIORITY 2: Extract URLs from preview_url field (some servers use this)
|
|
if (!$didprint && defined($working_post->{'preview_url'}) && length($working_post->{'preview_url'})) {
|
|
print STDERR "-- DEBUG: Found preview_url: " . $working_post->{'preview_url'} . "\n" if ($superverbose);
|
|
&openurl($working_post->{'preview_url'});
|
|
$didprint++;
|
|
}
|
|
|
|
# PRIORITY 3: Media attachments
|
|
if (!$didprint && defined($working_post->{'media_attachments'}) &&
|
|
ref($working_post->{'media_attachments'}) eq 'ARRAY') {
|
|
foreach my $media (@{ $working_post->{'media_attachments'} }) {
|
|
if (defined($media->{'url'}) && length($media->{'url'})) {
|
|
print STDERR "-- DEBUG: Found media URL: " . $media->{'url'} . "\n" if ($superverbose);
|
|
&openurl($media->{'url'});
|
|
$didprint++;
|
|
}
|
|
}
|
|
}
|
|
|
|
# PRIORITY 4: Parse URLs from HTML content (href attributes)
|
|
if (!$didprint) {
|
|
my $content = $working_post->{'content'} || $working_post->{'text'} || '';
|
|
if (length($content)) {
|
|
# Extract URLs from href attributes in HTML
|
|
while ($content =~ s/<a[^>]+href=["']([^"']+)["'][^>]*>[^<]*<\/a>//i) {
|
|
my $url = $1;
|
|
next if ($url =~ /^#/); # Skip hashtag links
|
|
next if ($url =~ /^\@/); # Skip mention links
|
|
print STDERR "-- DEBUG: Found HTML href URL: " . $url . "\n" if ($superverbose);
|
|
&openurl($url);
|
|
$didprint++;
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($didprint) {
|
|
return 0;
|
|
}
|
|
# PRIORITY 5: Final fallback - parse plain text URLs from display text
|
|
# This handles truncated URLs in display text as a last resort
|
|
if (!$didprint) {
|
|
# Re-get content since we may have modified it above with regex substitutions
|
|
my $original_content = $working_post->{'content'} || $working_post->{'text'} || '';
|
|
my $plain_content = &html_to_text($original_content);
|
|
$plain_content = &descape($plain_content);
|
|
|
|
print STDERR "-- DEBUG: Parsing plain text content: '$plain_content'\n" if ($superverbose);
|
|
|
|
# findallurls - extract any remaining URLs from plain text
|
|
# First try URLs with protocols
|
|
while ($plain_content
|
|
=~ s#(h?ttp|h?ttps|ftp|gopher)://([a-zA-Z0-9_~/:%\-\+\.\=\&\?\#,]+)##){
|
|
my $url = $1 . "://$2";
|
|
$url = "h$url" if ($url =~ /^ttps?:/);
|
|
$url =~ s/[\.\?]$//;
|
|
print STDERR "-- DEBUG: Found plain text URL with protocol: " . $url . "\n" if ($superverbose);
|
|
&openurl($url);
|
|
$didprint++;
|
|
}
|
|
|
|
# Then try URLs without protocols (assume https) - WARNING: may be truncated
|
|
while ($plain_content
|
|
=~ s#\b([a-zA-Z0-9\-]+\.[a-zA-Z]{2,}(?:/[a-zA-Z0-9_~/%:\-\+\.\=\&\?\#,]*)?)\b##){
|
|
my $url = "https://$1";
|
|
$url =~ s/[\.\?]$//;
|
|
print STDERR "-- DEBUG: Found plain text URL without protocol (may be truncated): " . $url . "\n" if ($superverbose);
|
|
print $stdout "-- WARNING: URL may be truncated from display text: $url\n";
|
|
&openurl($url);
|
|
$didprint++;
|
|
}
|
|
}
|
|
|
|
print $stdout "-- sorry, couldn't find any URL.\n"
|
|
if (!$didprint);
|
|
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) {
|
|
# Look up account ID for the username
|
|
my $account_id = &lookup_account_id($_);
|
|
if (!$account_id) {
|
|
print $stdout "-- ERROR: Could not find account for user: $_\n";
|
|
return 0;
|
|
}
|
|
|
|
# Use fediverse accounts/{id}/favourites endpoint
|
|
$my_json_ref = &grabjson("${apibase}/accounts/${account_id}/favourites?limit=${countmaybe}",
|
|
0, 0, 0, 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(boost|a|av|ave|avorite|avourite)? ([zZ]?[a-zA-Z]?[0-9]+)$#) {
|
|
my $mode = $1;
|
|
my $secondmode = $2;
|
|
my $code = lc($3);
|
|
$secondmode = ($secondmode eq 'boost') ? 'boost' : $secondmode;
|
|
if ($mode eq 'un' && $secondmode eq 'boost') {
|
|
print $stdout
|
|
"-- hmm. seems contradictory. no dice.\n";
|
|
return 0;
|
|
}
|
|
my $post = &get_post($code);
|
|
if (!defined($post)) {
|
|
print $stdout "-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
&cordfav($post->{'id_str'}, 1,
|
|
(($mode eq 'un') ? $favdelurl : $favurl),
|
|
&descape($post->{'text'}),
|
|
(($mode eq 'un') ? 'removed' : 'created'));
|
|
if ($secondmode eq 'boost') {
|
|
$_ = "/boost $code";
|
|
# and fall through
|
|
} else {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# Boost API (fediverse equivalent of reposts)
|
|
if (s#^/([oe]?)boost ([zZ]?[a-zA-Z]?[0-9]+)\s*##) {
|
|
my $mode = $1;
|
|
my $code = lc($2);
|
|
my $post = &get_post($code);
|
|
if (!defined($post)) {
|
|
print $stdout "-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
# use a native repost unless we can't (or user used /ort /ert)
|
|
unless ($noreblogs || length || length($mode)) {
|
|
# we don't always get rs->text, so we simulate it.
|
|
my $text = &descape($post->{'text'});
|
|
$text =~ s/^RT \@[^\s]+:\s+//
|
|
if ($post->{'reblog'}->{'id_str'});
|
|
print $stdout "-- status boosted\n"
|
|
unless(&updatest($text, 1, 0, undef,
|
|
$post->{'reblog'}->{'id_str'}
|
|
|| $post->{'id_str'}));
|
|
return 0;
|
|
}
|
|
# we can't or user requested /ert /ort
|
|
$repost = "boost @" .
|
|
&descape($post->{'user'}->{'acct'} || $post->{'user'}->{'username'}) .
|
|
": " . &descape($post->{'text'});
|
|
if ($mode eq 'e') {
|
|
&add_history($repost);
|
|
print $stdout &wwrap(
|
|
"-- ok, %RT% and %% are now \"$repost\"\n");
|
|
return 0;
|
|
}
|
|
$_ = (length) ? "$repost $_" : $repost;
|
|
print $stdout &wwrap("(expanded to \"$_\")");
|
|
print $stdout "\n";
|
|
goto POSTPRINT; # fugly! FUGLY!
|
|
}
|
|
|
|
if (m#^/(re)?rts?of?me?(\s+\+\d+)?$# && !$noreblogs) {
|
|
#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;
|
|
|
|
# "Reposts of me" not available in fediverse (privacy feature)
|
|
print $stdout "-- Sorry, fediverse doesn't provide 'reposts of me' (privacy feature)\n";
|
|
return 0;
|
|
}
|
|
if (m#^/rts?of\s+([zZ]?[a-zA-Z]?[0-9]+)$# && !$noreblogs) {
|
|
my $code = lc($1);
|
|
my $post = &get_post($code);
|
|
my $id;
|
|
|
|
if (!defined($post)) {
|
|
print $stdout "-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
$id = $post->{'reblog'}->{'id_str'} ||
|
|
$post->{'id_str'};
|
|
if (!$id) {
|
|
print $stdout "-- hmmm, that post is major bogus.\n";
|
|
return 0;
|
|
}
|
|
my $url = $boostsbyurl;
|
|
$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 boosters, 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 -noreblogs
|
|
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 $post = &get_post($code);
|
|
if (!defined($post)) {
|
|
print $stdout "-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
if (lc(&descape($post->{'user'}->{'username'} || $post->{'user'}->{'acct'}))
|
|
ne lc($whoami)) {
|
|
print $stdout
|
|
"-- not allowed to delete somebody's else's posts\n";
|
|
return 0;
|
|
}
|
|
print $stdout &wwrap(
|
|
"-- verify you want to delete: \"@{[ &descape($post->{'text'}) ]}\"");
|
|
print $stdout "\n";
|
|
$answer = lc(&linein(
|
|
"-- sure you want to delete? (only y or Y is affirmative):"));
|
|
if ($answer ne 'y') {
|
|
print $stdout "-- ok, post is NOT deleted.\n";
|
|
return 0;
|
|
}
|
|
$lastpostid = -1 if ($post->{'id_str'} == $lastpostid);
|
|
&deletest($post->{'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;
|
|
}
|
|
my $sender = &descape($dm->{'last_status'}->{'account'}->{'username'} || $dm->{'last_status'}->{'account'}->{'acct'});
|
|
my $text = &descape(&html_to_text($dm->{'last_status'}->{'content'}));
|
|
print $stdout &wwrap(
|
|
"-- verify you want to delete: " .
|
|
"(from \@${sender}) \"${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, post 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 $post = &get_post($code);
|
|
if (!defined($post)) {
|
|
print $stdout "-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
# Use Mastodon's acct field (includes @domain for remote users) or username for local users
|
|
my $target;
|
|
my $acct = &descape($post->{'user'}->{'acct'} || $post->{'user'}->{'username'});
|
|
$target = $acct;
|
|
|
|
# If acct doesn't include @domain and this is a remote post, construct it
|
|
if ($acct !~ /\@/ && $post->{'url'} && $post->{'url'} =~ m{^https?://([^/]+)/}) {
|
|
my $domain = $1;
|
|
if ($domain ne $fediverseserver) {
|
|
$target = "$acct\@$domain";
|
|
}
|
|
}
|
|
print $stdout "-- DEBUG: Reply target acct='$post->{'user'}->{'acct'}', username='$post->{'user'}->{'username'}', url='$post->{'url'}', using='$target'\n" if ($verbose);
|
|
$_ = '@' . $target . " $_";
|
|
unless ($mode eq 'v') {
|
|
$in_reply_to = $post->{'id_str'};
|
|
$expected_post_ref = $post;
|
|
} else {
|
|
$_ = ".$_";
|
|
}
|
|
if ($termrl) {
|
|
$readline_completion{'@'.lc($target)}++;
|
|
&save_completion_cache;
|
|
}
|
|
print $stdout &wwrap("(expanded to \"$_\")");
|
|
print $stdout "\n";
|
|
goto POSTPRINT; # 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->{'last_status'}->{'account'}->{'acct'} || $dm->{'last_status'}->{'account'}->{'username'});
|
|
if ($termrl) {
|
|
$readline_completion{'@'.lc($target)}++;
|
|
&save_completion_cache;
|
|
}
|
|
$_ = "/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 $post = &get_post($code);
|
|
if (!defined($post)) {
|
|
print $stdout "-- no such post (yet?): $code\n";
|
|
return 0;
|
|
}
|
|
# Use Mastodon's acct field (includes @domain for remote users) or username for local users
|
|
my $target;
|
|
my $acct = &descape($post->{'user'}->{'acct'} || $post->{'user'}->{'username'});
|
|
$target = $acct;
|
|
|
|
# If acct doesn't include @domain and this is a remote post, construct it
|
|
if ($acct !~ /\@/ && $post->{'url'} && $post->{'url'} =~ m{^https?://([^/]+)/}) {
|
|
my $domain = $1;
|
|
if ($domain ne $fediverseserver) {
|
|
$target = "$acct\@$domain";
|
|
}
|
|
}
|
|
my $text = $_;
|
|
$_ = '@' . $target;
|
|
unless ($mode eq 'v') {
|
|
$in_reply_to = $post->{'id_str'};
|
|
$expected_post_ref = $post;
|
|
} else {
|
|
$_ = ".$_";
|
|
}
|
|
|
|
# don't repeat the target or myself; track other mentions
|
|
my %did_mentions = map { $_ => 1 } (lc($target));
|
|
my $reply_post = &descape($post->{'text'});
|
|
|
|
while($reply_post =~ s/\@(\w+(?:\@[\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
|
|
if ($termrl) {
|
|
grep { $readline_completion{'@'.$_}++ } (keys %did_mentions);
|
|
&save_completion_cache;
|
|
}
|
|
|
|
# and fall through to post
|
|
print $stdout &wwrap("(expanded to \"$_\")");
|
|
print $stdout "\n";
|
|
goto POSTPRINT; # 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;
|
|
}
|
|
|
|
# Timeline management commands
|
|
if ($_ eq '/timelines') {
|
|
print $stdout <<"EOF";
|
|
Available timelines:
|
|
/timeline home - Your main feed (default)
|
|
/timeline public - Local public timeline
|
|
/timeline federated - Federated public timeline
|
|
/timeline notifications - Your notifications (mentions, boosts, etc.)
|
|
/timeline bookmarks - Your bookmarked posts
|
|
/timeline favourites - Your favourite posts
|
|
|
|
Current timeline: home
|
|
EOF
|
|
return 0;
|
|
}
|
|
|
|
if (m#^/timeline\s+(\w+)(\s+\+\d+)?$#) {
|
|
my $timeline_name = lc($1);
|
|
my $countmaybe = $2;
|
|
$countmaybe =~ s/[^\d]//g if (length($countmaybe));
|
|
$countmaybe += 0;
|
|
|
|
my $timeline_url;
|
|
my $timeline_display_name;
|
|
|
|
# Map timeline names to API endpoints
|
|
if ($timeline_name eq 'home') {
|
|
$timeline_url = "${apibase}/timelines/home";
|
|
$timeline_display_name = "home feed";
|
|
} elsif ($timeline_name eq 'public') {
|
|
$timeline_url = "${apibase}/timelines/public?local=true";
|
|
$timeline_display_name = "local public timeline";
|
|
} elsif ($timeline_name eq 'federated') {
|
|
$timeline_url = "${apibase}/timelines/public";
|
|
$timeline_display_name = "federated timeline";
|
|
} elsif ($timeline_name eq 'notifications') {
|
|
$timeline_url = "${apibase}/notifications";
|
|
$timeline_display_name = "notifications";
|
|
} elsif ($timeline_name eq 'bookmarks') {
|
|
$timeline_url = "${apibase}/bookmarks";
|
|
$timeline_display_name = "bookmarks";
|
|
} elsif ($timeline_name eq 'favourites' || $timeline_name eq 'favorites') {
|
|
$timeline_url = "${apibase}/favourites";
|
|
$timeline_display_name = "favourites";
|
|
} else {
|
|
print $stdout "-- unknown timeline: $timeline_name\n";
|
|
print $stdout "-- use /timelines to see available timelines\n";
|
|
return 0;
|
|
}
|
|
|
|
print $stdout "-- fetching $timeline_display_name...\n" if ($verbose);
|
|
my $my_json_ref = &grabjson($timeline_url, 0, 0, $countmaybe || 20, undef, 1);
|
|
|
|
if ($timeline_name eq 'notifications') {
|
|
# Notifications need individual type mapping for sound alerts
|
|
¬ifications_tdisplay($my_json_ref);
|
|
} else {
|
|
&dt_tdisplay($my_json_ref, $timeline_name);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# Visibility management commands
|
|
if ($_ eq '/visibility') {
|
|
my @visibilities = ('public', 'unlisted', 'private', 'direct');
|
|
print $stdout "Available post visibility levels:\n";
|
|
foreach my $vis (@visibilities) {
|
|
my $marker = ($vis eq $post_visibility) ? "* " : " ";
|
|
print $stdout "${marker}${vis}\n";
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
if (m#^/visibility\s+(\w+)$#) {
|
|
my $new_visibility = lc($1);
|
|
my @valid_visibilities = ('public', 'unlisted', 'private', 'direct');
|
|
|
|
if (grep { $_ eq $new_visibility } @valid_visibilities) {
|
|
$post_visibility = $new_visibility;
|
|
print $stdout "-- post visibility set to: $post_visibility\n";
|
|
} else {
|
|
print $stdout "-- invalid visibility level: $new_visibility\n";
|
|
print $stdout "-- valid options: " . join(', ', @valid_visibilities) . "\n";
|
|
}
|
|
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 eq 'sent') ? 's' : 'd';
|
|
print C "${mode}mreset${countmaybe}---------\n";
|
|
&sync_semaphore;
|
|
return 0;
|
|
}
|
|
if (s#^/dm \@?([^\s]+)\s+## && length) {
|
|
return &common_split_post($_, undef, $1);
|
|
}
|
|
|
|
# vote on polls
|
|
if (m#^/vote\s+([a-z]\d+)\s+(.+)$#i) {
|
|
my $post_code = $1;
|
|
my $choices = $2;
|
|
return &vote_on_poll($post_code, $choices);
|
|
}
|
|
|
|
# reply to all mentioned users
|
|
if (m#^/(replyall|ra|replytoall)\s+([a-z]\d+)\s+(.+)$#i) {
|
|
my $post_code = $2;
|
|
my $reply_text = $3;
|
|
return &reply_to_all($post_code, $reply_text);
|
|
}
|
|
|
|
# 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;
|
|
}
|
|
|
|
# List subscriptions not available in fediverse (privacy feature)
|
|
print $stdout "-- Sorry, fediverse doesn't support list subscriptions (privacy feature)\n";
|
|
print $stdout "-- You can only access your own lists, not follow others' lists\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 = $_;
|
|
}
|
|
|
|
# Get list ID for fediverse API operations
|
|
my $list_id = &lookup_list_id($lname);
|
|
if (!$list_id && $comm ne 'create') {
|
|
print $stdout "*** list '$lname' not found; use /lists to see available lists\n";
|
|
return 0;
|
|
}
|
|
|
|
my $return;
|
|
my $state = "modified list $lname";
|
|
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') {
|
|
my $url = $modifyliurl;
|
|
$url =~ s/%I/$list_id/;
|
|
$return = &postjson($url, "replies_policy=$comm");
|
|
} elsif ($comm eq 'desc' || $comm eq 'description') {
|
|
if (!length($args)) {
|
|
print $stdout "-- $comm needs an argument\n";
|
|
return 0;
|
|
}
|
|
my $url = $modifyliurl;
|
|
$url =~ s/%I/$list_id/;
|
|
$return = &postjson($url, "description=".&url_oauth_sub($args));
|
|
} elsif ($comm eq 'name') {
|
|
if (!length($args)) {
|
|
print $stdout "-- $comm needs an argument\n";
|
|
return 0;
|
|
}
|
|
my $url = $modifyliurl;
|
|
$url =~ s/%I/$list_id/;
|
|
$return = &postjson($url, "title=".&url_oauth_sub($args));
|
|
$state = "renamed list $lname to $args";
|
|
} 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;
|
|
}
|
|
# Convert usernames to account IDs for fediverse API
|
|
my @usernames = split(/,/, $args);
|
|
my @account_ids = ();
|
|
for my $username (@usernames) {
|
|
$username =~ s/^@//; # Remove @ if present
|
|
my $account_id = &lookup_account_id($username);
|
|
if (!$account_id) {
|
|
print $stdout "-- ERROR: Could not find account for user: $username\n";
|
|
return 0;
|
|
}
|
|
push @account_ids, $account_id;
|
|
}
|
|
|
|
my $url = $u;
|
|
$url =~ s/%I/$list_id/;
|
|
|
|
# Fediverse API expects account_ids array parameter
|
|
my $account_ids_param = join(',', @account_ids);
|
|
$return = &postjson($url, "account_ids=$account_ids_param");
|
|
} 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;
|
|
}
|
|
my $url = $delliurl;
|
|
$url =~ s/%I/$list_id/;
|
|
$return = &postjson($url, "");
|
|
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;
|
|
|
|
# In fediverse, can only access your own lists (privacy feature)
|
|
if ($uname ne $whoami) {
|
|
print $stdout "-- Sorry, fediverse only allows access to your own lists (privacy feature)\n";
|
|
return 0;
|
|
}
|
|
|
|
# Look up list ID by title
|
|
my $list_id = &lookup_list_id($lname);
|
|
if (!$list_id) {
|
|
print $stdout "*** list '$lname' not found; use /lists to see available lists\n";
|
|
return 0;
|
|
}
|
|
|
|
# Get list timeline using proper fediverse endpoint
|
|
my $list_timeline_url = $statusliurl;
|
|
$list_timeline_url =~ s/%I/$list_id/g;
|
|
my $my_json_ref = &grabjson($list_timeline_url, 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;
|
|
}
|
|
|
|
# Fediverse privacy: only allow access to own lists
|
|
if ($uname ne $whoami) {
|
|
print $stdout "-- Sorry, fediverse only allows access to your own lists (privacy feature)\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
|
|
|
|
# Build fediverse API URL
|
|
my $furl;
|
|
if (length($lname)) {
|
|
# Get specific list members
|
|
my $list_id = &lookup_list_id($lname);
|
|
if (!$list_id) {
|
|
print $stdout "*** list '$lname' not found; use /lists to see available lists\n";
|
|
return 0;
|
|
}
|
|
$furl = $getliurl;
|
|
$furl =~ s/%I/$list_id/;
|
|
} elsif ($mode eq '') {
|
|
# Get all lists for user
|
|
$furl = $getlisurl;
|
|
} else {
|
|
# Following/followers of lists - not supported in fediverse
|
|
print $stdout "-- Sorry, list following/followers not supported in fediverse (privacy feature)\n";
|
|
return 0;
|
|
}
|
|
|
|
LABIO: while($countmaybe--) {
|
|
if(!scalar(@usarray)) {
|
|
last LABIO if ($nofetch);
|
|
$json_ref = &grabjson(
|
|
"${furl}&limit=${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'}->{'username'} || $list_ref->{'user'}->{'acct'});
|
|
|
|
# listhandle?
|
|
my $list_name =
|
|
"\@".($list_ref->{'user'}->{'username'} || $list_ref->{'user'}->{'acct'})."/@{[ &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 post, type /%%\n";
|
|
return 0;
|
|
}
|
|
s#^/##; # leave the second slash on
|
|
}
|
|
|
|
POSTPRINT: # 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 (@poststack) = &csplit($k, ($autosplit eq 'char' ||
|
|
$autosplit eq 'cut') ? 1 : 0);
|
|
my $m = shift(@poststack);
|
|
if (scalar(@poststack)) {
|
|
$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(@poststack)) {
|
|
$k = shift(@poststack);
|
|
$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;
|
|
}
|
|
|
|
# vote on a poll
|
|
sub vote_on_poll {
|
|
my $post_code = shift;
|
|
my $choices = shift;
|
|
|
|
# Find the post by its menu code
|
|
my $post_ref = &findtarget($post_code);
|
|
unless ($post_ref) {
|
|
print $stdout "-- no such post: $post_code\n";
|
|
return 0;
|
|
}
|
|
|
|
# Check if post has a poll
|
|
unless (exists($post_ref->{'poll'}) && $post_ref->{'poll'}) {
|
|
print $stdout "-- post $post_code does not have a poll\n";
|
|
return 0;
|
|
}
|
|
|
|
my $poll = $post_ref->{'poll'};
|
|
|
|
# Check if poll is expired or already voted
|
|
if ($poll->{'expired'}) {
|
|
print $stdout "-- poll has expired\n";
|
|
return 0;
|
|
}
|
|
|
|
if ($poll->{'voted'}) {
|
|
print $stdout "-- you have already voted on this poll\n";
|
|
return 0;
|
|
}
|
|
|
|
# Parse choices (support both single numbers and comma-separated)
|
|
my @choice_nums = split(/[\s,]+/, $choices);
|
|
my @valid_choices = ();
|
|
my $max_options = scalar(@{$poll->{'options'}});
|
|
|
|
foreach my $choice (@choice_nums) {
|
|
$choice =~ s/\D//g; # remove non-digits
|
|
if ($choice < 1 || $choice > $max_options) {
|
|
print $stdout "-- invalid choice: $choice (must be 1-$max_options)\n";
|
|
return 0;
|
|
}
|
|
push @valid_choices, ($choice - 1); # Convert to 0-based index
|
|
}
|
|
|
|
unless (@valid_choices) {
|
|
print $stdout "-- no valid choices specified\n";
|
|
return 0;
|
|
}
|
|
|
|
# Check if multiple choices are allowed
|
|
if (!$poll->{'multiple'} && scalar(@valid_choices) > 1) {
|
|
print $stdout "-- this poll only allows single choice\n";
|
|
return 0;
|
|
}
|
|
|
|
# Submit the vote
|
|
my $post_id = $post_ref->{'id_str'} || $post_ref->{'id'};
|
|
my $vote_url = "$apibase/polls/$poll->{'id'}/votes";
|
|
|
|
# Build POST data with choices
|
|
my $post_data = '';
|
|
foreach my $choice_idx (@valid_choices) {
|
|
$post_data .= "&choices[]=$choice_idx";
|
|
}
|
|
$post_data =~ s/^&//; # remove leading &
|
|
|
|
print $stdout "-- submitting vote on poll...\n";
|
|
|
|
my $result = &backticks($useragent, '/dev/null', undef, $vote_url, $post_data, 1, @agentopts);
|
|
|
|
if ($result) {
|
|
print $stdout "-- vote submitted successfully\n";
|
|
|
|
# Show which options were selected
|
|
my @chosen_titles = ();
|
|
foreach my $choice_idx (@valid_choices) {
|
|
my $title = $poll->{'options'}->[$choice_idx]->{'title'} || '';
|
|
push @chosen_titles, ($choice_idx + 1) . ". $title";
|
|
}
|
|
print $stdout "-- voted for: " . join(', ', @chosen_titles) . "\n";
|
|
|
|
return 1;
|
|
} else {
|
|
print $stdout "-- failed to submit vote\n";
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# reply to all users mentioned in a post
|
|
sub reply_to_all {
|
|
my $post_code = shift;
|
|
my $reply_text = shift;
|
|
|
|
# Find the post by its menu code
|
|
my $post_ref = &findtarget($post_code);
|
|
unless ($post_ref) {
|
|
print $stdout "-- no such post: $post_code\n";
|
|
return 0;
|
|
}
|
|
|
|
# Get the post content and author
|
|
my $post_content = $post_ref->{'text'} || '';
|
|
my $post_author = $post_ref->{'user'}->{'acct'} || $post_ref->{'user'}->{'username'} || '';
|
|
|
|
# Set up reply-to ID
|
|
my $in_reply_to = $post_ref->{'id_str'} || $post_ref->{'id'};
|
|
|
|
# Extract all @mentions from the post content using fediverse format
|
|
my %mentioned_users = ();
|
|
|
|
# Look for @user@domain format (full fediverse mentions)
|
|
while ($post_content =~ m/(@\w+@[\w\.-]+)/g) {
|
|
my $mention = $1;
|
|
# Don't mention ourselves or the original author
|
|
unless (lc($mention) eq lc("\@$whoami") || lc($mention) eq lc("\@$post_author")) {
|
|
$mentioned_users{lc($mention)} = $mention;
|
|
}
|
|
}
|
|
|
|
# Also look for @user format (local mentions) and convert to full format
|
|
while ($post_content =~ m/(@\w+)(?!@)/g) {
|
|
my $local_mention = $1;
|
|
# Don't mention ourselves or the original author
|
|
unless (lc($local_mention) eq lc("\@$whoami") || lc($local_mention) eq lc("\@$post_author")) {
|
|
# For local mentions, we need to determine the domain
|
|
# Check if the post has mentions array with full acct info
|
|
if (exists($post_ref->{'mentions'}) && ref($post_ref->{'mentions'}) eq 'ARRAY') {
|
|
foreach my $mention_obj (@{$post_ref->{'mentions'}}) {
|
|
my $username = $mention_obj->{'username'} || '';
|
|
my $acct = $mention_obj->{'acct'} || '';
|
|
if (lc($local_mention) eq lc("\@$username") && $acct) {
|
|
$mentioned_users{lc("\@$acct")} = "\@$acct";
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Build the reply text with all mentions
|
|
my $mentions_text = '';
|
|
if (%mentioned_users) {
|
|
$mentions_text = join(' ', values %mentioned_users) . ' ';
|
|
}
|
|
|
|
# Construct the full reply: @author mentions reply_text
|
|
my $full_reply = "\@$post_author $mentions_text$reply_text";
|
|
|
|
print $stdout "-- replying to all: $full_reply\n" if ($verbose);
|
|
|
|
# Use the existing post sending mechanism
|
|
return &common_split_post($full_reply, $in_reply_to, undef);
|
|
}
|
|
|
|
# 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)) {
|
|
read(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 post 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;
|
|
$dm_display_only = 0; # Flag to suppress notifications during user-initiated /dms commands
|
|
$dm_notification_sent = 0; # Flag to prevent duplicate notifications per refresh cycle
|
|
# DM tracking now uses Mastodon's unread flag with local read tracking fallback
|
|
%dm_seen_status = (); # Hash to track seen conversation_id:last_status_id pairs
|
|
&load_dm_seen_status(); # Load persistent tracking data
|
|
$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) {
|
|
print $stdout "-- DEBUG: DM countdown: $dmcount -> " . ($dmcount - 1) . "\n" if ($verbose);
|
|
if (!--$dmcount) {
|
|
print $stdout "-- DEBUG: Triggering background DM refresh\n" if ($verbose);
|
|
&dmrefresh($interactive); # using dm_first_time
|
|
$dmcount = $dmpause;
|
|
}
|
|
} else {
|
|
print $stdout "-- DEBUG: Skipping DM countdown (interactive=$interactive)\n" if ($verbose);
|
|
}
|
|
}
|
|
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 TTYverse.
|
|
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(read(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_post($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->{'reblog'}->{'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->{'reblogs_count'} || "0") . " " .
|
|
($key->{'user'}->{'username'} || $key->{'user'}->{'acct'})." $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->{'last_status'}->{'created_at'} || 'argh, no created_at';
|
|
$ds =~ s/\s/_/g;
|
|
my $sender = $key->{'last_status'}->{'account'}->{'acct'} || $key->{'last_status'}->{'account'}->{'username'};
|
|
my $content = $key->{'last_status'}->{'content'};
|
|
$key = substr(( "$ms ".($key->{'id'})." ".
|
|
$sender." $ds ".
|
|
unpack("${pack_magic}H*", $content).
|
|
$space_pad), 0, 1024);
|
|
print P $key;
|
|
goto RESTART_SELECT;
|
|
} elsif ($rout =~ /^ki ([^\s]+) /) {
|
|
my $key = $1;
|
|
my $module;
|
|
read(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;
|
|
read(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;
|
|
read(STDIN, $module, 1024);
|
|
$module =~ s/\s+$//;
|
|
$module = pack("H*", $module);
|
|
read(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 {
|
|
read(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 =~ /^dmreset/) { # /dms (received)
|
|
$dmfetchwanted = 0+$1
|
|
if ($rout =~ /(\d+)/);
|
|
$dm_display_only = 1; # Suppress notifications for user-initiated /dms
|
|
&dmrefresh(1, 0); # interactive=1, sent_dm=0
|
|
$dm_display_only = 0; # Reset flag
|
|
&send_repaint if ($termrl);
|
|
# we do not want to force a refresh.
|
|
goto DONT_REFRESH;
|
|
} elsif ($rout =~ /^smreset/) { # /dmsent
|
|
$dmfetchwanted = 0+$1
|
|
if ($rout =~ /(\d+)/);
|
|
$dm_display_only = 1; # Suppress notifications for user-initiated /dmsent
|
|
&dmrefresh(1, 1); # interactive=1, sent_dm=1
|
|
$dm_display_only = 0; # Reset flag
|
|
&send_repaint if ($termrl);
|
|
# we do not want to force a refresh.
|
|
goto DONT_REFRESH;
|
|
}
|
|
if ($rout =~ /^dmthump_no_skip/) {
|
|
&dmrefresh(0); # Force background-style refresh to update last_dm
|
|
&send_repaint if ($termrl);
|
|
$dmcount = $dmpause;
|
|
# Don't skip - let timeline refresh continue
|
|
} elsif ($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 fediverse 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')) {
|
|
|
|
# fediverse 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;
|
|
|
|
# For fediverse servers, rate limits come from HTTP headers, not JSON endpoints
|
|
if ($authtype eq 'oauth2') {
|
|
# Fediverse servers provide rate limits in HTTP headers from any API call
|
|
# We'll extract them from the next API response we make
|
|
$rate_limit_left = 300; # Default assumption for fediverse
|
|
$rate_limit_rate = 300; # Most fediverse servers are quite generous
|
|
} else {
|
|
# fediverse OAuth 1.0a rate limiting (legacy)
|
|
$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/posts,
|
|
# choose the MOST restrictive and normalize that.
|
|
|
|
$rate_limit_left = &min(
|
|
0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/home_timeline'}->{'remaining'},
|
|
&min(
|
|
0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/mentions_timeline'}->{'remaining'},
|
|
0+$rate_limit_ref->{'resources'}->{'search'}->{'\\/search\\/posts'}->{'remaining'}));
|
|
$rate_limit_rate = &min(
|
|
0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/home_timeline'}->{'limit'},
|
|
&min(
|
|
0+$rate_limit_ref->{'resources'}->{'statuses'}->{'\\/statuses\\/mentions_timeline'}->{'limit'},
|
|
0+$rate_limit_ref->{'resources'}->{'search'}->{'\\/search\\/posts'}->{'limit'}));
|
|
}
|
|
}
|
|
if ($rate_limit_left < 3 && $rate_limit_rate) {
|
|
$estring =
|
|
"*** warning: API rate limit imminent";
|
|
if ($pause eq 'auto') {
|
|
$estring .=
|
|
"; temporarily halting autofetch";
|
|
$effpause = 0;
|
|
}
|
|
&$exception(5, "$estring\n");
|
|
} else {
|
|
if ($pause eq 'auto') {
|
|
|
|
# the new rate limits do not require us to reduce our fetching for mentions,
|
|
# direct messages or search, because they pull from different buckets, and
|
|
# their rate limits are roughly the same.
|
|
$effpause = 5*$rate_limit_rate;
|
|
# Cap refresh rate for fediverse servers (generous rate limits)
|
|
if ($effpause > 120) {
|
|
$effpause = 120; # Maximum 2 minutes for fediverse
|
|
}
|
|
# this will usually be 120s (fediverse rate limit cap)
|
|
# 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) {
|
|
if ($authtype eq 'oauth2') {
|
|
print $stdout
|
|
"-- rate limit info unavailable: using 30 second fallback\n";
|
|
$effpause = 30; # More reasonable for fediverse
|
|
} else {
|
|
print $stdout
|
|
"-- rate limit rate failure: using 180 second fallback\n";
|
|
$effpause = 180; # fediverse fallback
|
|
}
|
|
}
|
|
|
|
# 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':
|
|
'';
|
|
print $stdout
|
|
"-- 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);
|
|
# }
|
|
|
|
# Fediverse fallback: ensure auto-refresh works even if rate limiting fails
|
|
if (defined($pause) && $pause eq 'auto' && (!defined($effpause) || $effpause == 0)) {
|
|
$effpause = 120; # 2 minutes - consistent with fediverse cap
|
|
print $stdout "-- using fallback refresh rate: $effpause seconds\n";
|
|
}
|
|
|
|
# Debug: always show current effpause value
|
|
print $stdout "-- current effpause: " . (defined($effpause) ? $effpause : 'undefined') . " seconds\n" if ($verbose);
|
|
}
|
|
|
|
# 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 = "TTYverse (streaming buffer thread)";
|
|
$in_buffer = 1;
|
|
# set up signal handlers
|
|
$streampid = 0;
|
|
&sigify(sub {
|
|
# in an earlier version we wrote a disconnect packet to the
|
|
# pipe in this handler. THIS IS NOT SAFE on certain OS/Perl
|
|
# combinations. I moved this down to the HELLOAGAINNURSE loop,
|
|
# or otherwise you get random seg faults.
|
|
$i = $streampid;
|
|
$streampid = 0;
|
|
waitpid $i, 0 if ($i);
|
|
}, qw(CHLD PIPE));
|
|
&sigify(sub {
|
|
$i = $streampid;
|
|
$streampid = 0; # suppress handler above
|
|
kill ($SIGHUP, $i) if ($i);
|
|
waitpid $i, 0 if ($i);
|
|
kill 9, $curlpid if ($curlpid && !$i);
|
|
kill 9, $$;
|
|
}, qw(HUP TERM));
|
|
&sigify("IGNORE", qw(INT));
|
|
|
|
$packets_read = 0; # part of exponential backoff
|
|
$wait_time = 0;
|
|
|
|
# open the nurse process
|
|
HELLOAGAINNURSE: $w = "{\"packet\" : \"connect\", \"payload\" : {} }";
|
|
select(STDOUT); $|++;
|
|
printf STDOUT ("%08x%s", length($w), $w);
|
|
close(NURSE);
|
|
if (!$packets_read) { $wait_time += (($wait_time) ? $wait_time : 1) }
|
|
else { $wait_time = 0; }
|
|
$packets_read = 0;
|
|
$wait_time = ($wait_time > 60) ? 60 : $wait_time;
|
|
if ($streampid = open(NURSE, "-|")) {
|
|
# within the buffer process
|
|
select(NURSE); $|++; select(STDOUT);
|
|
my $rin = '';
|
|
vec($rin,fileno(NURSE),1) = 1;
|
|
my $datasize = 0;
|
|
my $buf = '';
|
|
my $cuf = '';
|
|
my $duf = '';
|
|
|
|
# read the curlpid from the stream
|
|
read(NURSE, $curlpax, 8);
|
|
$curlpid = hex($curlpax);
|
|
|
|
# if we are testing the socket, just emit data.
|
|
if ($streamtest) {
|
|
my $c;
|
|
|
|
for(;;) {
|
|
sysread(NURSE, $c, 1);
|
|
print STDOUT $c;
|
|
}
|
|
}
|
|
HELLONURSE: while(1) {
|
|
# restart nurse process if it/curl died
|
|
goto HELLOAGAINNURSE if(!$streampid);
|
|
|
|
# read a line of text (hopefully numbers)
|
|
chomp($buf = <NURSE>);
|
|
# should be nothing but digits and whitespace.
|
|
# if anything else, we're getting garbage, and we
|
|
# should reconnect.
|
|
if ($buf =~ /[^0-9\r\l\n\s]+/s) {
|
|
close(NURSE);
|
|
kill 9, $streampid if ($streampid);
|
|
# and SIGCHLD will reap
|
|
kill 9, $curlpid if ($curlpid);
|
|
goto HELLOAGAINNURSE;
|
|
}
|
|
$datasize = 0+$buf;
|
|
next HELLONURSE if (!$datasize);
|
|
$datasize--;
|
|
read(NURSE, $duf, $datasize);
|
|
# don't send broken entries
|
|
next HELLONURSE if (length($duf) < $datasize);
|
|
# yank out all \r\n
|
|
1 while $duf =~ s/[\r\n]//g;
|
|
$duf = "{ \"packet\" : \"data\", \"pid\" : \"$streampid\", \"curlpid\" : \"$curlpid\", \"payload\" : $duf }";
|
|
printf STDOUT ("%08x%s", length($duf), $duf);
|
|
$packets_read++;
|
|
}
|
|
} else {
|
|
# within the nurse process
|
|
$0 = "TTYverse (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
|
|
# Build streaming URL with appropriate parameters
|
|
my $stream_endpoint;
|
|
if ($authtype eq 'oauth2') {
|
|
# Mastodon streaming - use Server-Sent Events
|
|
$stream_endpoint = "$streamurl?stream=user";
|
|
} else {
|
|
# fediverse legacy streaming
|
|
$stream_endpoint = "$streamurl?delimited=length${replarg}";
|
|
}
|
|
|
|
($comm, $args, $data) = &$stringify_args($baseagent,
|
|
[ $stream_endpoint ],
|
|
undef, undef,
|
|
'-s',
|
|
'-A', "TTYverse_Streaming/$TTYverse_VERSION",
|
|
'-N',
|
|
'-H', 'Expect:');
|
|
($curlpid = open(K, "|$comm")) || die("failed curl: $!\n");
|
|
printf STDOUT ("%08x", $curlpid);
|
|
|
|
# "DIE QUICKLY"
|
|
$0 = "TTYverse (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;
|
|
|
|
# Handle both fediverse (legacy) and Mastodon streaming formats
|
|
if ($authtype eq 'oauth2') {
|
|
# Mastodon streaming format - events have 'event' and 'payload' fields
|
|
next unless (exists($w->{'event'}) && exists($w->{'payload'}));
|
|
&handle_mastodon_stream_event($w);
|
|
} else {
|
|
# fediverse legacy format
|
|
next if ($w->{'packet'} ne 'data');
|
|
&handle_fediverse_stream_event($w);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub handle_fediverse_stream_event {
|
|
my $w = shift;
|
|
my $tmp;
|
|
|
|
# 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).
|
|
return if ($w->{'payload'}->{'friends'});
|
|
|
|
sleep 5 while ($suspend_output > 0);
|
|
|
|
# dispatch posts
|
|
if ($w->{'payload'}->{'text'} && !$notimeline) {
|
|
# normalize the post 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 $posttype to determine
|
|
# this so the user can interpose custom logic.
|
|
if ($nostreamreplies) {
|
|
my $sn = &descape(
|
|
$payload->{'user'}->{'username'} || $payload->{'user'}->{'acct'});
|
|
my $text = &descape($payload->{'text'});
|
|
return if (&$posttype($payload, $sn, $text) eq
|
|
'reply');
|
|
}
|
|
|
|
# finally, filter everything else and dedupe.
|
|
unless (length($id_cache{$sid}) ||
|
|
$filter_next{$sid} ||
|
|
$main::k{$sid}) {
|
|
&tdisplay([ $payload ]);
|
|
$main::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'}->{'username'} || $w->{'source'}->{'acct'});
|
|
if (!length($sou_sn) || !$filterusers_sub ||
|
|
!&$filterusers_sub($sou_sn)) {
|
|
&send_removereadline if ($termrl);
|
|
&$eventhandle($w);
|
|
$wrapseq = 1;
|
|
&send_repaint if ($termrl);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub handle_mastodon_stream_event {
|
|
my $w = shift;
|
|
my $event_type = $w->{'event'};
|
|
my $payload_json = $w->{'payload'};
|
|
|
|
# Parse the JSON payload (Mastodon sends JSON as string)
|
|
my $payload = &map_mastodon_fields(&parsejson($payload_json));
|
|
|
|
sleep 5 while ($suspend_output > 0);
|
|
|
|
# Handle different Mastodon event types
|
|
if ($event_type eq 'update' && !$notimeline) {
|
|
# New status/post
|
|
my $sid = $payload->{'id_str'} || $payload->{'id'};
|
|
|
|
$payload->{'tag'}->{'type'} = 'timeline';
|
|
$payload->{'tag'}->{'payload'} = 'stream';
|
|
|
|
# Filter replies if requested
|
|
if ($nostreamreplies) {
|
|
my $sn = &descape($payload->{'user'}->{'username'} || $payload->{'user'}->{'acct'});
|
|
my $text = &descape($payload->{'text'});
|
|
return if (&$posttype($payload, $sn, $text) eq 'reply');
|
|
}
|
|
|
|
# Filter and dedupe
|
|
unless (length($id_cache{$sid}) ||
|
|
$filter_next{$sid} ||
|
|
$main::k{$sid}) {
|
|
&tdisplay([ $payload ]);
|
|
$main::k{$sid}++;
|
|
}
|
|
|
|
$last_id = $sid unless (!$last_id);
|
|
}
|
|
elsif ($event_type eq 'delete') {
|
|
# Status deleted - payload is just the ID
|
|
print $streamout "-- post $payload_json deleted\n" if ($verbose);
|
|
}
|
|
elsif ($event_type eq 'notification') {
|
|
# New notification (follow, mention, boost, favourite)
|
|
&send_removereadline if ($termrl);
|
|
&$eventhandle($payload);
|
|
$wrapseq = 1;
|
|
&send_repaint if ($termrl);
|
|
}
|
|
elsif ($event_type eq 'conversation') {
|
|
# Direct message update
|
|
if ($dmpause) {
|
|
&dmrefresh(0, 0, [ $payload ]);
|
|
}
|
|
}
|
|
else {
|
|
# Unknown event type
|
|
print $streamout "-- unknown streaming event: $event_type\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
# 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 post 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 $since_id = ($dostream) ? $last_id : $fetch_id;
|
|
print $stdout "-- DEBUG: Calling timeline API with since_id='$since_id', dostream=$dostream, last_id='$last_id', fetch_id='$fetch_id'\n" if ($verbose);
|
|
my $base_json_ref = &grabjson($url,
|
|
$since_id,
|
|
0,
|
|
(($last_id) ? 250 : $fetchwanted || $backload), {
|
|
"type" => "timeline",
|
|
"payload" => "api"
|
|
}, 1);
|
|
# if I can't get my own timeline, ABORT! highest priority!
|
|
if (!defined($base_json_ref) || ref($base_json_ref) ne 'ARRAY') {
|
|
print $stdout "-- DEBUG: grabjson failed for timeline - base_json_ref is " .
|
|
(defined($base_json_ref) ? ref($base_json_ref) : 'undefined') . "\n" if ($verbose);
|
|
return;
|
|
}
|
|
print $stdout "-- DEBUG: grabjson returned " . scalar(@{ $base_json_ref }) . " posts from timeline\n" if ($verbose);
|
|
|
|
# we have to filter against the ID cache right now, because
|
|
# we might not have any other streams!
|
|
if ($fetch_id && $last_id) {
|
|
print $stdout "-- DEBUG: Filtering timeline posts (fetch_id=$fetch_id, last_id=$last_id)\n" if ($verbose);
|
|
$my_json_ref = [];
|
|
my $l;
|
|
my %k; # need temporary dedupe
|
|
my $filtered_count = 0;
|
|
foreach $l (@{ $base_json_ref }) {
|
|
if (length($id_cache{$l->{'id_str'}}) ||
|
|
$filter_next{$l->{'id_str'}} ||
|
|
$k{$l->{'id_str'}}) {
|
|
$filtered_count++;
|
|
} else {
|
|
push(@{ $my_json_ref }, $l);
|
|
$k{$l->{'id_str'}}++;
|
|
}
|
|
}
|
|
print $stdout "-- DEBUG: After filtering: " . scalar(@{ $my_json_ref }) . " posts remain, $filtered_count filtered out\n" if ($verbose);
|
|
} else {
|
|
print $stdout "-- DEBUG: No filtering applied (fetch_id=$fetch_id, last_id=$last_id)\n" if ($verbose);
|
|
$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) {
|
|
# Fediverse privacy: only allow access to own lists
|
|
if ($k->[0] ne $whoami) {
|
|
print $stdout "-- Skipping $k->[0]/$k->[1]: fediverse only allows access to your own lists (privacy feature)\n" if ($verbose);
|
|
next;
|
|
}
|
|
|
|
# Convert list name to ID for fediverse API
|
|
my $list_id = &lookup_list_id($k->[1]);
|
|
if (!$list_id) {
|
|
print $stdout "-- Skipping $k->[1]: list not found\n" if ($verbose);
|
|
next;
|
|
}
|
|
|
|
# Build fediverse list timeline URL
|
|
my $list_url = $statusliurl;
|
|
$list_url =~ s/%I/$list_id/;
|
|
|
|
# always use fetch_id
|
|
my $r = &grabjson($list_url,
|
|
$fetch_id, 0,
|
|
(($last_id) ? 250 : $fetchwanted), {
|
|
"type" => "list",
|
|
"payload" => "$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 posts are FIRST.
|
|
if (scalar(@streams)) {
|
|
my $j;
|
|
my $k;
|
|
my $l = scalar(@{ $my_json_ref });
|
|
my $m;
|
|
my $n;
|
|
|
|
foreach $n (@streams) {
|
|
SMIX0: foreach $j (@{ $n }) {
|
|
my $id = $j->{'id_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 posts we just filtered.
|
|
next SMIX0 if (length($id_cache{$id}) &&
|
|
$fetch_id);
|
|
next SMIX0 if ($filter_next{$id} &&
|
|
$fetch_id);
|
|
|
|
if (!$l) { # degenerate case
|
|
push (@{ $my_json_ref }, $j);
|
|
$l++;
|
|
next SMIX0;
|
|
}
|
|
|
|
# find the same ID, or one just before,
|
|
# and splice in
|
|
$m = -1;
|
|
SMIX1: for($i=0; $i<$l; $i++) {
|
|
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) {
|
|
print $stdout "-- DEBUG: First time startup path - posts in array: " . scalar(@{ $my_json_ref || [] }) . "\n" if ($verbose);
|
|
if (scalar(@{ $my_json_ref || [] }) > 0 && defined($my_json_ref->[0]->{'id_str'})) {
|
|
print $stdout "-- DEBUG: First time startup - setting last_id from '" . $my_json_ref->[0]->{'id_str'} . "'\n" if ($verbose);
|
|
$last_id = &max($my_json_ref->[0]->{'id_str'}, $last_id);
|
|
} else {
|
|
print $stdout "-- DEBUG: First time startup - no posts or invalid ID, keeping last_id='$last_id'\n" if ($verbose);
|
|
}
|
|
} 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);
|
|
|
|
# Clear initial load flag after first timeline display
|
|
if ($initial_load_in_progress) {
|
|
$initial_load_in_progress = 0;
|
|
print $stdout "-- DEBUG: Initial timeline load complete, notifications now enabled\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 posts in standard format
|
|
sub tdisplay { # used by both synchronous /again and asynchronous refreshes
|
|
my $my_json_ref = shift;
|
|
my $class = shift;
|
|
my $relative_last_id = shift;
|
|
my $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 = $post_counter;
|
|
$post_counter = $mini_split;
|
|
for(0..9) {
|
|
undef $store_hash{"zz$_"};
|
|
}
|
|
}# else {
|
|
# $post_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'}->{'username'} || $j->{'user'}->{'acct'};
|
|
next if (!length($sn));
|
|
$sn = lc(&descape($sn));
|
|
|
|
# Debug: Check what data is in the processing loop for boost posts
|
|
if (exists($j->{'boost_attribution'}) && $j->{'boost_attribution'}) {
|
|
my $text_debug = $j->{'text'} || '';
|
|
print $stdout "-- DEBUG: Processing loop received boost - user: '$sn', text: '$text_debug', boost_attribution: '" . $j->{'boost_attribution'} . "'\n" if ($verbose);
|
|
}
|
|
|
|
#
|
|
# implement filter stages:
|
|
# do so in such a way that we can toss posts out
|
|
# quickly, because multiple layers eat CPU!
|
|
#
|
|
|
|
# zeroth: if this is us, do not filter.
|
|
if (($anonymous || $sn ne $whoami) && !($nofilter)) {
|
|
|
|
# first, filterusers. this is very fast.
|
|
# do for the post
|
|
(&killtw($j), next) if
|
|
($filterusers_sub &&
|
|
&$filterusers_sub($sn));
|
|
# and if the post has a reposted status, do for
|
|
# that.
|
|
(&killtw($j), next) if
|
|
($j->{'reblog'} &&
|
|
$filterusers_sub &&
|
|
&$filterusers_sub(lc(&descape($j->
|
|
{'reblog'}->
|
|
{'user'}->{'username'} || $j->{'user'}->{'acct'}))));
|
|
|
|
# second, filterrts. this is almost as fast.
|
|
(&killtw($j), next) if
|
|
($filterrts_sub &&
|
|
length($j->{'reblog'}->{'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 post.
|
|
# assign menu codes and place into caches
|
|
$key = (($is_background) ? '' : 'z' ).
|
|
substr($alphabet, $post_counter/10, 1) .
|
|
$post_counter % 10;
|
|
$post_counter =
|
|
($post_counter == 259) ? $mini_split :
|
|
($post_counter == ($mini_split - 1))
|
|
? 0 : ($post_counter+1);
|
|
$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 le $relative_last_id) ? 'again' :
|
|
undef))));
|
|
}
|
|
}
|
|
$post_counter = $save_counter if ($save_counter > -1);
|
|
sleep 5 while ($suspend_output > 0);
|
|
&$exception(6,"*** warning: more posts 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;
|
|
}
|
|
# Safe ID calculation - handle empty arrays
|
|
my $new_max_id;
|
|
if (scalar(@{ $my_json_ref }) > 0 && defined($my_json_ref->[0]->{'id_str'})) {
|
|
my $first_post_id = $my_json_ref->[0]->{'id_str'};
|
|
print $stdout "-- DEBUG: First post ID: '$first_post_id', current last_id: '$last_id'\n" if ($verbose);
|
|
$new_max_id = &max($first_post_id, $last_id);
|
|
print $stdout "-- DEBUG: max('$first_post_id', '$last_id') = '$new_max_id'\n" if ($verbose);
|
|
} else {
|
|
$new_max_id = $last_id;
|
|
print $stdout "-- DEBUG: No valid posts for ID calculation, using last_id='$last_id'\n" if ($verbose);
|
|
}
|
|
print $stdout "-- DEBUG: tdisplay returning max_id='$new_max_id' (from " . scalar(@{ $my_json_ref }) . " posts)\n" if ($verbose);
|
|
|
|
# Save completion cache after timeline processing
|
|
if ($termrl && $termrl->ReadLine eq 'Term::ReadLine::Gnu') {
|
|
my $cache_count = scalar(grep { /^@/ } keys %readline_completion);
|
|
if ($cache_count > 0) {
|
|
$last_cache_save = 0; # Force save
|
|
&save_completion_cache;
|
|
print $stdout "-- saved completion cache after timeline processing ($cache_count entries)\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
return ($new_max_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;
|
|
}
|
|
}
|
|
|
|
sub notifications_tdisplay {
|
|
my $my_json_ref = shift;
|
|
if (defined($my_json_ref)
|
|
&& ref($my_json_ref) eq 'ARRAY'
|
|
&& scalar(@{ $my_json_ref })) {
|
|
|
|
# Process each notification with proper type mapping
|
|
for my $notification (@{ $my_json_ref }) {
|
|
my $type = $notification->{'type'} || 'default';
|
|
# Map Mastodon notification types to sound categories
|
|
my $sound_class = $type;
|
|
$sound_class = 'mention' if ($type eq 'mention');
|
|
$sound_class = 'boost' if ($type eq 'reblog');
|
|
$sound_class = 'favourite' if ($type eq 'favourite');
|
|
$sound_class = 'follow' if ($type eq 'follow');
|
|
|
|
# Process as individual post with proper class
|
|
&$handle($notification, $sound_class);
|
|
}
|
|
|
|
unless ($timestamp) {
|
|
my ($time, $ts1) = &$wraptime(
|
|
$my_json_ref->[(&min($print_max,scalar(@{ $my_json_ref }))-1)]->{'created_at'});
|
|
my ($time, $ts2) = &$wraptime($my_json_ref->[0]->{'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;
|
|
|
|
# Reset notification flag for this refresh cycle
|
|
$dm_notification_sent = 0;
|
|
|
|
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;
|
|
|
|
print $stdout "-- DEBUG: DM response: " . scalar(@{ $my_json_ref }) . " conversations, disp_max=$disp_max\n" if ($verbose);
|
|
|
|
# For background refresh, check if there are any unread DMs first
|
|
if (!$interactive && !$sent_dm && $disp_max) {
|
|
my $has_unread = 0;
|
|
for (my $check_i = 0; $check_i < $disp_max; $check_i++) {
|
|
my $check_j = $my_json_ref->[$check_i];
|
|
next if (!$check_j->{'accounts'} || !@{$check_j->{'accounts'}} || !$check_j->{'last_status'});
|
|
if ($check_j->{'unread'}) {
|
|
$has_unread = 1;
|
|
last;
|
|
}
|
|
}
|
|
if (!$has_unread) {
|
|
print $stdout "-- DEBUG: No unread DMs found in background refresh, returning early\n" if ($verbose);
|
|
return;
|
|
}
|
|
print $stdout "-- DEBUG: Found unread DMs in background refresh, proceeding\n" if ($verbose);
|
|
}
|
|
|
|
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;
|
|
print $stdout "-- DEBUG: dm_first_time: disp_max reduced to $disp_max\n" if ($verbose);
|
|
}
|
|
print $stdout "-- DEBUG: Starting DM display loop: $disp_max conversations\n" if ($verbose);
|
|
for($i = $disp_max; $i > 0; $i--) {
|
|
$g = ($i-1);
|
|
my $j = $my_json_ref->[$g];
|
|
print $stdout "-- DEBUG: Processing DM #$i (index $g)\n" if ($verbose);
|
|
|
|
# Skip if missing data
|
|
if (!$j->{'accounts'} || !@{$j->{'accounts'}} || !$j->{'last_status'}) {
|
|
print $stdout "-- DEBUG: Skipping DM #$i - missing data (accounts=" . (defined($j->{'accounts'}) ? scalar(@{$j->{'accounts'}}) : 'undef') . ")\n" if ($verbose);
|
|
next;
|
|
}
|
|
|
|
# For background refresh (interactive=0), use unread flag detection with local tracking fallback
|
|
if (!$interactive && !$sent_dm) {
|
|
my $is_unread = $j->{'unread'} || 0;
|
|
my $conversation_id = $j->{'id'};
|
|
my $last_status_id = $j->{'last_status'}->{'id'} || $j->{'last_status'}->{'id_str'};
|
|
my $tracking_key = "${conversation_id}:${last_status_id}";
|
|
|
|
print $stdout "-- DEBUG: DM #$i unread flag: " . ($is_unread ? "true" : "false") . ", tracking_key: $tracking_key\n" if ($verbose);
|
|
|
|
# Check if we've already seen this exact conversation+status combination
|
|
if ($dm_seen_status{$tracking_key}) {
|
|
print $stdout "-- DEBUG: Skipping DM #$i - already seen locally (key: $tracking_key)\n" if ($verbose);
|
|
next;
|
|
}
|
|
|
|
# For servers that support unread flag, also check that
|
|
if (!$is_unread && !$dm_seen_status{$tracking_key}) {
|
|
print $stdout "-- DEBUG: Skipping DM #$i - already read (unread=false)\n" if ($verbose);
|
|
next;
|
|
}
|
|
|
|
# Only play sound for the first unread conversation to avoid spam
|
|
if ($dm_notification_sent) {
|
|
print $stdout "-- DEBUG: Suppressing notification for DM #$i - already notified this cycle\n" if ($verbose);
|
|
# Still display the DM but suppress notification
|
|
} else {
|
|
# Mark that we will send a notification for this unread DM
|
|
print $stdout "-- DEBUG: Will send notification for unread DM #$i\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
$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++;
|
|
|
|
print $stdout "-- DEBUG: Calling dmhandle for DM #$i\n" if ($verbose);
|
|
my $dm_result = scalar(&$dmhandle($j));
|
|
print $stdout "-- DEBUG: dmhandle returned: $dm_result\n" if ($verbose);
|
|
$printed += $dm_result;
|
|
}
|
|
$max = $my_json_ref->[0]->{'id'};
|
|
}
|
|
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;
|
|
}
|
|
# Update last_dm for background refresh AND manual /dms
|
|
# Background calls: $interactive=0
|
|
# Manual /dms: $interactive=1, $sent_dm=0 (receives messages, should update read marker)
|
|
# Manual /dmsent: $interactive=1, $sent_dm=1 (shows sent messages, don't update)
|
|
if (!$interactive || $dm_first_time || ($interactive && !$sent_dm)) {
|
|
$last_dm = ($sent_dm) ? $orig_last_dm
|
|
: &max($last_dm, $max);
|
|
|
|
# Update content bookmark for the newest DM (index 0)
|
|
if (!$sent_dm && scalar(@{ $my_json_ref }) > 0) {
|
|
my $newest_dm = $my_json_ref->[0];
|
|
if ($newest_dm->{'last_status'}) {
|
|
# Track newest DM for next comparison (unread flag handles change detection)
|
|
}
|
|
}
|
|
|
|
print $stdout "-- DEBUG: Updated last_dm to $last_dm (interactive=$interactive, dm_first_time=$dm_first_time, sent_dm=$sent_dm)\n" if ($verbose);
|
|
} else {
|
|
print $stdout "-- DEBUG: NOT updating last_dm (interactive=$interactive, keeping last_dm=$last_dm)\n" if ($verbose);
|
|
}
|
|
$dm_first_time = 0 if ($last_dm || !scalar(@{ $my_json_ref }));
|
|
print $stdout "-- dm bookmark is $last_dm.\n" if ($verbose);
|
|
|
|
# Save completion cache after processing DMs
|
|
my $dm_users_added = scalar(grep { /^@/ } keys %readline_completion) - 10; # original timeline users
|
|
if ($dm_users_added > 0) {
|
|
print $stdout "-- saving completion cache after DM processing ($dm_users_added DM users added)\n" if ($verbose);
|
|
&save_completion_cache;
|
|
}
|
|
|
|
&$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-post' :
|
|
'post';
|
|
|
|
if ($anonymous) {
|
|
print $stdout
|
|
"-- sorry, you can't $verb if you're anonymous.\n"
|
|
if ($interactive);
|
|
return 99;
|
|
}
|
|
|
|
# "the pastebrake" - enhanced paste protection
|
|
if (!$slowpost && !$verify && !$script) {
|
|
my $current_time = time();
|
|
|
|
# Check if posting too fast (more than 2 posts in 3 seconds)
|
|
if (($current_time - $postbreak_time) < 3) {
|
|
$postbreak_count++;
|
|
|
|
# First warning after 2 rapid posts
|
|
if ($postbreak_count == 2) {
|
|
print $stdout
|
|
"-- PASTE PROTECTION: You're posting very fast!\n".
|
|
"-- This might be an accidental paste. Press CTRL-C to abort!\n".
|
|
"-- Waiting 5 seconds... (posts will be ignored during this time)\n";
|
|
|
|
# Install signal handler for interrupt
|
|
local $SIG{INT} = sub {
|
|
print $stdout "\n-- PASTE ABORTED by user! No more posts will be sent.\n";
|
|
$postbreak_count = 999; # Block further posts
|
|
die "User aborted paste sequence\n";
|
|
};
|
|
|
|
# Wait with interrupt checking
|
|
for my $i (1..5) {
|
|
print $stdout "-- $i... ";
|
|
sleep 1;
|
|
}
|
|
print $stdout "\n-- Continuing (press CTRL-C quickly to abort next posts)\n";
|
|
}
|
|
|
|
# After 4 posts, require confirmation
|
|
if ($postbreak_count >= 4) {
|
|
print $stdout
|
|
"-- PASTE PROTECTION: Blocking rapid posts!\n".
|
|
"-- You've posted $postbreak_count times in quick succession.\n".
|
|
"-- Type 'continue' to keep posting, or CTRL-C to abort: ";
|
|
|
|
my $response = <STDIN>;
|
|
chomp($response);
|
|
|
|
if (lc($response) ne 'continue') {
|
|
print $stdout "-- Paste sequence aborted by user.\n";
|
|
return 98; # Return without posting
|
|
}
|
|
|
|
print $stdout "-- Continuing paste sequence...\n";
|
|
$postbreak_count = 0; # Reset after confirmation
|
|
}
|
|
} else {
|
|
# Reset counter if enough time has passed
|
|
$postbreak_count = 0;
|
|
}
|
|
$postbreak_time = $current_time;
|
|
}
|
|
|
|
my $payload = 'status'; # Always use 'status' for Mastodon
|
|
$string = &$prepost($string) unless ($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";
|
|
}
|
|
}
|
|
}
|
|
|
|
# Keep $user_name_dm as-is for Mastodon DM handling
|
|
|
|
my $i = '';
|
|
$i .= "source=TTYverse&" 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";
|
|
}
|
|
if ($rt_id) {
|
|
$i .= "id=$rt_id";
|
|
} else {
|
|
if (length($user_name_dm)) {
|
|
# For DMs: include mention in status and set visibility
|
|
my $dm_status = "\@${user_name_dm} ${string}";
|
|
my $dm_urle = '';
|
|
foreach my $char (unpack("${pack_magic}C*", $dm_status)) {
|
|
my $k = chr($char);
|
|
if ($k =~ /[-._~a-zA-Z0-9]/) {
|
|
$dm_urle .= $k;
|
|
} else {
|
|
$k = sprintf("%02X", $char);
|
|
$dm_urle .= "%$k";
|
|
}
|
|
}
|
|
$i .= "${payload}=${dm_urle}&";
|
|
$i .= "visibility=direct&";
|
|
} else {
|
|
$i .= "${payload}=${urle}&";
|
|
$i .= "visibility=${post_visibility}&";
|
|
}
|
|
}
|
|
$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,
|
|
($rt_id) ? ($reblogurl =~ s/%I/$rt_id/gr) : $update,
|
|
$i, 0, @wend);
|
|
print $stdout "-- return --\n$return\n-- return --\n"
|
|
if ($superverbose);
|
|
if ($? > 0) {
|
|
$x = $? >> 8;
|
|
print $stdout <<"EOF" if ($interactive);
|
|
${MAGENTA}*** warning: connect timeout or no confirmation received ($x)
|
|
*** to attempt a resend, type %%${OFF}
|
|
EOF
|
|
return $?;
|
|
}
|
|
my $ec;
|
|
if ($ec = &is_json_error($return)) {
|
|
print $stdout <<"EOF" if ($interactive);
|
|
${MAGENTA}*** warning: server error message received
|
|
*** "$ec"${OFF}
|
|
EOF
|
|
return 98;
|
|
}
|
|
if ($ec = &is_fail_whale($return) ||
|
|
$return =~ /^\[?\]?<!DOCTYPE\s+html/i ||
|
|
$return =~ /^(Status:\s*)?50[0-9]\s/ ||
|
|
$return =~ /^<html>/i ||
|
|
$return =~ /^<\??xml\s+/) {
|
|
print $stdout <<"EOF" if ($interactive);
|
|
${MAGENTA}*** warning: Server temporarily unavailable${OFF}
|
|
EOF
|
|
return 98;
|
|
}
|
|
$lastpostid = &map_mastodon_fields(&parsejson($return))->{'id_str'};
|
|
unless ($user_name_dm || $rt_id) {
|
|
$lasttwit = $string;
|
|
&$postpost($string);
|
|
}
|
|
|
|
# Send "me" notification for outgoing DMs
|
|
if ($user_name_dm) {
|
|
¬ifytype_dispatch('me', $string, undef);
|
|
}
|
|
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
|
|
# TTYverse, 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 "-- post id #${id} has been removed\n"
|
|
if ($interactive && !$en);
|
|
print $stdout "*** (was the post already deleted?)\n"
|
|
if ($interactive && $en);
|
|
return 0;
|
|
}
|
|
|
|
# delete a 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 post id #${id}: \"$text\"\n"
|
|
if ($interactive && !$en);
|
|
print $stdout "*** (was the favourite already ${verb}?)\n"
|
|
if ($interactive && $en);
|
|
return 0;
|
|
}
|
|
|
|
# follow or unfollow a user
|
|
sub foruuser {
|
|
my $uname = shift;
|
|
my $interactive = shift;
|
|
my $basef = shift;
|
|
my $verb = shift;
|
|
|
|
# Look up account ID for the username
|
|
my $account_id = &lookup_account_id($uname);
|
|
if (!$account_id) {
|
|
&report_account_not_found($uname, $interactive);
|
|
return 1;
|
|
}
|
|
|
|
my ($en, $em) = ¢ral_cd_dispatch("id=$account_id",
|
|
$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;
|
|
|
|
# Look up account ID for the username
|
|
my $account_id = &lookup_account_id($uname);
|
|
if (!$account_id) {
|
|
&report_account_not_found($uname, $interactive);
|
|
return 1;
|
|
}
|
|
|
|
my ($en, $em) = ¢ral_cd_dispatch("id=$account_id",
|
|
$interactive, $basef);
|
|
print $stdout "-- ok, you have $verb blocking user $uname.\n"
|
|
if ($interactive && !$en);
|
|
return 0;
|
|
}
|
|
|
|
# enable or disable reposts for a user
|
|
sub rtsonoffuser {
|
|
my $uname = shift;
|
|
my $interactive = shift;
|
|
my $selection = shift;
|
|
my $verb = ($selection) ? 'enabled' : 'disabled';
|
|
my $tval = ($selection) ? 'true' : 'false';
|
|
|
|
# Look up account ID for the username
|
|
my $account_id = &lookup_account_id($uname);
|
|
if (!$account_id) {
|
|
&report_account_not_found($uname, $interactive);
|
|
return 1;
|
|
}
|
|
|
|
my ($en, $em) = ¢ral_cd_dispatch(
|
|
"reposts=${tval}&id=${account_id}",
|
|
$interactive, $frupdurl);
|
|
print $stdout "-- ok, you have ${verb} boosts for user $uname.\n"
|
|
if ($interactive && !$en);
|
|
return 0;
|
|
}
|
|
|
|
#### TTYverse internal API utility functions ####
|
|
# ... which your API *can* call
|
|
|
|
# gets and returns the contents of a URL (optionally pass a POST body)
|
|
sub graburl {
|
|
my $resource = shift;
|
|
my $data = shift;
|
|
|
|
return &backticks($baseagent,
|
|
'/dev/null', undef, $resource, $data,
|
|
1, @wind);
|
|
}
|
|
|
|
# format a post based on user options
|
|
sub standardpost {
|
|
my $ref = shift;
|
|
my $nocolour = shift;
|
|
|
|
my $sn = &descape($ref->{'user'}->{'acct'} || $ref->{'user'}->{'username'});
|
|
my $post = &descape($ref->{'text'});
|
|
|
|
# Add usernames to completion cache
|
|
if ($termrl && $sn) {
|
|
$readline_completion{'@'.$sn}++;
|
|
my $total_keys = scalar(keys %readline_completion);
|
|
print STDERR "COMPLETION: Added \@$sn to completion cache (total: $total_keys)\n" if ($verbose);
|
|
# Don't save on every add - let the final save handle it
|
|
}
|
|
|
|
# Debug boost display
|
|
if (exists($ref->{'boost_attribution'}) && $ref->{'boost_attribution'}) {
|
|
print $stdout "-- DEBUG: standardpost - user: '$sn', text: '$post', boost_attribution: '" . $ref->{'boost_attribution'} . "'\n" if ($verbose);
|
|
|
|
# Also add boost attribution to completion cache
|
|
if ($termrl) {
|
|
my $booster = &descape($ref->{'boost_attribution'});
|
|
if ($booster) {
|
|
$readline_completion{'@'.$booster}++;
|
|
my $total_keys = scalar(keys %readline_completion);
|
|
print STDERR "COMPLETION: Added \@$booster (booster) to completion cache (total: $total_keys)\n" if ($verbose);
|
|
# Don't save on every add - let the final save handle it
|
|
}
|
|
}
|
|
}
|
|
|
|
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(&$posttype($ref, $sn, $post)) }
|
|
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->{'reblog'}->{'id_str'}));
|
|
$sn = "*$sn" if ($ref->{'source'} =~ /TTYverse/ && $ttytteristas);
|
|
# prepend list information, if this post originated from a list
|
|
$sn = "($ref->{'tag'}->{'payload'})$sn"
|
|
if (length($ref->{'tag'}->{'payload'}) &&
|
|
$ref->{'tag'}->{'type'} eq 'list');
|
|
|
|
# Build the metadata/info line: <user> [boost] (time) via client
|
|
my $info_line = "<$sn>";
|
|
|
|
# Add boost attribution if this is a boosted post
|
|
if (exists($ref->{'boost_attribution'}) && $ref->{'boost_attribution'}) {
|
|
my $booster = &descape($ref->{'boost_attribution'});
|
|
$info_line .= " [boosted $booster]";
|
|
}
|
|
|
|
# Add relative time and client info
|
|
my $relative_time = &format_relative_time($ref->{'created_at'});
|
|
my $client_info = &format_client_info($ref);
|
|
|
|
$info_line .= " ($relative_time)" if ($relative_time);
|
|
$info_line .= " via $client_info" if ($client_info);
|
|
|
|
# Add visibility indicator
|
|
my $visibility = $ref->{'visibility'} || 'public'; # Default to public if not specified
|
|
my $vis_display = '';
|
|
my $vis_color = '';
|
|
|
|
if ($visibility eq 'public') {
|
|
$vis_display = '[Public]';
|
|
$vis_color = $CYAN; # Subtle cyan for public
|
|
} elsif ($visibility eq 'unlisted') {
|
|
$vis_display = '[Unlisted]';
|
|
$vis_color = $MAGENTA; # Purple for unlisted
|
|
} elsif ($visibility eq 'private') {
|
|
$vis_display = '[Followers]';
|
|
$vis_color = $YELLOW; # Yellow for followers-only
|
|
} elsif ($visibility eq 'direct') {
|
|
$vis_display = '[Direct]';
|
|
$vis_color = $RED; # Red for direct messages
|
|
}
|
|
|
|
if ($vis_display) {
|
|
if ($nocolour) {
|
|
$info_line .= " $vis_display";
|
|
} else {
|
|
$info_line .= " ${vis_color}${vis_display}${OFF}";
|
|
}
|
|
}
|
|
|
|
# Add poll indicator if this post has a poll
|
|
if (exists($ref->{'poll'}) && $ref->{'poll'}) {
|
|
my $poll_indicator = '[Poll]';
|
|
if ($nocolour) {
|
|
$info_line .= " $poll_indicator";
|
|
} else {
|
|
$info_line .= " ${GREEN}${poll_indicator}${OFF}";
|
|
}
|
|
}
|
|
|
|
# Add content warning/title if present
|
|
my $cw_text = '';
|
|
if (exists($ref->{'reblog'}) && $ref->{'reblog'} && exists($ref->{'reblog'}->{'spoiler_text'})) {
|
|
# For boost posts, check original post's content warning
|
|
$cw_text = $ref->{'reblog'}->{'spoiler_text'};
|
|
} elsif (exists($ref->{'spoiler_text'})) {
|
|
# Regular post content warning
|
|
$cw_text = $ref->{'spoiler_text'};
|
|
}
|
|
|
|
if ($cw_text && length($cw_text)) {
|
|
$cw_text = &descape($cw_text);
|
|
$info_line .= " [$cw_text]";
|
|
}
|
|
|
|
# fediverse doesn't always do this right.
|
|
$h = $ref->{'reblogs_count'}; $h += 0; #$h = "${h}+" if ($h >= 100);
|
|
# fediverse doesn't always handle single reposts right. good f'n grief.
|
|
$info_line = "(x${h}) $info_line" if ($h > 1 && !$noreblogs);
|
|
|
|
# br3nda's modified timestamp patch (absolute timestamp)
|
|
if ($timestamp) {
|
|
my ($time, $ts) = &$wraptime($ref->{'created_at'});
|
|
$info_line = "[$ts] $info_line";
|
|
}
|
|
|
|
# Combine info line + content with newline separation
|
|
$post = $info_line . "\n" . $post;
|
|
|
|
# Add poll information if this post has a poll
|
|
if (exists($ref->{'poll'}) && $ref->{'poll'}) {
|
|
my $poll_info = &format_poll_display($ref->{'poll'});
|
|
$post .= "\n$poll_info" if ($poll_info);
|
|
}
|
|
|
|
# pull it all together
|
|
$post = &wwrap($post, ($wrapseq <= 1) ? ((&$prompt(1))[1]) : 0)
|
|
if ($wrap); # remember to account for prompt length on #1
|
|
$post =~ s/^([^<]*)<([^>]+)>/${g}\1<${EM}\2${colour}>/
|
|
unless ($nocolour);
|
|
$post =~ s/\n*$//;
|
|
$post .= ($nocolour) ? "\n" : "$OFF\n";
|
|
|
|
# highlight anything that we have in track
|
|
if(scalar(@tracktags)) { # I'm paranoid
|
|
foreach $h (@tracktags) {
|
|
$h =~ s/^"//; $h =~ s/"$//; # just in case
|
|
$post =~ s/(^|[^a-zA-Z0-9])($h)([^a-zA-Z0-9]|$)/\1${EM}\2${colour}\3/ig
|
|
unless ($nocolour);
|
|
}
|
|
}
|
|
|
|
# smb's underline/bold patch goes on last (modified for lists)
|
|
unless ($nocolour) {
|
|
# only do this after the < > portion.
|
|
my $k = index($post, ">");
|
|
my $botsub = substr($post, $k);
|
|
my $topsub = substr($post, 0, $k);
|
|
$botsub =~
|
|
s/(^|[^a-zA-Z0-9_])\@([a-zA-Z0-9_\/]+)/\1\@${UNDER}\2${colour}/g;
|
|
$post = $topsub . $botsub;
|
|
}
|
|
|
|
return $post;
|
|
}
|
|
|
|
# format poll information for display
|
|
sub format_poll_display {
|
|
my $poll = shift;
|
|
return '' unless ($poll && ref($poll) eq 'HASH');
|
|
|
|
my @options = @{$poll->{'options'} || []};
|
|
return '' unless (@options);
|
|
|
|
my $poll_text = "Poll:";
|
|
my $option_num = 1;
|
|
|
|
# Display each option with number and vote count
|
|
foreach my $option (@options) {
|
|
my $title = &descape($option->{'title'} || '');
|
|
my $votes = $option->{'votes_count'} || 0;
|
|
$poll_text .= "\n $option_num. $title ($votes votes)";
|
|
$option_num++;
|
|
}
|
|
|
|
# Add poll metadata
|
|
my $total_votes = $poll->{'votes_count'} || 0;
|
|
my $expires_at = $poll->{'expires_at'};
|
|
my $expired = $poll->{'expired'} || 0;
|
|
my $multiple = $poll->{'multiple'} || 0;
|
|
my $voted = $poll->{'voted'} || 0;
|
|
|
|
$poll_text .= "\n Total: $total_votes votes";
|
|
$poll_text .= $multiple ? " (multiple choice)" : " (single choice)";
|
|
|
|
if ($expired) {
|
|
$poll_text .= " - EXPIRED";
|
|
} elsif ($expires_at) {
|
|
$poll_text .= " - expires $expires_at";
|
|
}
|
|
|
|
if ($voted) {
|
|
$poll_text .= " - Already voted";
|
|
} else {
|
|
$poll_text .= " - Use /vote to participate";
|
|
}
|
|
|
|
return $poll_text;
|
|
}
|
|
|
|
# format relative time (e.g., "5 minutes ago", "2 hours ago")
|
|
sub format_relative_time {
|
|
my $created_at = shift;
|
|
return '' unless ($created_at);
|
|
|
|
# Parse the fediverse timestamp format (ISO 8601)
|
|
# Example: "2025-07-26T12:34:56.000Z"
|
|
my ($year, $month, $day, $hour, $min, $sec);
|
|
if ($created_at =~ /^(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})/) {
|
|
($year, $month, $day, $hour, $min, $sec) = ($1, $2, $3, $4, $5, $6);
|
|
} else {
|
|
return '';
|
|
}
|
|
|
|
# Convert to Unix timestamp
|
|
my $post_time = eval {
|
|
require Time::Local;
|
|
Time::Local::timegm($sec, $min, $hour, $day, $month - 1, $year);
|
|
};
|
|
return '' if (!defined($post_time) || $@);
|
|
|
|
my $now = time();
|
|
my $diff = $now - $post_time;
|
|
|
|
# Handle future timestamps (clock skew)
|
|
return "just now" if ($diff < 0);
|
|
|
|
# Calculate relative time
|
|
if ($diff < 60) {
|
|
return "just now";
|
|
} elsif ($diff < 3600) { # Less than 1 hour
|
|
my $minutes = int($diff / 60);
|
|
return "${minutes}m ago";
|
|
} elsif ($diff < 86400) { # Less than 1 day
|
|
my $hours = int($diff / 3600);
|
|
return "${hours}h ago";
|
|
} elsif ($diff < 604800) { # Less than 1 week
|
|
my $days = int($diff / 86400);
|
|
return "${days}d ago";
|
|
} elsif ($diff < 2629746) { # Less than 1 month (30.44 days)
|
|
my $weeks = int($diff / 604800);
|
|
return "${weeks}w ago";
|
|
} elsif ($diff < 31556952) { # Less than 1 year
|
|
my $months = int($diff / 2629746);
|
|
return "${months}mo ago";
|
|
} else {
|
|
my $years = int($diff / 31556952);
|
|
return "${years}y ago";
|
|
}
|
|
}
|
|
|
|
# format client application info
|
|
sub format_client_info {
|
|
my $ref = shift;
|
|
|
|
# For boost posts, show client of original post
|
|
my $app_data;
|
|
if (exists($ref->{'reblog'}) && $ref->{'reblog'} && exists($ref->{'reblog'}->{'application'})) {
|
|
$app_data = $ref->{'reblog'}->{'application'};
|
|
} elsif (exists($ref->{'application'})) {
|
|
$app_data = $ref->{'application'};
|
|
}
|
|
|
|
return '' unless ($app_data && ref($app_data) eq 'HASH');
|
|
|
|
my $client_name = $app_data->{'name'} || '';
|
|
return '' unless ($client_name);
|
|
|
|
# Clean up common client names for better display
|
|
if ($client_name =~ /^mastodon/i) {
|
|
return "Web" if ($client_name =~ /web/i);
|
|
return "Mobile" if ($client_name =~ /mobile|android|ios/i);
|
|
}
|
|
|
|
# Handle common clients
|
|
$client_name = "Tusky" if ($client_name =~ /tusky/i);
|
|
$client_name = "Subway Tooter" if ($client_name =~ /subway.*tooter/i);
|
|
$client_name = "Fedilab" if ($client_name =~ /fedilab/i);
|
|
$client_name = "TTYverse" if ($client_name =~ /ttyverse/i);
|
|
|
|
return $client_name;
|
|
}
|
|
|
|
# format a DM based on standard user options
|
|
sub standarddm {
|
|
my $ref = shift;
|
|
my $nocolour = shift;
|
|
|
|
my ($time, $ts) = &$wraptime($ref->{'last_status'}->{'created_at'});
|
|
my $text = &descape(&html_to_text($ref->{'last_status'}->{'content'}));
|
|
my $sns = &descape($ref->{'last_status'}->{'account'}->{'username'} || $ref->{'last_status'}->{'account'}->{'acct'});
|
|
|
|
# Add relative time for DMs
|
|
my $relative_time = &format_relative_time($ref->{'last_status'}->{'created_at'});
|
|
|
|
# Build DM info line: [DM code][user] (relative_time)
|
|
my $dm_info = "[DM d$ref->{'menu_select'}][$sns]";
|
|
$dm_info .= " ($relative_time)" if ($relative_time);
|
|
|
|
# Combine info line + content with newline (new two-line format)
|
|
my $g = &wwrap($dm_info . "\n" . $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'});
|
|
|
|
# ActivityPub streaming API messages
|
|
|
|
if (length($verb)) { # see below for server-level events
|
|
my $tar_sn = '@'.&descape($ref->{'target'}->{'acct'} || $ref->{'target'}->{'username'});
|
|
my $sou_sn = '@'.&descape($ref->{'source'}->{'acct'} || $ref->{'source'}->{'username'});
|
|
|
|
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 post: \"$txt\"";
|
|
} elsif ($verb eq 'follow') {
|
|
$g .= "$sou_sn is now following $tar_sn";
|
|
} elsif ($verb eq 'user_update') {
|
|
$g .= "$sou_sn updated their profile (/whois $sou_sn to see)";
|
|
} 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 post it is, since that
|
|
# would be embarrassing, so just say a delete occurred.
|
|
$g .=
|
|
"post ID# ".$ref->{'delete'}->{'status'}->{'id_str'}.
|
|
" deleted by server";
|
|
} elsif ($ref->{'status_withheld'}) {
|
|
# fediverse doesn't document id_str as available here. check.
|
|
if (!length($ref->{'status_withheld'}->{'id_str'})) {
|
|
# do nothing right now
|
|
} else { $g .=
|
|
"post 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 TTYverse 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 post was refused for
|
|
# processing by this extension, then the post is now
|
|
# suppressed. do not call any other extensions after this.
|
|
# even if it ends in suppression, we still call the default
|
|
# if it was ever called before.
|
|
return 5 if ($rv==0);
|
|
|
|
# if accepted in any manner, keep calling.
|
|
return 0;
|
|
}, @_);
|
|
}
|
|
sub multiheartbeat {
|
|
&multi_module_dispatch(\&defaultheartbeat, \@m_heartbeat, 0, @_);
|
|
}
|
|
sub multiprecommand {
|
|
&multi_module_dispatch(\&defaultprecommand, \@m_precommand, sub {
|
|
return 2; # feed subsequent chains the result.
|
|
}, @_);
|
|
}
|
|
sub multiprepost {
|
|
&multi_module_dispatch(\&defaultprepost, \@m_prepost, sub {
|
|
return 2; # feed subsequent chains the result.
|
|
}, @_);
|
|
}
|
|
sub multipostpost {
|
|
&multi_module_dispatch(\&defaultpostpost, \@m_postpost, 0, @_);
|
|
}
|
|
sub multiposttype {
|
|
&multi_module_dispatch(\&defaultposttype, \@m_posttype, sub {
|
|
# if this module DID NOT call default, exit now.
|
|
return (!$this_call_default);
|
|
}, @_);
|
|
}
|
|
|
|
sub flag_default_call { $this_call_default++; $did_call_default++; }
|
|
|
|
# now the actual default methods
|
|
|
|
sub defaultexception {
|
|
(&flag_default_call, return) if ($multi_module_context);
|
|
my $msg_code = shift;
|
|
return if ($msg_code == 2 && $muffle_server_messages);
|
|
my $message = "@_";
|
|
$message =~ s/\n*$//sg;
|
|
if ($timestamp) {
|
|
my ($time, $ts) = &$wraptime(scalar(localtime));
|
|
$message = "[$ts] $message";
|
|
$message =~ s/\n/\n[$ts] /sg;
|
|
}
|
|
&send_removereadline if ($termrl);
|
|
$wrapseq = 1;
|
|
print $stdout "${MAGENTA}${message}${OFF}\n";
|
|
&send_repaint if ($termrl);
|
|
$laststatus = 1;
|
|
}
|
|
sub defaultshutdown {
|
|
(&flag_default_call, return) if ($multi_module_context);
|
|
}
|
|
sub defaultlisthandle {
|
|
(&flag_default_call, return) if ($multi_module_context);
|
|
my $list_ref = shift;
|
|
|
|
print $streamout "*** for future expansion ***\n";
|
|
|
|
return 1;
|
|
}
|
|
sub defaulthandle {
|
|
(&flag_default_call, return) if ($multi_module_context);
|
|
my $post_ref = shift;
|
|
my $class = shift;
|
|
my $dclass = ($verbose) ? "{$class,$post_ref->{'id_str'}} " : '';
|
|
my $sn = &descape($post_ref->{'user'}->{'acct'} || $post_ref->{'user'}->{'username'});
|
|
my $post = &descape($post_ref->{'text'});
|
|
|
|
# Debug: Check what data defaulthandle receives for boost posts
|
|
if (exists($post_ref->{'boost_attribution'}) && $post_ref->{'boost_attribution'}) {
|
|
print $stdout "-- DEBUG: defaulthandle received boost - user: '$sn', text: '$post', boost_attribution: '" . $post_ref->{'boost_attribution'} . "'\n" if ($verbose);
|
|
}
|
|
my $spost = &standardpost($post_ref);
|
|
my $menu_select = $post_ref->{'menu_select'};
|
|
|
|
$menu_select = (length($menu_select) && !$script)
|
|
? (($menu_select =~ /^z/) ?
|
|
"${EM}${menu_select}>${OFF} " :
|
|
"${menu_select}> ")
|
|
: '';
|
|
|
|
print $streamout $menu_select . $dclass . $spost;
|
|
print $stdout "-- DEBUG: defaulthandle about to call sendnotifies with class='$class'\n" if ($verbose);
|
|
&sendnotifies($post_ref, $class);
|
|
return 1;
|
|
}
|
|
sub defaultuserhandle {
|
|
(&flag_default_call, return) if ($multi_module_context);
|
|
|
|
my $user_ref = shift;
|
|
&userline($user_ref, $streamout);
|
|
my $desc = &strim(&descape($user_ref->{'description'}));
|
|
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->{'username'} || $my_json_ref->{'acct'}) ]}) (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 $post_ref = shift;
|
|
my $class = shift;
|
|
|
|
my $sn = &descape($post_ref->{'user'}->{'acct'} || $post_ref->{'user'}->{'username'});
|
|
my $post = &descape($post_ref->{'text'});
|
|
|
|
# Debug: Show what we received
|
|
print $stdout "-- DEBUG: sendnotifies called with class='$class', sn='$sn'\n" if ($verbose);
|
|
|
|
# If no class provided, determine it from post content
|
|
if (!length($class) && length($post)) {
|
|
$class = scalar(&$posttype($post_ref, $sn, $post));
|
|
print $stdout "-- DEBUG: sendnotifies determined class='$class'\n" if ($verbose);
|
|
}
|
|
|
|
# Debug: Show notify_list status
|
|
my $notify_enabled = $notify_list{$class} ? 'YES' : 'NO';
|
|
print $stdout "-- DEBUG: notify_list{$class} = $notify_enabled\n" if ($verbose);
|
|
|
|
# Send notification if we have a valid class, it's enabled, AND initial load is complete
|
|
if (length($class) && $notify_list{$class} && !$initial_load_in_progress) {
|
|
print $stdout "-- DEBUG: Calling notifytype_dispatch for class='$class'\n" if ($verbose);
|
|
¬ifytype_dispatch($class,
|
|
&standardpost($post_ref, 1), $post_ref);
|
|
} else {
|
|
my $reason = !length($class) ? "no class" :
|
|
!$notify_list{$class} ? "disabled" :
|
|
$initial_load_in_progress ? "initial load" : "unknown";
|
|
print $stdout "-- DEBUG: NOT calling notifytype_dispatch - class='$class', reason='$reason'\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
sub defaultposttype {
|
|
(&flag_default_call, return) if ($multi_module_context);
|
|
my $ref = shift;
|
|
my $sn = shift;
|
|
my $post = 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 ($post =~ /\@$whoami(\b|$)/i) {
|
|
# if I'm in the post, 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 posts)\n";
|
|
$filtered = 0;
|
|
}
|
|
}
|
|
|
|
sub defaultdmhandle {
|
|
(&flag_default_call, return) if ($multi_module_context);
|
|
my $dm_ref = shift;
|
|
my $sns = &descape($dm_ref->{'last_status'}->{'account'}->{'acct'} || $dm_ref->{'last_status'}->{'account'}->{'username'});
|
|
|
|
# Add DM username to completion cache
|
|
print STDERR "DM_DEBUG: sns='$sns', whoami='$whoami'\n" if ($verbose && $sns);
|
|
if ($sns && $sns ne $whoami) {
|
|
my $username = $sns;
|
|
$username = '@' . $username unless $username =~ /^@/;
|
|
print STDERR "DM_DEBUG: Processing username '$username' for completion\n" if ($verbose);
|
|
if (!exists $readline_completion{$username}) {
|
|
$readline_completion{$username}++;
|
|
my $total = scalar(grep { /^@/ } keys %readline_completion);
|
|
print STDERR "COMPLETION: Added $username (DM user) to completion cache (total: $total)\n" if ($verbose);
|
|
} else {
|
|
print STDERR "DM_DEBUG: Username '$username' already in completion cache\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
my $dm_content = &standarddm($dm_ref);
|
|
print $streamout $dm_content;
|
|
print $stdout "-- DEBUG: DM displayed: " . substr($dm_content, 0, 50) . "...\n" if ($verbose);
|
|
&senddmnotifies($dm_ref) if ($sns ne $whoami);
|
|
|
|
# Mark conversation as read if it was unread (can be disabled with dmmarkread=0)
|
|
if ($dm_ref->{'unread'} && (!defined($dmmarkread) || $dmmarkread)) {
|
|
my $mark_result = &mark_conversation_read($dm_ref->{'id'});
|
|
|
|
# If server-side mark-as-read failed, track locally to prevent re-showing
|
|
if (!$mark_result) {
|
|
my $conversation_id = $dm_ref->{'id'};
|
|
my $last_status_id = $dm_ref->{'last_status'}->{'id'} || $dm_ref->{'last_status'}->{'id_str'};
|
|
my $tracking_key = "${conversation_id}:${last_status_id}";
|
|
$dm_seen_status{$tracking_key} = time(); # Store timestamp when seen
|
|
print $stdout "-- DEBUG: Marked DM as seen locally (key: $tracking_key)\n" if ($verbose);
|
|
&save_dm_seen_status(); # Persist the change
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub senddmnotifies {
|
|
my $dm_ref = shift;
|
|
# Only send notification if we haven't already sent one this refresh cycle
|
|
# and we're not in initial load (either timeline or DM first time)
|
|
# and we're not in display-only mode (user-initiated /dms commands)
|
|
if ($notify_list{'dm'} && !$initial_load_in_progress && !$dm_first_time && !$dm_notification_sent && !$dm_display_only) {
|
|
¬ifytype_dispatch('dm', &standarddm($dm_ref, 1), $dm_ref);
|
|
$dm_notification_sent = 1;
|
|
}
|
|
}
|
|
|
|
sub mark_conversation_read {
|
|
my $conversation_id = shift;
|
|
return unless ($conversation_id);
|
|
|
|
print $stdout "-- DEBUG: Marking conversation $conversation_id as read\n" if ($verbose);
|
|
|
|
# Build the URL for marking conversation as read
|
|
my $read_url = "${apibase}/conversations/$conversation_id/read";
|
|
print $stdout "-- DEBUG: Mark-as-read URL: $read_url\n" if ($verbose);
|
|
|
|
# Make POST request with shorter timeout for mark-as-read
|
|
my $old_timeout = $timeout;
|
|
my $old_exception = $exception;
|
|
$timeout = 5; # Short timeout for non-critical operation
|
|
|
|
# Use a custom exception handler to capture detailed error info
|
|
$exception = sub {
|
|
my ($severity, $message) = @_;
|
|
print $stdout "-- DEBUG: Mark-as-read API call failed (severity=$severity): $message" if ($verbose);
|
|
# Don't show user warning for this - it's not critical, but log the error
|
|
};
|
|
|
|
my $result = &postjson($read_url, "");
|
|
|
|
# Restore original handlers
|
|
$timeout = $old_timeout;
|
|
$exception = $old_exception;
|
|
|
|
if ($result) {
|
|
print $stdout "-- DEBUG: Successfully marked conversation $conversation_id as read\n" if ($verbose);
|
|
return 1;
|
|
} else {
|
|
print $stdout "-- DEBUG: Failed to mark conversation $conversation_id as read - trying alternative method\n" if ($verbose);
|
|
|
|
# Fallback: Some servers might need different approach
|
|
# Try sending empty message to conversation (some implementations mark as read this way)
|
|
my $alt_url = "${apibase}/conversations/$conversation_id";
|
|
print $stdout "-- DEBUG: Trying alternative approach: GET $alt_url\n" if ($verbose);
|
|
|
|
my $alt_result = &grabjson($alt_url, 0, 0, 1, undef, 1);
|
|
if ($alt_result) {
|
|
print $stdout "-- DEBUG: Alternative method succeeded (conversation fetched)\n" if ($verbose);
|
|
return 1;
|
|
} else {
|
|
print $stdout "-- DEBUG: All methods failed - server may not support conversation read API\n" if ($verbose);
|
|
return 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub lookup_account_id {
|
|
my $username = shift;
|
|
return unless ($username);
|
|
|
|
# Remove @ prefix if present
|
|
$username =~ s/^@//;
|
|
|
|
print $stdout "-- DEBUG: Looking up account ID for username: $username\n" if ($verbose);
|
|
|
|
# Use Mastodon search API to find account
|
|
my $search_result = &grabjson("${searchurl}?q=${username}&type=accounts&limit=1", 0, 0, 0, undef, 1);
|
|
|
|
if ($search_result && $search_result->{'accounts'} && @{$search_result->{'accounts'}}) {
|
|
my $account = $search_result->{'accounts'}->[0];
|
|
my $found_username = $account->{'username'} || $account->{'acct'};
|
|
|
|
# Verify we found the right account (case-insensitive match)
|
|
if (lc($found_username) eq lc($username) || lc($account->{'acct'}) eq lc($username)) {
|
|
print $stdout "-- DEBUG: Found account ID: " . $account->{'id'} . " for $username\n" if ($verbose);
|
|
return $account->{'id'};
|
|
}
|
|
}
|
|
|
|
print $stdout "-- DEBUG: Could not find account ID for username: $username\n" if ($verbose);
|
|
return undef;
|
|
}
|
|
|
|
sub lookup_list_id {
|
|
my $list_title = shift;
|
|
return unless ($list_title);
|
|
|
|
print $stdout "-- DEBUG: Looking up list ID for title: $list_title\n" if ($verbose);
|
|
|
|
# Get all lists for current user
|
|
my $lists_result = &grabjson($getlisurl, 0, 0, 0, undef, 1);
|
|
|
|
if ($lists_result && ref($lists_result) eq 'ARRAY') {
|
|
for my $list (@{$lists_result}) {
|
|
my $title = $list->{'title'} || '';
|
|
if (lc($title) eq lc($list_title)) {
|
|
print $stdout "-- DEBUG: Found list ID: " . $list->{'id'} . " for $list_title\n" if ($verbose);
|
|
return $list->{'id'};
|
|
}
|
|
}
|
|
}
|
|
|
|
print $stdout "-- DEBUG: Could not find list ID for title: $list_title\n" if ($verbose);
|
|
return undef;
|
|
}
|
|
|
|
# Helper function for consistent error reporting
|
|
sub report_account_not_found {
|
|
my ($username, $interactive) = @_;
|
|
return unless ($interactive || $verbose);
|
|
print $stdout "-- ERROR: Could not find account for user: $username\n";
|
|
}
|
|
|
|
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+//) {
|
|
if ($termrl) {
|
|
$readline_completion{'@'.lc($1)}++;
|
|
&save_completion_cache;
|
|
}
|
|
}
|
|
if ($line =~ /^[dD]\s+(\w+)\s+/) {
|
|
if ($termrl) {
|
|
$readline_completion{'@'.lc($1)}++;
|
|
&save_completion_cache;
|
|
}
|
|
}
|
|
}
|
|
|
|
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', '/repost', '/replyall',
|
|
'/replies', '/timelines', '/timeline', '/visibility', '/ruler', '/exit', '/me', '/vcheck',
|
|
'/orepost', '/erepost', '/frepost', '/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 TTYverse 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 'TTYverse' 'TTYverse: $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 TTYverse.';
|
|
}
|
|
}
|
|
# figure out the time to display based on length of post
|
|
my $t = 1000+50*length($text); # about 150-180wpm read speed
|
|
open(NOTIFYSEND,
|
|
"|$notify_tool_path -t $t -f - 'TTYverse: $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 post code, figures
|
|
# out where that post is, and returns something approximating a post
|
|
# structure (or the actual post structure itself if it can).
|
|
sub get_post {
|
|
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 post 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) {
|
|
read(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->{'reblog'}->{'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->{'reblogs_count'},
|
|
$w->{'user'}->{'username'}, $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//);
|
|
|
|
# Handle foreground/background like get_post does
|
|
if ($is_background) {
|
|
return $dm_store_hash{$code};
|
|
}
|
|
|
|
# this is the aforementioned "similar code" (see get_post).
|
|
# 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) {
|
|
read(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);
|
|
my ($menu_select, $id, $sender, $created_at, $hex_content) = split(/\s/, $k, 5);
|
|
|
|
# Reconstruct Mastodon conversation format
|
|
$w->{'menu_select'} = $menu_select;
|
|
$w->{'id'} = $id;
|
|
$w->{'last_status'} = {
|
|
'created_at' => $created_at,
|
|
'content' => pack("H*", $hex_content),
|
|
'account' => {
|
|
'username' => $sender,
|
|
'acct' => $sender
|
|
}
|
|
};
|
|
return undef if (!length($w->{'last_status'}->{'content'})); # not possible
|
|
$w->{'last_status'}->{'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) {
|
|
read(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 $stdout "-- DEBUG: Manual refresh requested, sending update command to background\n" if ($verbose);
|
|
print C "update-------------\n";
|
|
&sync_semaphore;
|
|
}
|
|
sub dmthump { print C "dmthump------------\n"; &sync_semaphore; }
|
|
sub dmthump_no_skip { print C "dmthump_no_skip----\n"; &sync_semaphore; }
|
|
|
|
sub sync_n_quit {
|
|
# Save completion cache before exiting
|
|
if ($termrl && $termrl->ReadLine eq 'Term::ReadLine::Gnu') {
|
|
$last_cache_save = 0; # Force save on exit
|
|
&save_completion_cache;
|
|
}
|
|
|
|
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 'shoreblogurl');
|
|
&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 $shoreblogurldomain;
|
|
($shoreblogurl =~ 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
|
|
$shoreblogurldomain = "http://$y/";
|
|
last;
|
|
}
|
|
}
|
|
print $stdout "-- warning: couldn't parse shortener service\n"
|
|
if (!length($shoreblogurldomain));
|
|
}
|
|
|
|
sub detect_browser {
|
|
my $is_gui = defined($ENV{'DISPLAY'}) && length($ENV{'DISPLAY'});
|
|
my $browser;
|
|
|
|
if ($is_gui) {
|
|
# GUI environment - check gui_browser setting first
|
|
if (length($gui_browser)) {
|
|
return ($gui_browser, 1); # Return browser and background flag
|
|
}
|
|
|
|
# Try xdg-open first (most reliable on Linux)
|
|
if (system("which xdg-open >/dev/null 2>&1") == 0) {
|
|
return ('xdg-open %U', 1);
|
|
}
|
|
|
|
# Fallback GUI browsers
|
|
my @gui_browsers = qw(brave chromium firefox google-chrome);
|
|
foreach my $br (@gui_browsers) {
|
|
if (system("which $br >/dev/null 2>&1") == 0) {
|
|
return ("$br %U", 1);
|
|
}
|
|
}
|
|
|
|
# If no GUI browser found, fall back to CLI
|
|
print STDERR "-- warning: no GUI browser found, falling back to CLI browser\n";
|
|
}
|
|
|
|
# CLI environment or fallback - check cli_browser setting first
|
|
if (length($cli_browser)) {
|
|
return ($cli_browser, 0); # CLI browsers are blocking
|
|
}
|
|
|
|
# Try CLI browsers in order of preference
|
|
my @cli_browsers = qw(w3m elinks lynx);
|
|
foreach my $br (@cli_browsers) {
|
|
if (system("which $br >/dev/null 2>&1") == 0) {
|
|
return ("$br %U", 0);
|
|
}
|
|
}
|
|
|
|
# Ultimate fallback - use the old urlopen setting
|
|
return ($urlopen, 0);
|
|
}
|
|
|
|
sub openurl {
|
|
my $url = shift;
|
|
my ($comm, $should_background) = &detect_browser();
|
|
|
|
# Handle gopher URLs through gateway if not using lynx
|
|
$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;
|
|
|
|
if ($should_background) {
|
|
# Background GUI browsers
|
|
$comm .= " &";
|
|
print $stdout "($comm)\n";
|
|
system("$comm");
|
|
} else {
|
|
# CLI browsers run in foreground
|
|
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 =~ /^$shoreblogurldomain/i); # stop loops
|
|
$url = &url_oauth_sub($url);
|
|
$cl = "$simple_agent \"${shoreblogurl}$url\"";
|
|
print $stdout "$cl\n" if ($superverbose);
|
|
chomp($rc = `$cl`);
|
|
return ($urlshort = (($rc =~ m#^http://#) ? $rc : undef));
|
|
}
|
|
|
|
##### Media Upload Functions #####
|
|
|
|
sub handle_media_upload {
|
|
my $file_path = shift;
|
|
|
|
# Validate file exists and is readable
|
|
unless (-f $file_path && -r $file_path) {
|
|
print $stdout "-- ERROR: File '$file_path' not found or not readable\n";
|
|
return 0;
|
|
}
|
|
|
|
# Check file size (Mastodon limit is typically 8MB for images, 40MB for video)
|
|
my $file_size = -s $file_path;
|
|
if ($file_size > 40 * 1024 * 1024) { # 40MB
|
|
print $stdout "-- ERROR: File too large (max 40MB)\n";
|
|
return 0;
|
|
}
|
|
|
|
# Detect MIME type
|
|
my $mime_type = &detect_mime_type($file_path);
|
|
unless ($mime_type) {
|
|
print $stdout "-- ERROR: Unable to determine file type\n";
|
|
return 0;
|
|
}
|
|
|
|
print $stdout "-- Detected file type: $mime_type\n" if ($verbose);
|
|
|
|
# Handle alt-text for images (REQUIRED for accessibility)
|
|
my $alt_text = "";
|
|
if ($mime_type =~ /^image\//) {
|
|
print $stdout "-- Images require alt-text for accessibility\n";
|
|
$alt_text = &linein("Enter alt text for " . (split('/', $file_path))[-1] . ": ");
|
|
|
|
# Empty alt-text cancels the upload (enforce accessibility)
|
|
unless (defined($alt_text) && length($alt_text) > 0) {
|
|
print $stdout "-- Upload cancelled: Alt-text is required for images\n";
|
|
print $stdout "-- If you're going to use a client maintained by a blind guy, you can damn well describe your images!\n";
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# Get optional post message
|
|
my $post_message = &linein("Enter post message (optional): ");
|
|
$post_message = "" unless defined($post_message);
|
|
|
|
# Upload media and create post
|
|
return &upload_media_and_post($file_path, $mime_type, $alt_text, $post_message);
|
|
}
|
|
|
|
sub detect_mime_type {
|
|
my $file_path = shift;
|
|
|
|
# Try using 'file' command first (most reliable)
|
|
my $file_output = `file -b --mime-type "$file_path" 2>/dev/null`;
|
|
chomp($file_output);
|
|
if ($file_output && $file_output =~ /^[\w-]+\/[\w-]+$/) {
|
|
return $file_output;
|
|
}
|
|
|
|
# Fallback to file extension
|
|
my $extension = lc((split(/\./, $file_path))[-1]);
|
|
my %ext_to_mime = (
|
|
'jpg' => 'image/jpeg',
|
|
'jpeg' => 'image/jpeg',
|
|
'png' => 'image/png',
|
|
'gif' => 'image/gif',
|
|
'webp' => 'image/webp',
|
|
'mp4' => 'video/mp4',
|
|
'webm' => 'video/webm',
|
|
'mov' => 'video/quicktime',
|
|
'mp3' => 'audio/mpeg',
|
|
'ogg' => 'audio/ogg',
|
|
'wav' => 'audio/wav',
|
|
'flac' => 'audio/flac'
|
|
);
|
|
|
|
return $ext_to_mime{$extension} || undef;
|
|
}
|
|
|
|
sub upload_media_and_post {
|
|
my ($file_path, $mime_type, $alt_text, $post_message) = @_;
|
|
|
|
print $stdout "-- Uploading media file...\n";
|
|
|
|
# Step 1: Upload media to get media ID
|
|
my $media_id = &upload_media_file($file_path, $mime_type, $alt_text);
|
|
unless ($media_id) {
|
|
print $stdout "-- ERROR: Media upload failed\n";
|
|
return 0;
|
|
}
|
|
|
|
print $stdout "-- Media uploaded successfully (ID: $media_id)\n";
|
|
|
|
# Step 2: Create post with media attachment
|
|
return &create_post_with_media($media_id, $post_message);
|
|
}
|
|
|
|
sub upload_media_file {
|
|
my ($file_path, $mime_type, $alt_text) = @_;
|
|
|
|
# Mastodon media upload endpoint
|
|
my $media_url = "${apibase}/media";
|
|
|
|
# Build curl command for multipart file upload
|
|
my $curl_cmd = "$baseagent";
|
|
|
|
# Add standard auth and options (from @wend)
|
|
foreach my $arg (@wend) {
|
|
$curl_cmd .= " '$arg'";
|
|
}
|
|
|
|
# Add OAuth Bearer token authentication
|
|
my $bearer_header = &signrequest($media_url, '');
|
|
if ($bearer_header) {
|
|
$curl_cmd .= " $bearer_header";
|
|
}
|
|
|
|
# Add multipart form data
|
|
$curl_cmd .= " -X POST";
|
|
$curl_cmd .= " -F 'file=\@$file_path;type=$mime_type'";
|
|
|
|
# Add alt-text if provided (for images)
|
|
if (length($alt_text)) {
|
|
my $escaped_alt = $alt_text;
|
|
$escaped_alt =~ s/'/'\\''/g; # Escape single quotes for shell
|
|
$curl_cmd .= " -F 'description=$escaped_alt'";
|
|
}
|
|
|
|
$curl_cmd .= " '$media_url'";
|
|
|
|
print $stdout "-- DEBUG: Upload command: $curl_cmd\n" if ($superverbose);
|
|
print $stdout "-- DEBUG: Uploading to $media_url\n" if ($verbose);
|
|
|
|
# Execute the upload
|
|
my $response = `$curl_cmd 2>/dev/null`;
|
|
my $exit_code = $? >> 8;
|
|
|
|
if ($exit_code != 0) {
|
|
print $stdout "-- ERROR: Upload failed (curl exit code: $exit_code)\n";
|
|
return undef;
|
|
}
|
|
|
|
print $stdout "-- DEBUG: Upload response: $response\n" if ($superverbose);
|
|
|
|
# Parse JSON response to get media ID
|
|
my $media_data = &parsejson($response);
|
|
unless ($media_data && ref($media_data) eq 'HASH') {
|
|
print $stdout "-- ERROR: Invalid response from media upload\n";
|
|
print $stdout "-- Response: $response\n" if ($verbose);
|
|
return undef;
|
|
}
|
|
|
|
my $media_id = $media_data->{'id'};
|
|
unless ($media_id) {
|
|
print $stdout "-- ERROR: No media ID in response\n";
|
|
print $stdout "-- Response: $response\n" if ($verbose);
|
|
return undef;
|
|
}
|
|
|
|
return $media_id;
|
|
}
|
|
|
|
sub create_post_with_media {
|
|
my ($media_id, $post_message) = @_;
|
|
|
|
# Build post data
|
|
my $post_data = "media_ids[]=$media_id";
|
|
if (length($post_message)) {
|
|
$post_data .= "&status=" . &url_oauth_sub($post_message);
|
|
}
|
|
|
|
# Add current visibility setting
|
|
$post_data .= "&visibility=$post_visibility" if defined($post_visibility);
|
|
|
|
print $stdout "-- Creating post with media attachment...\n";
|
|
|
|
# Use existing postjson function for creating the post
|
|
my $result = &postjson($update, $post_data);
|
|
|
|
if ($result) {
|
|
print $stdout "-- Post created successfully!\n";
|
|
return 1;
|
|
} else {
|
|
print $stdout "-- ERROR: Failed to create post\n";
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
##### 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 {
|
|
print $stdout "-- DEBUG: notifytype_dispatch called with " . scalar(@notifytypes) . " notifiers\n" if ($verbose);
|
|
return if (!scalar(@notifytypes));
|
|
my $nt; foreach $nt (@notifytypes) {
|
|
print $stdout "-- DEBUG: Calling notifier function: $nt\n" if ($verbose);
|
|
&$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);
|
|
print $stdout "-- DEBUG: notify_list compiled: " . join(',', keys %notify_list) . "\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
# 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 $update_url = shift;
|
|
my $vs = '';
|
|
|
|
# Git-based version checking for TTYverse
|
|
my $repo_url = "https://git.stormux.org/storm/ttyverse";
|
|
my $current_version = $TTYverse_VERSION;
|
|
my $latest_version = '';
|
|
|
|
|
|
# Term::ReadLine::Gnu doesn't need version checking - it's maintained on CPAN
|
|
|
|
print $stdout "-- checking TTYverse version...\n";
|
|
# Git-based version checking - no longer using remote URL
|
|
$vvs = '';
|
|
# Git-based version checking
|
|
my $tag_output = '';
|
|
|
|
# Use curl-only approach for version checking
|
|
my $curl_cmd = `which curl 2>/dev/null`;
|
|
chomp($curl_cmd);
|
|
|
|
if ($curl_cmd) {
|
|
print $stdout "-- using curl to check for latest version...\n" if ($verbose);
|
|
|
|
# Try multiple approaches for Gitea
|
|
my @api_attempts = (
|
|
# Try different possible API paths for Gitea
|
|
"https://git.stormux.org/api/v1/repos/storm/ttyverse/tags",
|
|
"https://git.stormux.org/api/v1/repos/storm/ttyverse/releases",
|
|
# Try web scraping the releases/tags page if API doesn't work
|
|
"https://git.stormux.org/storm/ttyverse/releases",
|
|
"https://git.stormux.org/storm/ttyverse/tags"
|
|
);
|
|
|
|
foreach my $url (@api_attempts) {
|
|
print $stdout "-- trying: $url\n" if ($verbose);
|
|
my $response = `$curl_cmd -s -f "$url" 2>/dev/null`;
|
|
|
|
if ($response && length($response) > 10) {
|
|
print $stdout "-- got response from $url\n" if ($verbose);
|
|
|
|
# Try to parse as JSON first (for API responses)
|
|
my @json_tags = $response =~ /"name"\s*:\s*"([^"]+)"/g;
|
|
if (@json_tags) {
|
|
my @tags = sort { $b cmp $a } @json_tags;
|
|
$tag_output = $tags[0];
|
|
print $stdout "-- found tags via JSON: " . join(", ", @tags[0..2]) . "\n" if ($verbose && @tags > 2);
|
|
last;
|
|
}
|
|
|
|
# Try to parse as HTML (for web interface)
|
|
my @html_tags = $response =~ /\/releases\/tag\/([^"'\s>]+)/g;
|
|
if (@html_tags) {
|
|
my @tags = sort { $b cmp $a } @html_tags;
|
|
$tag_output = $tags[0];
|
|
print $stdout "-- found tags via HTML: " . join(", ", @tags[0..2]) . "\n" if ($verbose && @tags > 2);
|
|
last;
|
|
}
|
|
|
|
# Try alternate HTML patterns
|
|
@html_tags = $response =~ /tag\/([0-9]{4}\.[0-9]{2}\.[0-9]{2}[^"'\s>]*)/g;
|
|
if (@html_tags) {
|
|
my @tags = sort { $b cmp $a } @html_tags;
|
|
$tag_output = $tags[0];
|
|
print $stdout "-- found version tags: " . join(", ", @tags[0..2]) . "\n" if ($verbose && @tags > 2);
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Fallback: Try local git if we're in a repository and curl failed
|
|
if (!$tag_output && -d '.git') {
|
|
print $stdout "-- curl failed, trying local git...\n" if ($verbose);
|
|
$tag_output = `git tag --list --sort=-version:refname 2>/dev/null | head -1`;
|
|
chomp($tag_output);
|
|
}
|
|
} else {
|
|
# No curl available, try git only if in repository
|
|
if (-d '.git') {
|
|
print $stdout "-- no curl available, using local git...\n" if ($verbose);
|
|
$tag_output = `git tag --list --sort=-version:refname 2>/dev/null | head -1`;
|
|
chomp($tag_output);
|
|
}
|
|
}
|
|
|
|
if ($tag_output) {
|
|
$latest_version = $tag_output;
|
|
|
|
# Compare versions
|
|
if ($latest_version gt $current_version) {
|
|
$vs .= "** NEW TTYverse VERSION AVAILABLE: $latest_version **\n";
|
|
$vs .= "** (you have: $current_version)\n";
|
|
$vs .= "** get it: $repo_url\n";
|
|
if ($update_url) {
|
|
$vs .= "-- %URL% is now $repo_url (/short shortens, /url opens)\n";
|
|
$urlshort = $repo_url;
|
|
}
|
|
} elsif ($latest_version eq $current_version) {
|
|
$vs .= "-- your version of TTYverse is up to date ($current_version)\n";
|
|
} else {
|
|
# Local version is newer - check if we're in a git repo
|
|
if (-d '.git') {
|
|
$vs .= "-- your version ($current_version) is newer than latest remote ($latest_version)\n";
|
|
$vs .= "-- you may have unpushed changes or unreleased version\n";
|
|
} else {
|
|
$vs .= "-- you appear to have a development version ($current_version)\n";
|
|
$vs .= "-- latest stable release: $latest_version\n";
|
|
}
|
|
}
|
|
} else {
|
|
$vs .= "-- warning: unable to determine latest version\n";
|
|
$vs .= "-- git and HTTP methods both failed\n";
|
|
$vs .= "-- you have: $current_version\n";
|
|
$vs .= "-- please visit $repo_url to check for updates manually\n";
|
|
}
|
|
|
|
return $vs;
|
|
|
|
# Old TTYtter logic (commented out)
|
|
if (0) {
|
|
if ($my_version_string eq $bversion) {
|
|
$vs .=
|
|
"** REMINDER: you are using a beta version (${my_version_string}b${TTYverse_RC_NUMBER})\n";
|
|
$vs .=
|
|
"** NEW TTYverse RELEASE CANDIDATE AVAILABLE: build $rcnum **\n" .
|
|
"** get it: $bdownload\n$s2"
|
|
if ($TTYverse_RC_NUMBER < $rcnum);
|
|
$vs .= "** (this is the most current beta)\n"
|
|
if ($TTYverse_RC_NUMBER == $rcnum);
|
|
$vs .= "$s1$s3";
|
|
if ($TTYverse_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 && $TTYverse_RC_NUMBER) {
|
|
$vs .=
|
|
"** FINAL TTYverse 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+$TTYverse_VERSION < $maj ||
|
|
(0+$TTYverse_VERSION == $maj &&
|
|
$TTYverse_PATCH_VERSION < $min)) {
|
|
$vs .=
|
|
"** NEWER TTYverse 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+$TTYverse_VERSION > $maj ||
|
|
(0+$TTYverse_VERSION == $maj &&
|
|
$TTYverse_PATCH_VERSION > $min)) {
|
|
$vs .=
|
|
"** unable to identify your version of TTYverse\n$s1";
|
|
} else {
|
|
$vs .=
|
|
"-- your version of TTYverse is up to date ($inversion)\n$s1";
|
|
}
|
|
}
|
|
|
|
# if we got this far, then there is no TTYverse 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 if ($verbose);
|
|
sleep 2 if ($dostream);
|
|
kill 9, $curlpid if ($curlpid);
|
|
kill 9, $child;
|
|
}
|
|
&$shutdown unless (!$shutdown);
|
|
}
|
|
|
|
sub generate_ansi {
|
|
my $k;
|
|
|
|
$BLUE = ($ansi) ? "${ESC}[34;1m" : '';
|
|
$RED = ($ansi) ? "${ESC}[31;1m" : '';
|
|
$GREEN = ($ansi) ? "${ESC}[32;1m" : '';
|
|
$YELLOW = ($ansi) ? "${ESC}[33m" : '';
|
|
$MAGENTA = ($ansi) ? "${ESC}[35m" : '';
|
|
$CYAN = ($ansi) ? "${ESC}[36m" : '';
|
|
|
|
$EM = ($ansi) ? "${ESC}[1m" : '';
|
|
$UNDER = ($ansi) ? "${ESC}[4m" : '';
|
|
$OFF = ($ansi) ? "${ESC}[0m" : '';
|
|
|
|
foreach $k (qw(prompt me dm reply warn search list default)) {
|
|
${"colour$k"} = uc(${"colour$k"});
|
|
if (!defined($${"colour$k"})) {
|
|
print $stdout
|
|
"-- warning: bogus colour '".${"colour$k"}."'\n";
|
|
} else {
|
|
eval("\$CC$k = \$".${"colour$k"});
|
|
}
|
|
}
|
|
|
|
eval '$termrl->hook_use_ansi' if ($termrl);
|
|
}
|
|
|
|
# always POST
|
|
sub postjson {
|
|
my $url = shift;
|
|
my $postdata = shift; # add _method=DELETE for delete
|
|
my $data;
|
|
|
|
# this is copied mostly verbatim from grabjson
|
|
chomp($data = &backticks($baseagent, '/dev/null', undef, $url,
|
|
$postdata, 0, @wend));
|
|
my $k = $? >> 8;
|
|
|
|
$data =~ s/[\r\l\n\s]*$//s;
|
|
$data =~ s/^[\r\l\n\s]*//s;
|
|
|
|
if (!length($data) || $k == 28 || $k == 7 || $k == 35) {
|
|
&$exception(1, "*** warning: timeout or no data\n");
|
|
return undef;
|
|
}
|
|
|
|
# old non-JSON based error reporting code still supported
|
|
if ($data =~ /^\[?\]?<!DOCTYPE\s+html/i || $data =~ /^(Status:\s*)?50[0-9]\s/ || $data =~ /^<html>/i || $data =~ /^<\??xml\s+/) {
|
|
print $stdout $data if ($superverbose);
|
|
if (&is_fail_whale($data)) {
|
|
&$exception(2, "*** warning: Server temporarily unavailable\n");
|
|
} else {
|
|
&$exception(2, "*** warning: server error message received\n" .
|
|
(($data =~ /<title>([^<]+)</) ?
|
|
"*** \"$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);
|
|
|
|
# Handle successful HTTP responses properly for fediverse APIs
|
|
if ($code == 200) {
|
|
# 200 OK with content - continue processing
|
|
} elsif ($code == 204) {
|
|
# 204 No Content - successful but empty (normal for some API calls)
|
|
print $stdout "-- No new content (HTTP 204)\n" if ($verbose);
|
|
return [];
|
|
} elsif ($code == 304) {
|
|
# 304 Not Modified - no new content since last fetch
|
|
print $stdout "-- No new content since last fetch (HTTP 304)\n" if ($verbose);
|
|
return [];
|
|
} else {
|
|
&$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 &map_mastodon_fields(&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);
|
|
}
|
|
|
|
# limit parameter for Mastodon API (replaces Twitter's count parameter)
|
|
push(@xargs, "limit=$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);
|
|
|
|
# include_entities is Twitter-specific, not needed for Mastodon
|
|
# push (@xargs, "include_entities=1") if ($do_entities);
|
|
|
|
my $resource = (scalar(@xargs)) ?
|
|
[ $url, join('&', sort @xargs) ] : $url;
|
|
|
|
# Debug: show the actual API call being made
|
|
if ($verbose && ref($resource) eq 'ARRAY') {
|
|
print $stdout "-- DEBUG: API call: $resource->[0]?$resource->[1]\n";
|
|
} elsif ($verbose) {
|
|
print $stdout "-- DEBUG: API call: $resource\n";
|
|
}
|
|
|
|
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: Server temporarily unavailable\n");
|
|
} else {
|
|
&$exception(2, "*** warning: server error message received\n" .
|
|
(($data =~ /<title>([^<]+)</) ?
|
|
"*** \"$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);
|
|
|
|
# Handle successful HTTP responses properly for fediverse APIs
|
|
if ($code == 200) {
|
|
# 200 OK with content - continue processing
|
|
} elsif ($code == 204) {
|
|
# 204 No Content - successful but empty (normal for some API calls)
|
|
print $stdout "-- No new content (HTTP 204)\n" if ($verbose);
|
|
return [];
|
|
} elsif ($code == 304) {
|
|
# 304 Not Modified - no new content since last fetch
|
|
print $stdout "-- No new content since last fetch (HTTP 304)\n" if ($verbose);
|
|
return [];
|
|
} else {
|
|
&$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 = &map_mastodon_fields(&parsejson($data));
|
|
|
|
# normalize the data into a standard form.
|
|
# single posts such as from statuses/show aren't arrays, so
|
|
# we special-case for them.
|
|
if (defined($my_json_ref) && ref($my_json_ref) eq 'HASH' &&
|
|
$my_json_ref->{'favorited'} &&
|
|
$my_json_ref->{'source'} &&
|
|
((0+$my_json_ref->{'id'}) ||
|
|
length($my_json_ref->{'id_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 &map_mastodon_fields($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;
|
|
|
|
# fediverse 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 post 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 posts, since
|
|
# we're iterating through them anyway. the tag should be a hashref payload.
|
|
# - if the post is an newRT, unwrap it so that the full post text is
|
|
# revealed (unless -noreblogs).
|
|
# - if this appears to be a post, 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 post
|
|
$i->{'tag'} = $tag if (defined($tag));
|
|
|
|
# id -> id_str if needed
|
|
if (!length($i->{'id_str'})) {
|
|
# Fediverse servers use string IDs - copy directly without numeric conversion
|
|
if (defined($i->{'id'})) {
|
|
$i->{'id_str'} = $i->{'id'};
|
|
}
|
|
}
|
|
# irtsid -> irtsid_str (if there is one)
|
|
if (!length($i->{'in_reply_to_status_id_str'}) &&
|
|
$i->{'in_reply_to_status_id'}) {
|
|
# Fediverse servers use string IDs - copy directly without numeric conversion
|
|
$i->{'in_reply_to_status_id_str'} = $i->{'in_reply_to_status_id'};
|
|
}
|
|
|
|
# normalize geo. if this has a source and it has a
|
|
# favorited, then it is probably a post and we will
|
|
# add a stub geo hash if one doesn't exist yet.
|
|
if ($kludge_search_api_adjust ||
|
|
($i->{'favorited'} && $i->{'source'})){
|
|
$i = &fix_geo_api_data($i);
|
|
}
|
|
|
|
# hooray! this just tags it
|
|
if ($kludge_search_api_adjust) {
|
|
$i->{'class'} = "search";
|
|
}
|
|
|
|
# normalize newRTs
|
|
# if we get newRTs with -noreblogs, oh well
|
|
my $boost_content = '';
|
|
my $boost_attribution = '';
|
|
my $boost_user = undef;
|
|
|
|
if (!$noreblogs && ($rt = $i->{'reblog'})) {
|
|
# reconstruct the boost in fediverse format: <author> [boosted <booster@domain>] content
|
|
# without truncation, but detco it first
|
|
$rt = &destroy_all_tco($rt);
|
|
$i->{'reblog'} = $rt;
|
|
|
|
# Get original author and content
|
|
my $original_author = $rt->{'user'}->{'acct'} || $rt->{'user'}->{'username'} || 'unknown_user';
|
|
my $content = $rt->{'text'} || '';
|
|
|
|
# Get booster (who shared this)
|
|
my $booster = $i->{'user'}->{'acct'} || $i->{'user'}->{'username'} || 'unknown_booster';
|
|
|
|
print $stdout "-- DEBUG: Boost - original: '$original_author', booster: '$booster', content: '$content'\n" if ($verbose);
|
|
|
|
# Store boost data to apply after destroy_all_tco
|
|
$boost_content = $content;
|
|
my $original_acct = $rt->{'user'}->{'acct'} || $rt->{'user'}->{'username'} || $original_author;
|
|
$boost_attribution = $original_acct;
|
|
|
|
# Set booster as the main user (who performed the boost action)
|
|
$boost_user = {
|
|
'username' => $booster,
|
|
'acct' => $booster
|
|
};
|
|
}
|
|
|
|
# Apply destroy_all_tco first
|
|
$i = &destroy_all_tco($i);
|
|
|
|
# Now apply boost data after destroy_all_tco processing
|
|
if ($boost_content) {
|
|
$i->{'text'} = $boost_content;
|
|
$i->{'boost_attribution'} = $boost_attribution;
|
|
$i->{'user'} = $boost_user;
|
|
print $stdout "-- DEBUG: Final boost data applied - text: '$boost_content', attribution: '$boost_attribution'\n" if ($verbose);
|
|
}
|
|
|
|
# Handle poll data - check for polls in boost-aware manner (Bifrost pattern)
|
|
my $poll_data = undef;
|
|
if (exists($i->{'reblog'}) && exists($i->{'reblog'}->{'poll'})) {
|
|
# Poll is in the boosted post
|
|
$poll_data = $i->{'reblog'}->{'poll'};
|
|
print $stdout "-- DEBUG: Found poll in boosted post\n" if ($verbose);
|
|
} elsif (exists($i->{'poll'})) {
|
|
# Poll is in the main post
|
|
$poll_data = $i->{'poll'};
|
|
print $stdout "-- DEBUG: Found poll in main post\n" if ($verbose);
|
|
}
|
|
|
|
# Store poll data for display - but only if it's a valid poll with options
|
|
if ($poll_data && ref($poll_data) eq 'HASH' && exists($poll_data->{'options'}) && @{$poll_data->{'options'}}) {
|
|
$i->{'poll'} = $poll_data;
|
|
print $stdout "-- DEBUG: Poll data stored for display\n" if ($verbose);
|
|
} else {
|
|
# Clear any false poll data
|
|
delete $i->{'poll'} if exists($i->{'poll'});
|
|
print $stdout "-- DEBUG: No valid poll data found, cleared poll flag\n" if ($verbose && $poll_data);
|
|
}
|
|
|
|
return $i;
|
|
}
|
|
|
|
# process the JSON data ... simplemindedly, because I just write utter crap,
|
|
# am not a professional programmer, and don't give a flying fig whether
|
|
# kludges suck or no. this used to be part of grabjson, but I split it out.
|
|
sub parsejson {
|
|
my $data = shift;
|
|
my $my_json_ref = undef; # durrr hat go on foot
|
|
|
|
# Early filtering for HTTP error responses in fediverse mode
|
|
if ($authtype eq 'oauth2' && defined($data)) {
|
|
# Filter out obvious HTTP error responses before processing
|
|
if ($data =~ /^HTTP\/\d\.\d\s+\d+/ ||
|
|
$data =~ /\b(405|404|403|401|500)\s+(Method\s+Not\s+Allowed|Not\s+Found|Forbidden|Unauthorized|Internal\s+Server\s+Error)/i ||
|
|
$data =~ /^\s*\d{3}\s+\w+\s*$/) {
|
|
return undef;
|
|
}
|
|
}
|
|
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 fediverse 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 ...
|
|
# Special case: empty array is valid in fediverse APIs
|
|
if ($tdata eq "[]") {
|
|
return [];
|
|
}
|
|
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 some APIs use 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.
|
|
# For fediverse JSON, we're more permissive as it includes
|
|
# boolean, null, and number values that are valid JSON.
|
|
# Also filter out HTTP status lines and error responses that might appear
|
|
if ($authtype eq 'oauth2') {
|
|
# For fediverse, be more permissive with HTTP error responses
|
|
if ($tdata =~ /^HTTP\/\d\.\d\s+\d+/ ||
|
|
$tdata =~ /\b\d{3}\s+(method|not\s+found|forbidden|unauthorized)/i ||
|
|
$tdata =~ /\b(405|404|403|401|500)\s+\w+/i) {
|
|
# Skip validation for HTTP error responses
|
|
return undef;
|
|
}
|
|
}
|
|
my $json_check = ($authtype eq 'oauth2')
|
|
? qr/[^\[\]\{\}:,\s\w\d\.\-"'@#\/%]/ # More permissive for fediverse (allow @, #, /, %, etc.)
|
|
: qr/[^\[\]\{\}:,]/; # Strict check for fediverse
|
|
if ($tdata =~ /$json_check/) {
|
|
&$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;
|
|
}
|
|
|
|
# Map Mastodon/ActivityPub JSON fields to fediverse-compatible field names
|
|
# This maintains compatibility with existing display logic
|
|
sub map_mastodon_fields {
|
|
my $json_ref = shift;
|
|
return $json_ref unless ($authtype eq 'oauth2'); # Only for fediverse
|
|
|
|
# Handle single status objects
|
|
if (ref($json_ref) eq 'HASH' && exists($json_ref->{'content'})) {
|
|
$json_ref = &map_single_status($json_ref, 0);
|
|
}
|
|
# Handle user/account objects (verify_credentials, etc.)
|
|
elsif (ref($json_ref) eq 'HASH' && exists($json_ref->{'username'})) {
|
|
$json_ref = &map_user_object($json_ref);
|
|
}
|
|
# Handle arrays of statuses (timelines)
|
|
elsif (ref($json_ref) eq 'ARRAY') {
|
|
for my $i (0..$#{$json_ref}) {
|
|
$json_ref->[$i] = &map_single_status($json_ref->[$i], 0)
|
|
if (ref($json_ref->[$i]) eq 'HASH');
|
|
}
|
|
}
|
|
|
|
return $json_ref;
|
|
}
|
|
|
|
sub map_single_status {
|
|
my $status = shift;
|
|
my $recursion_depth = shift || 0;
|
|
return $status unless (ref($status) eq 'HASH');
|
|
|
|
# Prevent infinite recursion - limit depth to 1 level
|
|
return $status if ($recursion_depth > 1);
|
|
|
|
# Skip re-processing if this is already a processed boost post
|
|
if (exists($status->{'boost_attribution'}) && $status->{'boost_attribution'}) {
|
|
print $stdout "-- DEBUG: Skipping re-processing of already processed boost post\n" if ($verbose);
|
|
return $status;
|
|
}
|
|
|
|
# Debug: Check if this is a boost
|
|
if (exists($status->{'reblog'}) && $status->{'reblog'}) {
|
|
print $stdout "-- DEBUG: Found boost - original account: " . ($status->{'account'}->{'acct'} || 'unknown') . "\n" if ($verbose);
|
|
print $stdout "-- DEBUG: Reblog content present: " . (exists($status->{'reblog'}->{'content'}) ? 'yes' : 'no') . "\n" if ($verbose);
|
|
print $stdout "-- DEBUG: Reblog account present: " . (exists($status->{'reblog'}->{'account'}) ? 'yes' : 'no') . "\n" if ($verbose);
|
|
}
|
|
|
|
# Core Mastodon → fediverse field mappings
|
|
if (exists($status->{'content'})) {
|
|
$status->{'text'} = &html_to_text($status->{'content'});
|
|
}
|
|
$status->{'user'} = $status->{'account'} if exists($status->{'account'});
|
|
# reblog and reblogs_count fields are already in correct format for ActivityPub
|
|
$status->{'favorite_count'} = $status->{'favourites_count'} if exists($status->{'favourites_count'});
|
|
$status->{'in_reply_to_status_id_str'} = $status->{'in_reply_to_id'} if exists($status->{'in_reply_to_id'});
|
|
|
|
# User/Account field mappings - native fediverse fields preferred
|
|
if (exists($status->{'user'}) && ref($status->{'user'}) eq 'HASH') {
|
|
my $user = $status->{'user'};
|
|
# Map display fields only for compatibility with display functions
|
|
$user->{'name'} = $user->{'display_name'} if exists($user->{'display_name'});
|
|
$user->{'profile_image_url'} = $user->{'avatar'} if exists($user->{'avatar'});
|
|
# Native fediverse fields: username, acct (username@domain.com)
|
|
}
|
|
|
|
# Recursively map reblogged status - with depth limit to prevent infinite recursion
|
|
if (exists($status->{'reblog'})) {
|
|
print $stdout "-- DEBUG: Processing reblogged status recursively (depth: $recursion_depth)\n" if ($verbose);
|
|
$status->{'reblog'} = &map_single_status($status->{'reblog'}, $recursion_depth + 1);
|
|
}
|
|
|
|
return $status;
|
|
}
|
|
|
|
sub map_user_object {
|
|
my $user = shift;
|
|
|
|
# Map display-only fields for legacy compatibility
|
|
$user->{'name'} = $user->{'display_name'} if exists($user->{'display_name'});
|
|
$user->{'profile_image_url'} = $user->{'avatar'} if exists($user->{'avatar'});
|
|
# Count fields use native names already
|
|
$user->{'followers_count'} = $user->{'followers_count'} if exists($user->{'followers_count'});
|
|
$user->{'friends_count'} = $user->{'following_count'} if exists($user->{'following_count'});
|
|
$user->{'statuses_count'} = $user->{'statuses_count'} if exists($user->{'statuses_count'});
|
|
# Use native fediverse username/acct fields directly
|
|
|
|
return $user;
|
|
}
|
|
|
|
# Get server configuration and update character limits
|
|
sub update_server_config {
|
|
return unless ($authtype eq 'oauth2'); # Only for fediverse servers
|
|
|
|
my $instance_url = "${http_proto}://${fediverseserver}/api/v1/instance";
|
|
print $stdout "-- checking server configuration...\n" if ($verbose);
|
|
|
|
my $config_json = &grabjson($instance_url);
|
|
if (!$config_json) {
|
|
print $stdout "-- server configuration unavailable (using defaults)\n" if ($verbose);
|
|
return;
|
|
}
|
|
|
|
# Extract character limit from server configuration
|
|
if (exists($config_json->{'configuration'}->{'statuses'}->{'max_characters'})) {
|
|
my $server_limit = $config_json->{'configuration'}->{'statuses'}->{'max_characters'};
|
|
if ($server_limit > 0 && $server_limit != $linelength) {
|
|
print $stdout "-- server character limit: $server_limit (was $linelength)\n" if ($verbose);
|
|
$linelength = $server_limit;
|
|
}
|
|
}
|
|
|
|
# Check for streaming support based on server software
|
|
my $server_software = $config_json->{'version'} || '';
|
|
if ($server_software =~ /(mastodon|pleroma|akkoma|misskey|foundkey|calckey|firefish)/i) {
|
|
print $stdout "-- streaming supported by $1\n" if ($verbose);
|
|
print $stdout "-- enable with -dostream for real-time updates\n" if ($verbose && !$dostream);
|
|
} elsif ($server_software =~ /gotosocial/i) {
|
|
print $stdout "-- GoToSocial detected (streaming available)\n" if ($verbose);
|
|
print $stdout "-- enable with -dostream for real-time updates\n" if ($verbose && !$dostream);
|
|
}
|
|
|
|
# Also check for other useful server info
|
|
if (exists($config_json->{'title'})) {
|
|
print $stdout "-- connected to: " . $config_json->{'title'} . "\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
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>.*Over.+capacity.*</title>#i ||
|
|
$data =~ m#[\r\l\n\s]*DB_DataObject Error: Connect failed#s);
|
|
}
|
|
|
|
# {'errors':[{'message':'Rate limit exceeded','code':88}]}
|
|
sub is_json_error {
|
|
# is this actually a JSON error message? if so, extract it
|
|
my $data = shift;
|
|
if ($data =~ /(['"])(warning|errors?)\1\s*:\s*/s) {
|
|
if ($data =~ /^\s*\{/s) { # JSON object?
|
|
my $dref = &map_mastodon_fields(&parsejson($data));
|
|
print $stdout "*** is_json_error returning true\n"
|
|
if ($verbose);
|
|
# support 1.0 and 1.1 error objects
|
|
return $dref->{'error'} if (length($dref->{'error'}));
|
|
return $dref->{'errors'}->[0]->{'message'}
|
|
if (length($dref->{'errors'}->[0]->{'message'}));
|
|
return (split(/\\n/, $dref->{'errors'}))[0]
|
|
if(length($dref->{'errors'}));
|
|
}
|
|
return $data;
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub backticks {
|
|
# more efficient/flexible backticks system
|
|
my $comm = shift;
|
|
my $rerr = shift;
|
|
my $rout = shift;
|
|
my $resource = shift;
|
|
my $data = shift;
|
|
my $dont_do_auth = shift;
|
|
my $buf = '';
|
|
my $undersave = $_;
|
|
my $pid;
|
|
my $args;
|
|
|
|
($comm, $args, $data) = &$stringify_args($comm, $resource,
|
|
$data, $dont_do_auth, @_);
|
|
print $stdout "$comm\n$args\n$data\n" if ($superverbose);
|
|
if(open(BACTIX, '-|')) {
|
|
while(<BACTIX>) {
|
|
$buf .= $_;
|
|
} close(BACTIX);
|
|
$_ = $undersave;
|
|
return $buf; # and $? is still in $?
|
|
} else {
|
|
$in_backticks = 1;
|
|
&sigify(sub {
|
|
die(
|
|
"** user agent not honouring timeout (caught by sigalarm)\n");
|
|
}, qw(ALRM));
|
|
alarm 120; # this should be sufficient
|
|
if (length($rerr)) {
|
|
close(STDERR);
|
|
open(STDERR, ">$rerr");
|
|
}
|
|
if (length($rout)) {
|
|
close(STDOUT);
|
|
open(STDOUT, ">$rout");
|
|
}
|
|
if(open(FRONTIX, "|$comm")) {
|
|
print FRONTIX "$args\n";
|
|
print FRONTIX "$data" if (length($data));
|
|
close(FRONTIX);
|
|
} else {
|
|
die(
|
|
"backticks() failure for $comm $rerr $rout @_: $!\n");
|
|
}
|
|
$rv = $? >> 8;
|
|
exit $rv;
|
|
}
|
|
}
|
|
|
|
sub wherecheck {
|
|
my ($prompt, $filename, $fatal) = (@_);
|
|
my (@paths) = split(/\:/, $ENV{'PATH'});
|
|
my $setv = '';
|
|
|
|
push(@paths, '/usr/bin'); # the usual place
|
|
@paths = ('') if ($filename =~ m#^/#); # for absolute paths
|
|
|
|
print $stdout "$prompt ... " unless ($silent);
|
|
foreach(@paths) {
|
|
if (-r "$_/$filename") {
|
|
$setv = "$_/$filename";
|
|
1 while $setv =~ s#//#/#;
|
|
print $stdout "$setv\n" unless ($silent);
|
|
last;
|
|
}
|
|
}
|
|
if (!length($setv)) {
|
|
print $stdout "not found.\n";
|
|
if ($fatal) {
|
|
print $stdout $fatal;
|
|
exit(1);
|
|
}
|
|
}
|
|
return $setv;
|
|
}
|
|
|
|
sub screech {
|
|
print $stdout "\n\n${BEL}${BEL}@_";
|
|
if ($is_background) {
|
|
kill 9, $parent;
|
|
kill 9, $$;
|
|
} elsif ($child) {
|
|
kill 9, $child;
|
|
kill 9, $$;
|
|
}
|
|
die("death not achieved conventionally");
|
|
}
|
|
|
|
# &in($x, @y) returns true if $x is a member of @y
|
|
sub in { my $key = shift; my %mat = map { $_ => 1 } @_;
|
|
return $mat{$key}; }
|
|
|
|
sub descape {
|
|
my $x = shift;
|
|
my $mode = shift;
|
|
|
|
$x =~ s#\\/#/#g;
|
|
|
|
# try to do something sensible with unicode
|
|
if ($mode) { # this probably needs to be revised
|
|
$x =~ s/\\u([0-9a-fA-F]{4})/"&#" . hex($1) . ";"/eg;
|
|
} else {
|
|
# intermediate form if HTML entities get in
|
|
$x =~ s/\&\#([0-9]+);/'\u' . sprintf("%04x", $1)/eg;
|
|
|
|
$x =~ s/\\u202[89]/\\n/g;
|
|
|
|
# canonicalize Unicode whitespace
|
|
1 while ($x =~ s/\\u(00[aA]0)/ /g);
|
|
1 while ($x =~ s/\\u(200[0-9aA])/ /g);
|
|
1 while ($x =~ s/\\u(20[25][fF])/ /g);
|
|
if ($seven) {
|
|
# known UTF-8 entities (char for char only)
|
|
$x =~ s/\\u201[89]/\'/g;
|
|
$x =~ s/\\u201[cCdD]/\"/g;
|
|
|
|
# 7-bit entities (32-126) also ok
|
|
$x =~ s/\\u00([2-7][0-9a-fA-F])/chr(((hex($1)==127)?46:hex($1)))/eg;
|
|
|
|
# dot out the rest
|
|
$x =~ s/\\u([0-9a-fA-F]{4})/./g;
|
|
$x =~ s/[\x80-\xff]/./g;
|
|
} else {
|
|
# try to promote to UTF-8
|
|
&$utf8_decode($x);
|
|
|
|
# fediverse uses UTF-16 for high code points, which
|
|
# Perl's UTF-8 support does not like as surrogates.
|
|
# try to decode these here; they are always back-to-
|
|
# back surrogates of the form \uDxxx\uDxxx
|
|
$x =~
|
|
s/\\u([dD][890abAB][0-9a-fA-F]{2})\\u([dD][cdefCDEF][0-9a-fA-F]{2})/&deutf16($1,$2)/eg;
|
|
|
|
# decode the rest
|
|
$x =~ s/\\u([0-9a-fA-F]{4})/chr(hex($1))/eg;
|
|
$x = &uforcemulti($x);
|
|
}
|
|
$x =~ s/\"/"/g;
|
|
$x =~ s/\'/'/g;
|
|
$x =~ s/\</\</g;
|
|
$x =~ s/\>/\>/g;
|
|
$x =~ s/\&/\&/g;
|
|
}
|
|
if ($newline) {
|
|
$x =~ s/\\n/\n/sg;
|
|
$x =~ s/\\r//sg;
|
|
}
|
|
return $x;
|
|
}
|
|
|
|
sub html_to_text {
|
|
my $html = shift;
|
|
return "" unless defined($html);
|
|
|
|
# Convert common HTML elements to text equivalents
|
|
$html =~ s/<br\s*\/?>/\n/gi; # Line breaks
|
|
$html =~ s/<\/p>\s*<p[^>]*>/\n\n/gi; # Paragraph breaks
|
|
$html =~ s/<p[^>]*>//gi; # Remove opening <p> tags
|
|
$html =~ s/<\/p>//gi; # Remove closing </p> tags
|
|
|
|
# Handle links - extract just the URL and hashtag text
|
|
$html =~ s/<a[^>]*href="([^"]*)"[^>]*><span[^>]*>[^<]*<\/span><span[^>]*>([^<]*)<\/span><span[^>]*>[^<]*<\/span><\/a>/$2/gi; # Mastodon link format
|
|
$html =~ s/<a[^>]*class="mention hashtag"[^>]*>#<span>([^<]*)<\/span><\/a>/#$1/gi; # Hashtags
|
|
$html =~ s/<a[^>]*href="([^"]*)"[^>]*>([^<]*)<\/a>/$2/gi; # Simple links - show text
|
|
|
|
# Remove all remaining HTML tags
|
|
$html =~ s/<[^>]*>//g;
|
|
|
|
# Decode HTML entities
|
|
$html =~ s/"/"/g;
|
|
$html =~ s/'/'/g;
|
|
$html =~ s/</</g;
|
|
$html =~ s/>/>/g;
|
|
$html =~ s/&/&/g;
|
|
|
|
# Clean up whitespace
|
|
$html =~ s/\s+/ /g; # Multiple spaces to single space
|
|
$html =~ s/^\s+|\s+$//g; # Trim leading/trailing whitespace
|
|
$html =~ s/\n\s+/\n/g; # Remove spaces after newlines
|
|
|
|
return $html;
|
|
}
|
|
|
|
# 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, fediverse uses this endianness below (we have no BOM)
|
|
# see RFC 2781 4.3
|
|
return chr(($one << 10) + $two + 65536);
|
|
}
|
|
sub max {
|
|
# Fediverse-only: use string comparison for post IDs
|
|
return ($_[0] gt $_[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;
|
|
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;
|
|
}
|
|
# Smart URL handling - keep URLs on one line if possible
|
|
if ($string =~ s#^(https?://\S+)\s*##) {
|
|
$buf .= "$1\n";
|
|
next W;
|
|
}
|
|
|
|
# Also handle URLs that might appear mid-text
|
|
if ($string =~ /^(.{0,20})(https?:\/\/\S+)(.*)$/ && length($2) <= $lop) {
|
|
my ($before, $url, $after) = ($1, $2, $3);
|
|
if (length($before) + length($url) <= $lop) {
|
|
$string = $after;
|
|
$buf .= "$before$url\n";
|
|
next W;
|
|
}
|
|
}
|
|
|
|
# Try to break on word boundaries with smart lookback
|
|
if ($string =~ s/^(.{4,$lop})\s+/ /) {
|
|
$buf .= "$1\n";
|
|
next W;
|
|
}
|
|
|
|
# If no space found, look for punctuation boundaries
|
|
if ($string =~ s/^(.{4,$lop})([.,;:!?\)\]\}])/ $2/) {
|
|
$buf .= "$1\n";
|
|
next W;
|
|
}
|
|
|
|
# Last resort: try to find ANY whitespace or break point within reasonable distance
|
|
my $search_back = int($lop * 0.8); # Allow up to 20% shorter lines to avoid mid-word breaks
|
|
if ($search_back > 10 && $string =~ s/^(.{$search_back,$lop})\s+/ /) {
|
|
$buf .= "$1\n";
|
|
next W;
|
|
}
|
|
|
|
# Ultimate fallback: break at line length (original behavior)
|
|
if ($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/fediverse/fediverse-text-js/blob/master/fediverse-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);
|
|
|
|
# OAuth 2.0 mode - return access token (no token secret needed)
|
|
if ($authtype eq 'oauth2') {
|
|
return ($tokenkey, undef) if (length($tokenkey));
|
|
die("OAuth 2.0 access token required. Run with -oauthwizard to set up.\n");
|
|
}
|
|
|
|
# OAuth 1.0a mode - return both tokens
|
|
return ($tokenkey,$tokensecret)
|
|
if (length($tokenkey) && length($tokensecret));
|
|
|
|
# Basic auth mode - return username/password
|
|
@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);
|
|
}
|
|
|
|
# OAuth 2.0 wizard for Mastodon/fediverse
|
|
sub oauth2_wizard {
|
|
# Step 0: Ask user for their fediverse instance
|
|
print $stdout "\n" . "="x70 . "\n";
|
|
print $stdout "FEDIVERSE INSTANCE SELECTION\n";
|
|
print $stdout "="x70 . "\n";
|
|
print $stdout "TTYverse can connect to any Mastodon-compatible fediverse server.\n";
|
|
print $stdout "Popular instances include:\n\n";
|
|
print $stdout " • mastodon.social (flagship instance)\n";
|
|
print $stdout " • fosstodon.org (FOSS community)\n";
|
|
print $stdout " • hachyderm.io (tech community)\n";
|
|
print $stdout " • mas.to (general community)\n";
|
|
print $stdout " • mstdn.social (another general instance)\n\n";
|
|
print $stdout "Enter the domain name of your fediverse instance\n";
|
|
print $stdout "(without https://, just the domain like 'mastodon.social')\n\n";
|
|
|
|
my $user_instance;
|
|
while (1) {
|
|
print $stdout "Instance domain: ";
|
|
chomp($user_instance = <STDIN>);
|
|
|
|
if (!length($user_instance)) {
|
|
print $stdout "ERROR: Please enter an instance domain.\n\n";
|
|
next;
|
|
}
|
|
|
|
# Clean up the input - remove protocol, trailing slashes, etc.
|
|
$user_instance =~ s/^https?:\/\///;
|
|
$user_instance =~ s/\/$//;
|
|
$user_instance =~ s/^\s+|\s+$//g; # trim whitespace
|
|
|
|
if ($user_instance !~ /^[a-zA-Z0-9.-]+\.[a-zA-Z]{2,}$/) {
|
|
print $stdout "ERROR: '$user_instance' doesn't look like a valid domain.\n";
|
|
print $stdout "Please enter just the domain (like 'mastodon.social')\n\n";
|
|
next;
|
|
}
|
|
|
|
last;
|
|
}
|
|
|
|
# Update the global configuration to use user's instance
|
|
$fediverseserver = $user_instance;
|
|
&configure_fediverse_endpoints($fediverseserver);
|
|
|
|
print $stdout "\nRegistering TTYverse with $fediverseserver ...\n";
|
|
|
|
# Step 1: Register the application with Mastodon
|
|
my $app_data = "client_name=TTYverse&redirect_uris=urn%3Aietf%3Awg%3Aoauth%3A2.0%3Aoob&scopes=read write follow push";
|
|
my $app_response = &postjson($oauthurl, $app_data);
|
|
|
|
unless ($app_response) {
|
|
print $stdout "FAILED! Could not register application with server.\n";
|
|
exit;
|
|
}
|
|
|
|
# Extract client credentials from response
|
|
my $client_id = $app_response->{'client_id'};
|
|
my $client_secret = $app_response->{'client_secret'};
|
|
|
|
unless ($client_id && $client_secret) {
|
|
print $stdout "FAILED! Server did not return valid client credentials.\n";
|
|
print $stdout "Response debugging available in verbose mode\n" if ($verbose);
|
|
exit;
|
|
}
|
|
|
|
print $stdout "SUCCESS! Application registered.\n";
|
|
print $stdout "Client ID: $client_id\n" if ($verbose);
|
|
|
|
# Step 2: Get authorization from user
|
|
my $auth_url = "${oauthauthurl}?client_id=${client_id}&scope=read+write+follow+push&response_type=code&redirect_uri=urn%3Aietf%3Awg%3Aoauth%3A2.0%3Aoob";
|
|
|
|
print $stdout "\n1. Visit this URL in your browser:\n\n";
|
|
print $stdout "$auth_url\n\n";
|
|
print $stdout "2. Sign in to your $fediverseserver account if prompted.\n\n";
|
|
print $stdout "3. Authorize TTYverse to access your account.\n\n";
|
|
print $stdout "4. Copy the authorization code shown and paste it below.\n\n";
|
|
|
|
print $stdout "Enter authorization code: ";
|
|
chomp(my $auth_code = <STDIN>);
|
|
|
|
unless (length($auth_code)) {
|
|
print $stdout "ERROR: No authorization code provided.\n";
|
|
exit;
|
|
}
|
|
|
|
# Step 3: Exchange authorization code for access token
|
|
print $stdout "\nExchanging authorization code for access token...\n";
|
|
my $token_data = "client_id=${client_id}&client_secret=${client_secret}&redirect_uri=urn%3Aietf%3Awg%3Aoauth%3A2.0%3Aoob&grant_type=authorization_code&code=${auth_code}&scope=read write follow push";
|
|
my $token_response = &postjson($oauthaccurl, $token_data);
|
|
|
|
unless ($token_response) {
|
|
print $stdout "FAILED! Could not exchange authorization code for token.\n";
|
|
exit;
|
|
}
|
|
|
|
my $access_token = $token_response->{'access_token'};
|
|
|
|
unless ($access_token) {
|
|
print $stdout "FAILED! Server did not return a valid access token.\n";
|
|
print $stdout "Response debugging available in verbose mode\n" if ($verbose);
|
|
exit;
|
|
}
|
|
|
|
print $stdout "SUCCESS! Access token obtained.\n";
|
|
|
|
# Step 4: Save credentials to keyfile
|
|
my $keyfile_content = "client_id=${client_id}&client_secret=${client_secret}&access_token=${access_token}&server=${fediverseserver}";
|
|
|
|
# Ensure the keyfile directory exists
|
|
my $keyfile_dir = $keyfile;
|
|
$keyfile_dir =~ s|[^/]*$||; # Remove filename, keep directory path
|
|
if ($keyfile_dir && !-d $keyfile_dir) {
|
|
eval { make_path($keyfile_dir) };
|
|
if ($@) {
|
|
die("Failed to create keyfile directory $keyfile_dir: $@\n");
|
|
}
|
|
}
|
|
|
|
open(W, ">$keyfile") || die("couldn't write keyfile $keyfile: $!\n");
|
|
chmod 0600, $keyfile;
|
|
print W $keyfile_content;
|
|
close(W);
|
|
|
|
print $stdout "\nKeyfile $keyfile written successfully!\n";
|
|
print $stdout "You can now use TTYverse with your $fediverseserver account.\n";
|
|
|
|
exit;
|
|
}
|
|
|
|
# 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 {
|
|
my $resource = shift;
|
|
my $payload = shift;
|
|
|
|
# OAuth 2.0 Bearer token support (fediverse standard)
|
|
return undef if (!length($tokenkey));
|
|
return "-H \"Authorization: Bearer $tokenkey\"";
|
|
}
|
|
|
|
# Load locally tracked DM seen status from persistent storage
|
|
sub load_dm_seen_status {
|
|
my $seen_file = "$config/dm_seen_status";
|
|
return unless (-r $seen_file);
|
|
|
|
if (open(SEEN, '<', $seen_file)) {
|
|
print $stdout "-- DEBUG: Loading DM seen status from $seen_file\n" if ($verbose);
|
|
my $count = 0;
|
|
while (my $line = <SEEN>) {
|
|
chomp($line);
|
|
next unless ($line =~ /^(.+):(\d+)$/);
|
|
my ($tracking_key, $timestamp) = ($1, $2);
|
|
|
|
# Skip entries older than 30 days to prevent infinite growth
|
|
if (time() - $timestamp < 30 * 24 * 3600) {
|
|
$dm_seen_status{$tracking_key} = $timestamp;
|
|
$count++;
|
|
}
|
|
}
|
|
close(SEEN);
|
|
print $stdout "-- DEBUG: Loaded $count DM seen entries\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
# Save locally tracked DM seen status to persistent storage
|
|
sub save_dm_seen_status {
|
|
my $seen_file = "$config/dm_seen_status";
|
|
|
|
# Ensure config directory exists
|
|
unless (-d $config) {
|
|
mkdir($config, 0700) || do {
|
|
print $stdout "-- DEBUG: Could not create config directory $config: $!\n" if ($verbose);
|
|
return;
|
|
};
|
|
}
|
|
|
|
if (open(SEEN, '>', $seen_file)) {
|
|
print $stdout "-- DEBUG: Saving DM seen status to $seen_file\n" if ($superverbose);
|
|
my $count = 0;
|
|
for my $key (keys %dm_seen_status) {
|
|
my $timestamp = $dm_seen_status{$key};
|
|
# Only save entries from last 30 days
|
|
if (time() - $timestamp < 30 * 24 * 3600) {
|
|
print SEEN "$key:$timestamp\n";
|
|
$count++;
|
|
}
|
|
}
|
|
close(SEEN);
|
|
chmod(0600, $seen_file); # Keep private
|
|
print $stdout "-- DEBUG: Saved $count DM seen entries\n" if ($superverbose);
|
|
} else {
|
|
print $stdout "-- DEBUG: Could not save DM seen status to $seen_file: $!\n" if ($verbose);
|
|
}
|
|
}
|
|
|
|
}
|