* Plugins related to image downloding moved to subdir
+ Added plugin with sample dowloader that stores and retrieves links to/from memcache
This commit is contained in:
eleksir
179
web_link_saver/img-save.pl
Normal file
179
web_link_saver/img-save.pl
Normal file
@@ -0,0 +1,179 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
use warnings "all";
|
||||
use strict;
|
||||
use Cache::Memcached;
|
||||
use URI::URL;
|
||||
my $HTINY = undef;
|
||||
my $HTINYS = undef;
|
||||
$HTINY = eval {
|
||||
require HTTP::Tiny; # stock perl module, but some assholes from debian rip perl into modules,
|
||||
import HTTP::Tiny; # so there is non-zero possibility that we have no this module
|
||||
$HTINYS = HTTP::Tiny->can_ssl; # to operate ssl stuff, we need Net::SSLeay, but sometimes
|
||||
return 1; # installed perl environment lacks it, so use Tiny with care
|
||||
};
|
||||
|
||||
my $IMAGEMAGICK = undef; # use on demand
|
||||
if ($^O ne 'cygwin') { # cygwin 2.882 64-bit has broken Image::Magick
|
||||
$IMAGEMAGICK = eval {
|
||||
require Image::Magick;
|
||||
import Image::Magick qw(ping);
|
||||
return 1;
|
||||
};
|
||||
}
|
||||
|
||||
sub dlfunc(@);
|
||||
sub cdlfunc($); # thread, that checks and downloads stuff
|
||||
sub is_picture($);
|
||||
sub urlencode($);
|
||||
|
||||
my $wgetpath = '';
|
||||
|
||||
if (-f "/bin/wget") {
|
||||
$wgetpath = '/bin/wget';
|
||||
} elsif (-f "/usr/bin/wget") {
|
||||
$wgetpath = '/usr/bin/wget';
|
||||
} elsif (-f "/usr/local/bin/wget") {
|
||||
$wgetpath = '/usr/local/bin/wget';
|
||||
}
|
||||
|
||||
while ( 1 ) {
|
||||
my $memd = new Cache::Memcached { 'servers' => [ "127.0.0.1:11211" ] };
|
||||
my $itemref = $memd->stats(['items']);
|
||||
|
||||
if (length($itemref->{'hosts'}->{'127.0.0.1:11211'}->{'items'}) > 2) {
|
||||
my $slabinfo = (split("\n", $itemref->{'hosts'}->{'127.0.0.1:11211'}->{'items'}))[0];
|
||||
my $slab = (split(/\:/, $slabinfo))[1];
|
||||
my $itemsamount = (split(/ /, $slabinfo))[2];
|
||||
my $cachedump = $memd->stats(["cachedump $slab $itemsamount"]);
|
||||
my @keys = map { (split(/ /))[1] } split(/\n/, $cachedump->{'hosts'}->{'127.0.0.1:11211'}->{"cachedump $slab $itemsamount"});
|
||||
|
||||
foreach my $key (@keys) {
|
||||
my $url = $memd->get($key);
|
||||
cdlfunc($url);
|
||||
$memd->delete($key);
|
||||
}
|
||||
}
|
||||
|
||||
$memd->disconnect_all;
|
||||
sleep(30);
|
||||
}
|
||||
|
||||
|
||||
sub cdlfunc($) {
|
||||
my $url = shift;
|
||||
my $extension = is_picture($url);
|
||||
|
||||
if (defined($extension)) {
|
||||
my $savepath = sprintf("%s/imgsave", $ENV{'HOME'});
|
||||
mkdir ($savepath) unless (-d $savepath);
|
||||
my $fname = $url;
|
||||
$fname =~ s/[^\w!., -#]/_/g;
|
||||
$savepath = $savepath . "/" . $fname . ".$extension";
|
||||
|
||||
if ( (lc($url) =~ /\.(gif|jpeg|png|webm|mp4)$/) and ($1 eq $extension) ){
|
||||
$savepath = $ENV{'HOME'} . "/imgsave/" . $fname;
|
||||
}
|
||||
|
||||
dlfunc($url, $savepath);
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub dlfunc(@) {
|
||||
my $url = shift;
|
||||
my $file = shift;
|
||||
$url = urlencode($url);
|
||||
|
||||
if (($url =~ /^https/) and defined($HTINY) and ($HTINYS)) {
|
||||
eval {
|
||||
my $http1 = HTTP::Tiny->new();
|
||||
$http1->mirror($url, $file);
|
||||
undef $http1;
|
||||
};
|
||||
} elsif (defined($HTINY)) {
|
||||
eval {
|
||||
my $http2 = HTTP::Tiny->new();
|
||||
$http2->mirror($url, $file);
|
||||
undef $http2;
|
||||
};
|
||||
} else {
|
||||
system($wgetpath, '--no-check-certificate', '-q', '-T', '20', '-O', $file, '-o', '/dev/null', $url);
|
||||
}
|
||||
|
||||
if (($^O ne 'cygwin') and defined($IMAGEMAGICK)) {
|
||||
eval {
|
||||
if ($file =~ /(png|jpe?g|gif)$/i){
|
||||
my $im = Image::Magick->new();
|
||||
my $rename = 1;
|
||||
my (undef, undef, undef, $format) = $im->Ping($file);
|
||||
|
||||
if (defined($format)) {
|
||||
$rename = 0 if (($format eq 'JPEG') and ($file =~ /jpe?g$/i));
|
||||
$rename = 0 if (($format eq 'GIF') and ($file =~ /gif$/i));
|
||||
$rename = 0 if (($format =~ /^PNG/) and ($file =~ /png$/i));
|
||||
rename $file, sprintf("%s.%s", $file, lc($format)) if ($rename == 1);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub is_picture($) {
|
||||
my $url = shift;
|
||||
$url = urlencode($url);
|
||||
my $r = undef;
|
||||
|
||||
if (($url =~ /^https/) and defined($HTINY) and ($HTINYS)) {
|
||||
eval {
|
||||
my $http = HTTP::Tiny->new();
|
||||
$r = $http->request('HEAD', $url);
|
||||
undef $url;
|
||||
undef $http;
|
||||
};
|
||||
} elsif (defined($HTINY)) {
|
||||
eval {
|
||||
my $http = HTTP::Tiny->new();
|
||||
$r = $http->request('HEAD', $url);
|
||||
undef $url;
|
||||
undef $http;
|
||||
};
|
||||
} else {
|
||||
$r = `$wgetpath --no-check-certificate -q --method=HEAD -S --timeout=5 "$url" 2>&1`;
|
||||
if ($? == 0) {
|
||||
foreach (split(/\n/, $r)) {
|
||||
next unless($_ =~ /Content\-Type: (.+)/);
|
||||
my $h = ($1); chomp($h);
|
||||
$r->{'success'} = 1;
|
||||
$r->{'headers'}->{'content-type'} = $h;
|
||||
last;
|
||||
}
|
||||
} else {
|
||||
$r->{'success'} = 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($r->{'success'} and defined($r->{'headers'}->{'content-type'})) {
|
||||
if ($r->{'headers'}->{'content-type'} =~ /^image\/gif/) { $r = 'gif'; }
|
||||
elsif ($r->{'headers'}->{'content-type'} =~ /^image\/jpe?g/){ $r = 'jpeg';}
|
||||
elsif ($r->{'headers'}->{'content-type'} =~ /^image\/png/) { $r = 'png'; }
|
||||
elsif ($r->{'headers'}->{'content-type'} =~ /^video\/webm/) { $r = 'webm';}
|
||||
elsif ($r->{'headers'}->{'content-type'} =~ /^video\/mp4/) { $r = 'mp4'; }
|
||||
else { $r = undef; }
|
||||
} else {
|
||||
$r = undef;
|
||||
}
|
||||
|
||||
return $r;
|
||||
}
|
||||
|
||||
sub urlencode($) {
|
||||
my $url = shift;
|
||||
my $urlobj = url $url;
|
||||
$url = $urlobj->as_string;
|
||||
undef $urlobj;
|
||||
return $url;
|
||||
}
|
||||
297
web_link_saver/img_url_memc.pl
Normal file
297
web_link_saver/img_url_memc.pl
Normal file
@@ -0,0 +1,297 @@
|
||||
use HexChat qw(:all);
|
||||
|
||||
use strict;
|
||||
use warnings "all";
|
||||
use Socket; # hexchat in windows does not ship proper memcache interface, so we will
|
||||
# use Socket module and memcache text protocol
|
||||
use Digest::MD5 qw(md5_base64);
|
||||
|
||||
sub hookfn;
|
||||
sub loadliststatus($);
|
||||
sub loadlist($);
|
||||
sub savelist(@);
|
||||
sub savesetting(@);
|
||||
sub freehooks;
|
||||
|
||||
my $script_name = "URL_Memcacher";
|
||||
HexChat::register($script_name, '0.3', 'Automatically stores URLs to Memcache', \&freehooks);
|
||||
|
||||
HexChat::print("$script_name loaded\n");
|
||||
my $help = 'Usage:
|
||||
/dl enable nick|domain <name> - enable nick or domain blacklist
|
||||
/dl disable nick|domain <name> - disable nick or domain blacklist
|
||||
/dl add nick|domain <name> - adds nick or domain to apropriate blacklist
|
||||
/dl del nick|domain <name> - removes nick or domain from apropriate blacklist
|
||||
/dl show - show blacklists
|
||||
/dl info - same as above
|
||||
';
|
||||
my @hooks;
|
||||
push @hooks, HexChat::hook_print('Channel Message', \&hookfn);
|
||||
push @hooks, HexChat::hook_print('Channel Msg Hilight', \&hookfn);
|
||||
push @hooks, HexChat::hook_print('Channel Action', \&hookfn);
|
||||
push @hooks, HexChat::hook_print('Channel Action Hilight', \&hookfn);
|
||||
push @hooks, HexChat::hook_command('dl', \&dl_cmd);
|
||||
|
||||
my $host="localhost";
|
||||
my $port="11211";
|
||||
|
||||
|
||||
sub hookfn {
|
||||
my ($nick, $text, $modechar) = @{$_[0]};
|
||||
my $nicklist = loadliststatus('dl_nicklist');
|
||||
|
||||
if ($nicklist != 0) {
|
||||
my @nicklist = loadlist('dl_nicks');
|
||||
|
||||
foreach (@nicklist) {
|
||||
next unless(defined($_));
|
||||
next if($_ eq '');
|
||||
|
||||
if ($_ eq $nick) {
|
||||
undef $nick; undef $text; undef $modechar;
|
||||
undef $nicklist;
|
||||
@nicklist = -1; undef @nicklist;
|
||||
return HexChat::EAT_NONE;
|
||||
}
|
||||
}
|
||||
|
||||
@nicklist = -1; undef @nicklist;
|
||||
}
|
||||
|
||||
undef $nicklist;
|
||||
|
||||
my @words = split(/\s+/, $text);
|
||||
|
||||
foreach (@words) {
|
||||
my $str = $_;
|
||||
next unless(substr($str, 0, 4) eq 'http');
|
||||
|
||||
if ($str =~ m{https?://([a-zA-Z0-9.-]+\.[a-zA-Z]+)/(?:.*)}) {
|
||||
my $domain = $1;
|
||||
my $domainlist = loadliststatus('dl_domainlist');
|
||||
|
||||
if ($domainlist != 0) {
|
||||
my @domainlist = loadlist('dl_domains');
|
||||
|
||||
foreach (@domainlist) {
|
||||
next unless(defined($_));
|
||||
next if($_ eq '');
|
||||
|
||||
if ($_ eq $domain) {
|
||||
undef $nick; undef $text; undef $modechar;
|
||||
@words = -1; undef @words;
|
||||
undef $str; undef $domain;
|
||||
undef $domainlist;
|
||||
@domainlist = -1; undef @domainlist;
|
||||
return HexChat::EAT_NONE;
|
||||
}
|
||||
}
|
||||
|
||||
@domainlist = -1, undef @domainlist;
|
||||
}
|
||||
|
||||
undef $domainlist;
|
||||
|
||||
if (socket(SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp'))) {
|
||||
my $iaddr = inet_aton($host);
|
||||
my $paddr = sockaddr_in($port, $iaddr);
|
||||
|
||||
if (connect(SOCK, $paddr)) {
|
||||
send (SOCK, sprintf("set %s 0 0 %s noreply\r\n%s\r\nquit\r\n", md5_base64($str), length($str), $str), 0);
|
||||
}
|
||||
|
||||
close(SOCK);
|
||||
undef $iaddr; undef $paddr;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@words = -1; undef @words;
|
||||
undef $nick; undef $text; undef $modechar;
|
||||
|
||||
return HexChat::EAT_NONE;
|
||||
}
|
||||
|
||||
sub loadliststatus($){
|
||||
my $listtype = shift;
|
||||
my $list = HexChat::plugin_pref_get($listtype);
|
||||
|
||||
unless (defined($list)) {
|
||||
savesetting('list', '0');
|
||||
$list = 0;
|
||||
}
|
||||
|
||||
undef $listtype;
|
||||
return $list;
|
||||
}
|
||||
|
||||
sub loadlist($){
|
||||
my $setting = shift;
|
||||
my $val = HexChat::plugin_pref_get($setting);
|
||||
|
||||
unless (defined($val)) {
|
||||
savesetting($setting, encode_base64('', ''));
|
||||
$val = '';
|
||||
}
|
||||
|
||||
my @values = map { decode_base64($_); } split(/ /, $val);
|
||||
undef $setting; undef $val;
|
||||
return @values;
|
||||
}
|
||||
|
||||
sub savelist(@) {
|
||||
my $setting = shift;
|
||||
my @list = map { encode_base64($_, ''); } @_;
|
||||
my $value = join(' ', @list);
|
||||
@list = -1; undef @list;
|
||||
return savesetting($setting, $value);
|
||||
}
|
||||
|
||||
sub savesetting(@) {
|
||||
my $setting = shift;
|
||||
my $value = shift;
|
||||
|
||||
if (HexChat::plugin_pref_set($setting, $value) == 0) {
|
||||
HexChat::printf("Unable to save settings for %s\n", $script_name);
|
||||
undef $setting; undef $value;
|
||||
return undef;
|
||||
}
|
||||
|
||||
undef $setting;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub dl_cmd {
|
||||
shift(@{$_[0]});
|
||||
my $cmd = shift(@{$_[0]});
|
||||
my $entity = shift(@{$_[0]});
|
||||
my $value = join(' ', @{$_[0]});
|
||||
HexChat::print("\n");
|
||||
my $msg = undef;
|
||||
|
||||
if (defined($cmd)) {
|
||||
if ($cmd eq 'enable') {
|
||||
if($entity eq 'nick') {
|
||||
if (defined(savesetting('dl_nicklist', '1'))) {
|
||||
$msg = "Nicks blacklist now enabled\n";
|
||||
}
|
||||
} elsif ($entity eq 'domain') {
|
||||
if (defined(savesetting('dl_domainlist', '1'))) {
|
||||
$msg = "Domains blacklist now enabled\n";
|
||||
}
|
||||
}
|
||||
} elsif ($cmd eq 'disable') {
|
||||
if($entity eq 'nick') {
|
||||
if (defined(savesetting('dl_nicklist', '0'))) {
|
||||
$msg = "Nicks blacklist now disabled\n";
|
||||
}
|
||||
} elsif ($entity eq 'domain') {
|
||||
if (defined(savesetting('dl_domainlist', '0'))) {
|
||||
$msg = "Domains blacklist now disabled\n";
|
||||
}
|
||||
}
|
||||
} elsif (($cmd eq 'show') or ($cmd eq 'info')) {
|
||||
$msg = '';
|
||||
|
||||
if (loadliststatus('dl_nicklist') == 0) {
|
||||
$msg .= "Nicks blacklist: disabled\n";
|
||||
} else {
|
||||
$msg .= "Nicks blacklist: enabled\n";
|
||||
}
|
||||
|
||||
$msg .= "Blacklisted nicks = " . join( ', ', loadlist('dl_nicks')) ."\n";
|
||||
|
||||
if (loadliststatus('dl_domainlist') == 0) {
|
||||
$msg .= "Domains blacklist: disabled\n";
|
||||
} else {
|
||||
$msg .= "Domains blacklist: enabled\n";
|
||||
}
|
||||
|
||||
$msg .= "Blacklisted domains = " . join( ', ', loadlist('dl_domains')) . "\n";
|
||||
} elsif ($cmd eq 'add') {
|
||||
if ((defined($entity)) and (defined($value))) {
|
||||
if ($entity eq 'nick') {
|
||||
my @nicks = (loadlist('dl_nicks'), $value);
|
||||
|
||||
unless (defined(savelist('dl_nicks', @nicks))) {
|
||||
undef $cmd; undef $entity; undef $value; undef $msg;
|
||||
@nicks = -1; undef @nicks;
|
||||
return HexChat::EAT_ALL;
|
||||
}
|
||||
|
||||
$msg = sprintf("Nicks blacklist now: %s\n", join(', ', @nicks));
|
||||
@nicks = -1; undef @nicks;
|
||||
} elsif ($entity eq 'domain') {
|
||||
my @domains = (loadlist('dl_domains'), $value);
|
||||
|
||||
unless (defined(savelist('dl_domains', @domains))) {
|
||||
undef $cmd; undef $entity; undef $value; undef $msg;
|
||||
@domains = -1; undef @domains;
|
||||
return HexChat::EAT_ALL;
|
||||
}
|
||||
|
||||
$msg = sprintf("Domains blacklist now: %s\n", join(', ', @domains));
|
||||
@domains = -1; undef @domains;
|
||||
}
|
||||
}
|
||||
} elsif ($cmd eq 'del') {
|
||||
if ((defined($entity)) and (defined($value))) {
|
||||
if ($entity eq 'nick') {
|
||||
my @list = loadlist('dl_nicks');
|
||||
my @nicklist;
|
||||
|
||||
foreach (@list) {
|
||||
next if ($_ eq $value);
|
||||
push @nicklist, $_;
|
||||
}
|
||||
|
||||
@list = -1; undef @list;
|
||||
|
||||
unless (defined(savelist('dl_nicks', @nicklist))) {
|
||||
undef $cmd; undef $entity; undef $value; undef $msg;
|
||||
@nicklist = -1; undef @nicklist;
|
||||
return HexChat::EAT_ALL;
|
||||
}
|
||||
|
||||
$msg = sprintf("Nicks blacklist now: %s\n", join(', ', @nicklist));
|
||||
@nicklist = -1; undef @nicklist;
|
||||
} elsif ($entity eq 'domain') {
|
||||
my @list = loadlist('dl_domains');
|
||||
my @domainlist;
|
||||
|
||||
foreach (@list) {
|
||||
next if ($_ eq $value);
|
||||
push @domainlist, $_;
|
||||
}
|
||||
|
||||
@list = -1; undef @list;
|
||||
|
||||
unless (defined(savelist('dl_domains', @domainlist))) {
|
||||
undef $cmd; undef $entity; undef $value; undef $msg;
|
||||
@domainlist = -1; undef @domainlist;
|
||||
return HexChat::EAT_ALL;
|
||||
}
|
||||
|
||||
$msg = sprintf("Domains blacklist now: %s\n", join(', ', @domainlist));
|
||||
@domainlist = -1; undef @domainlist;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
unless(defined($msg)) {
|
||||
HexChat::print($help);
|
||||
} else {
|
||||
HexChat::print($msg);
|
||||
}
|
||||
undef $cmd; undef $entity; undef $value; undef $msg;
|
||||
return HexChat::EAT_ALL;
|
||||
}
|
||||
|
||||
sub freehooks {
|
||||
foreach (@hooks) {
|
||||
HexChat::unhook($_);
|
||||
}
|
||||
|
||||
return HexChat::EAT_ALL;
|
||||
}
|
||||
4
web_link_saver/readme.md
Normal file
4
web_link_saver/readme.md
Normal file
@@ -0,0 +1,4 @@
|
||||
Plugins in unsafe dir relies on perl threads which are unsafe in Hexchat (well, at least until 2.12.4 including) because of general thread unsafeness of hexchat internal api. Scripts are working correctly and the only side-effect that occurs - notable memory leak. Looks like threads never release consumed memory.
|
||||
|
||||
As a workaround img_url_memc.pl uses external key-value database to store links. Sample image download client (img-save.pl) included to provide working solution.
|
||||
|
||||
Reference in New Issue
Block a user