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