filter-img-hrefs.pl

   1 #                                MIT License
   2 #
   3 #   Copyright (c) 2009 Matej Cepl <mcepl () redhat ! com>
   4 #
   5 #   Permission is hereby granted, free of charge, to any person obtaining
   6 #   a copy of this software and associated documentation files (the
   7 #   "Software"), to deal in the Software without restriction, including
   8 #   without limitation the rights to use, copy, modify, merge, publish,
   9 #   distribute, sublicense, and/or sell copies of the Software, and to
  10 #   permit persons to whom the Software is furnished to do so, subject to
  11 #   the following conditions:
  12 #
  13 #   The above copyright notice and this permission notice shall be
  14 #   included in all copies or substantial portions of the Software.
  15 #
  16 #   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  17 #   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  18 #   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  19 #   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  20 #   CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  21 #   TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  22 #   SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  23 use Purple;
  24
  25 use strict;
  26 use warnings;
  27
  28 my $pluginName = "filter-img-hrefs";
  29 my $plugin = "";
  30
  31 our %PLUGIN_INFO = (
  32     perl_api_version => 2,
  33     name => "Perl: Filter out HREFs from IMG elements",
  34     version => "0.1",
  35     summary => "There are annoyingly long HREFs shown in twitter chat, this plugin wants to get rid of them.",
  36     description => "There are annoyingly long HREFs shown in twitter chat, this plugin wants to get rid of themOpens all chats on XMPP server according to bookmarks stored there.",
  37     author => "Matěj Cepl <mcepl () redhat ! com>",
  38     url => "http://matej.ceplovi.cz",
  39     load => "plugin_load",
  40     unload => "plugin_unload",
  41 );
  42
  43 # list of outstanding IDs for <iq>s we are waiting to get answer
  44 my @requests_queue = ();
  45 my @target_JIDs = qw( twitter.jabbim.com );
  46
  47 my @connected_signals = ();
  48
  49 sub plugin_load {
  50         $plugin = shift;
  51
  52         Purple::Debug::info("$pluginName",
  53                                                           "$pluginName plugin loaded\n");
  54
  55         my $jabber = Purple::Find::prpl("prpl-jabber");
  56         if (!$jabber) {
  57         Purple::Debug::info("$pluginName",
  58                                                           "Works only for Jabber protocol.\n");
  59                 return ;
  60         }
  61         my $consignal = Purple::Signal::connect($jabber,
  62                 "jabber-receiving-message",$plugin,\&got_message_cb, 0);
  63         push @connected_signals,$consignal;
  64 }
  65
  66 sub plugin_unload {
  67         foreach my $signal (@connected_signals) {
  68                 Purple::Prefs::disconnect_by_handle($signal);
  69         }
  70         Purple::Debug::info("$pluginName",
  71                                                           "$pluginName plugin unloaded\n");
  72 }
  73
  74 # (18:08:28) darkrain42: mcepl: With that patch, $node->get_child("")
  75 # followed by iterative "$node = $node->get_next()" should work as you'd expect.
  76
  77 sub clear_img {
  78     my $curnode = shift ;
  79     my $curname = $curnode->get_name();
  80
  81     Purple::Debug::misc("$pluginName",
  82      "clear_img: current node name is "
  83       . $curname . "\n");
  84
  85     if ($curname eq "img") {
  86         $curnode->free();
  87                   return ;
  88          }
  89
  90          # doesn't work in perl ... it would be curnode->child in C
  91     my $curchild = $curnode->get_child("");
  92          while ($curchild) {
  93                   clear_img($curchild);
  94                   $curchild = $curchild->get_next();
  95          }
  96 }
  97
  98 sub got_message_cb {
  99         my $conn = shift;     # connection
 100         my $msg_type = shift || ""; # what type of IQ is this?
 101         my $msg_id = shift || "";   # what's the ID of the incoming IQ?
 102    my $msg_from = shift || ""; # who is the IQ from?
 103    my $msg_to = shift || "";   # who is the IQ to?
 104    my $packet = shift || "";   # xmlnode
 105         Purple::Debug::misc("$pluginName",
 106           "Msg received: \$msg_type = $msg_type, \$msg_id = $msg_id," .
 107      " \$msg_from = $msg_from, \$msg_to\n\$packet = $packet\n");
 108
 109         if (grep ( $msg_from =~ /$_/ ,  @target_JIDs )) {
 110
 111                  my $len = 0; # length of the string generated from XMLNodemv
 112                  my $packetstr = $packet->to_str();
 113                  Purple::Debug::info("$pluginName", "packet: $packetstr\n");
 114                  clear_img($packet);
 115                  $packetstr = $packet->to_str();
 116                  Purple::Debug::info("$pluginName", "new packet: $packetstr\n");
 117         }
 118 }