Xchat/XPI.pm

   1 package Xchat::XPI;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Tie::RefHash;
   7
   8 use Xchat;
   9
  10 our $VERSION = '0.03';
  11
  12 use constant { COLOR_TAG => "\00307" };
  13
  14 sub new {
  15  my $class = shift;
  16  $class = ref($class) || $class || return;
  17  return if @_ % 2;
  18  my %opts = @_;
  19
  20  my $caller = (caller 0)[0];
  21  $opts{tag}     ||= ($caller =~ /([^:]*):*$/) ? $1 : 'UNKNOWN';
  22  $opts{name}    ||= $opts{tag};
  23  $opts{desc}    ||= $opts{name};
  24  $opts{version} ||= do { no strict 'refs'; ${$caller.'::VERSION'} }
  25                 || '0.01';
  26
  27  my $email = $opts{email};
  28  $email = '<' . $email . '>' if defined $email;
  29  my $desc = join ', ', grep defined, $opts{author}, $email, $opts{url};
  30  $desc = ' (' . $desc . ')' if length $desc;
  31  $opts{banner} = $opts{desc} . $desc;
  32
  33  my $ph = bless \do { local *PH }, $class;
  34  tie *$ph, $ph, @_;
  35
  36  *$ph->{$_}  = $opts{$_} for qw/tag name version desc author email url banner/;
  37  *$ph->{buf} = '';
  38
  39  Xchat::register(@opts{qw/name version banner/}, sub {
  40   $ph->flush;
  41   if (*$ph->{atexit_id}) {
  42    my @callbacks = sort { *$ph->{atexit}{$b} <=> *$ph->{atexit}{$a} }
  43                     keys %{*$ph->{atexit}};
  44    $_->($ph) for @callbacks;
  45   }
  46   undef $ph;
  47  });
  48  $ph->add_atexit($opts{unload}) if $opts{unload};
  49
  50  $ph->print("\002", $ph->name, ' v', $ph->version,
  51             " loaded\002 (", $ph->banner, ")\n");
  52
  53  return $ph;
  54 }
  55
  56 eval "sub $_ { *\$_[0]->{$_} }"
  57                           for qw/tag name version desc author email url banner/;
  58
  59 sub print {
  60  my $ph = shift;
  61  return unless $ph;
  62  my $ret  = 0;
  63  my $data = join '', *$ph->{buf},
  64                      grep defined,
  65                       (@_) ? @_ : ((defined) ? $_ : '');
  66  while ((my $i = index $data, "\n") >= 0) {
  67   Xchat::print(COLOR_TAG . $ph->tag . "\t" . (substr $data, 0, ($i + 1), ''));
  68   $ret = 1;
  69  }
  70  *$ph->{buf} = $data;
  71  return $ret;
  72 }
  73
  74 sub printf { shift->print(sprintf @_) }
  75
  76 sub flush {
  77  my ($ph) = @_;
  78  return unless $ph;
  79  $ph->print("\n") if length $ph->{buf};
  80 }
  81
  82 sub add_atexit {
  83  my ($ph, $callback) = @_;
  84  return unless $ph && $callback && ref $callback eq 'CODE';
  85  if (!*$ph->{atexit_id}) {
  86   tie my %h, 'Tie::RefHash';
  87   *$ph->{atexit} = \%h;
  88  }
  89  return *$ph->{atexit}{$callback} = ++*$ph->{atexit_id};
  90 }
  91
  92 sub remove_atexit {
  93  my ($ph, $callback) = @_;
  94  return unless $ph && $callback;
  95  if (exists *$ph->{atexit}{$callback}) {
  96   delete *$ph->{atexit}{$callback};
  97   return 1;
  98  }
  99  return 0;
 100 }
 101
 102 sub TIEHANDLE {
 103  my $ph = shift;
 104  ((defined $ph && $ph->isa(__PACKAGE__))
 105   ? $ph
 106   : shift->new(@_));
 107 }
 108
 109 sub PRINT { shift->print(@_) }
 110
 111 sub PRINTF { shift->printf(@_) }
 112
 113 my $ph = __PACKAGE__->new(
 114  name   => 'Extended Xchat Perl Interface',
 115  desc   => 'Adds extended support for Perl scripts',
 116  author => 'Vincent Pit (VPIT)',
 117  email  => 'perl@profvince.com',
 118  url    => 'http://www.profvince.com',
 119 );
 120
 121 1;