]> git.vpit.fr Git - perl/scripts/xchat.git/blob - Xchat/XPI.pm
Add an ignore highlight filter
[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 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 = new __PACKAGE__, name   => 'Extended Xchat Perl Interface',
159                           desc   => 'Adds extended support for Perl scripts',
160                           author => 'Vincent Pit (VPIT)',
161                           email  => 'perl@profvince.com',
162                           url    => 'http://www.profvince.com';
163
164 1;