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 sub tag {
  57  my $ph = shift;
  58  return unless $ph;
  59  return *$ph->{tag};
  60 }
  61
  62 sub name {
  63  my $ph = shift;
  64  return unless $ph;
  65  return *$ph->{name};
  66 }
  67
  68 sub version {
  69  my $ph = shift;
  70  return unless $ph;
  71  return *$ph->{version};
  72 }
  73
  74 sub desc {
  75  my $ph = shift;
  76  return unless $ph;
  77  return *$ph->{desc};
  78 }
  79
  80 sub author {
  81  my $ph = shift;
  82  return unless $ph;
  83  return *$ph->{author};
  84 }
  85
  86 sub email {
  87  my $ph = shift;
  88  return unless $ph;
  89  return *$ph->{email};
  90 }
  91
  92 sub url {
  93  my $ph = shift;
  94  return unless $ph;
  95  return *$ph->{url};
  96 }
  97
  98 sub banner {
  99  my $ph = shift;
 100  return unless $ph;
 101  return *$ph->{banner};
 102 }
 103
 104 sub print {
 105  my $ph = shift;
 106  return unless $ph;
 107  my $ret  = 0;
 108  my $data = join '', *$ph->{buf},
 109                      grep defined,
 110                       (@_) ? @_ : ((defined) ? $_ : '');
 111  while ((my $i = index $data, "\n") >= 0) {
 112   Xchat::print(COLOR_TAG . $ph->tag . "\t" . (substr $data, 0, ($i + 1), ''));
 113   $ret = 1;
 114  }
 115  *$ph->{buf} = $data;
 116  return $ret;
 117 }
 118
 119 sub printf { shift->print(sprintf @_) }
 120
 121 sub flush {
 122  my ($ph) = @_;
 123  return unless $ph;
 124  $ph->print("\n") if length $ph->{buf};
 125 }
 126
 127 sub add_atexit {
 128  my ($ph, $callback) = @_;
 129  return unless $ph && $callback && ref $callback eq 'CODE';
 130  if (!*$ph->{atexit_id}) {
 131   tie my %h, 'Tie::RefHash';
 132   *$ph->{atexit} = \%h;
 133  }
 134  return *$ph->{atexit}{$callback} = ++*$ph->{atexit_id};
 135 }
 136
 137 sub remove_atexit {
 138  my ($ph, $callback) = @_;
 139  return unless $ph && $callback;
 140  if (exists *$ph->{atexit}{$callback}) {
 141   delete *$ph->{atexit}{$callback};
 142   return 1;
 143  }
 144  return 0;
 145 }
 146
 147 sub TIEHANDLE {
 148  my $ph = shift;
 149  ((defined $ph && $ph->isa(__PACKAGE__))
 150   ? $ph
 151   : shift->new(@_));
 152 }
 153
 154 sub PRINT { shift->print(@_) }
 155
 156 sub PRINTF { shift->printf(@_) }
 157
 158 my $ph = __PACKAGE__->new(
 159  name   => 'Extended Xchat Perl Interface',
 160  desc   => 'Adds extended support for Perl scripts',
 161  author => 'Vincent Pit (VPIT)',
 162  email  => 'perl@profvince.com',
 163  url    => 'http://www.profvince.com',
 164 );
 165
 166 1;