Xchat/XPI/Utils.pm

   1 package Xchat::XPI::Utils;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Xchat qw<:all>;
   7
   8 our $VERSION = '0.02';
   9
  10 my @rcolors;
  11 BEGIN {
  12  if (nickcmp(get_info('version'), '2.4.0') < 0) {
  13   @rcolors = (3, 4, 6, 8, 9, 10, 11, 12, 13);
  14  } else {
  15   @rcolors = (19, 20, 22, 24, 25, 26, 27, 28, 29);
  16  }
  17 }
  18
  19 sub dye_nick {
  20  my $nick = $_[0];
  21  my $col  = 0;
  22  $col    += ord for split //, $nick;
  23  return sprintf "\003%d%s", $rcolors[$col % @rcolors], $nick;
  24 }
  25
  26 my %gui_commands = (
  27  'clear'     => [ 'COLOR 0' ],
  28  'highlight' => [ 'FLASH' => 'COLOR 3' ],
  29 );
  30
  31 sub gui {
  32  my $commands = $gui_commands{$_[0] || 'nope'};
  33  die 'Invalid command' unless defined $commands;
  34  command "GUI $_" for @$commands;
  35 }
  36
  37 sub save_context {
  38  my $cur_cxt = get_context;
  39  bless \$cur_cxt, 'Xchat::XPI::Utils::ContextGuard';
  40 }
  41
  42 sub local_context {
  43  return unless @_ >= 2;
  44  my $code    = pop;
  45  my $new_cxt = (@_ == 1) ? $_[0] : find_context(@_);
  46  my $cur_cxt = get_context;
  47  if (set_context $new_cxt) {
  48   my $guard = bless \$cur_cxt, 'Xchat::XPI::Utils::ContextGuard';
  49   return $code->();
  50  } else {
  51   return undef;
  52  }
  53 }
  54
  55 sub Xchat::XPI::Utils::ContextGuard::DESTROY {
  56  set_context ${$_[0]};
  57 }
  58
  59 sub called_from_script (&) {
  60  my $code  = shift;
  61  my $level = 0;
  62  my ($package, $filename);
  63  while (1) {
  64   my @frame = caller $level;
  65   last unless @frame;
  66   if ($frame[0] !~ /^(?:Xchat|HexChat)::XPI\b/) {
  67    ($package, $filename) = @frame[0, 1];
  68    last;
  69   }
  70   ++$level;
  71  }
  72  if (defined $filename) {
  73   my $internal_package = Xchat::Embed::file2pkg($filename);
  74   my $mock = sub { $internal_package, $package };
  75   no warnings 'redefine';
  76   local *Xchat::Embed::find_pkg   = $mock;
  77   local *HexChat::Embed::find_pkg = $mock;
  78   $code->();
  79  }
  80 }
  81
  82 use base qw<Exporter>;
  83
  84 our @EXPORT         = ();
  85 our %EXPORT_TAGS    = ('funcs' => [ qw<
  86  dye_nick
  87  gui
  88  save_context local_context
  89  called_from_script
  90 > ]);
  91 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
  92 $EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
  93
  94 1;