]> git.vpit.fr Git - perl/scripts/xchat.git/blob - Xchat/XPI.pm
Autogenerate accessors
[perl/scripts/xchat.git] / 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;