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