lib/Onis/Users.pm

   1 package Onis::Users;
   2
   3 use strict;
   4 use warnings;
   5 use Exporter;
   6 use Onis::Config (qw(get_config));
   7 use Onis::Data::Persistent ();
   8
   9 @Onis::Users::EXPORT_OK =
  10 (qw(
  11         ident_to_name chatter_to_name name_to_ident
  12         get_realname get_link get_image
  13 ));
  14 @Onis::Users::ISA = ('Exporter');
  15
  16 =head1 NAME
  17
  18 Onis::Users - Management of configures users, so called "names".
  19
  20 =head1 DESCRIPTION
  21
  22 Parses user-info and provides query-routines. The definition of "name" can be found in L<Onis::Data::Core>.
  23
  24 =head1 USAGE
  25
  26     use Onis::Users qw#ident_to_name chatter_to_name get_realname get_link get_image#;
  27
  28     # Functions to query the name
  29     $name = ident_to_name ($ident);
  30     $name = chatter_to_name ($chatter);
  31
  32     # Functions to query a name's properties
  33     my $realname  = get_realname ($name);
  34     my $link      = get_link     ($name);
  35     my $image     = get_image    ($name);
  36
  37 =head1 DIAGNOSTIGS
  38
  39 Set $::DEBUG to ``0x1000'' to get extra debug messages.
  40
  41 =cut
  42
  43 our $Users = {};
  44 our $IdentToName = {};
  45 our $NameToIdent = {};
  46
  47
  48 my $VERSION = '$Id: Users.pm,v 1.2 2004/08/01 13:45:27 octo Exp $';
  49 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  50
  51 read_config ();
  52
  53 return (1);
  54
  55 sub read_config
  56 {
  57         my $config_file = 'users.conf';
  58         my $content;
  59         my $fh;
  60
  61         if (get_config ('users_config'))
  62         {
  63                 my $temp = get_config ('users_config');
  64                 if (-e $temp and -r $temp)
  65                 {
  66                         $config_file = $temp;
  67                 }
  68                 elsif (-e $temp)
  69                 {
  70                         print STDERR $/, __FILE__, ": Unable to read users_config ``$temp'': ",
  71                                 "File not readable. Check your permissions.";
  72                 }
  73                 else
  74                 {
  75                         print STDERR $/, __FILE__, ": Unable to read users_config ``$temp'': ",
  76                                 "File does not exist.";
  77                 }
  78         }
  79
  80         # Fail silently, if fle does not exist..
  81         if (!-e $config_file) { return (0); }
  82
  83         print STDERR $/, __FILE__, ": Reading config file ``$config_file''" if ($::DEBUG & 0x1000);
  84
  85         # read the file
  86         unless (open ($fh, "< $config_file"))
  87         {
  88                 print STDERR $/, __FILE__, ": Unable to open ``$config_file'' for reading: $!";
  89                 return (0);
  90         }
  91
  92         {
  93                 local ($/) = undef;
  94                 $content = <$fh>;
  95         }
  96
  97         close ($fh);
  98
  99         # parse the file
 100         #$content =~ s/[\n\r\s]+//gs;
 101         $content =~ s/#.*$//gm;
 102         $content =~ s/[\n\r]+//gs;
 103
 104         #while ($content =~ m/([^{]+){([^}]+)}/g)
 105         while ($content =~ m/([^\s{]+)\s*{([^}]+)}/g)
 106         {
 107                 my $user = $1;
 108                 my $line = $2;
 109
 110                 print STDERR $/, __FILE__, ": User ``$user''" if ($::DEBUG & 0x1000);
 111
 112                 while ($line =~ m/([^\s:]+)\s*:([^;]+);/g)
 113                 {
 114                         my $key = lc ($1);
 115                         my $val = $2;
 116                         $val =~ s/^\s+|\s+$//g;
 117
 118                         print STDERR $/, __FILE__, ": + $key = ``$val''" if ($::DEBUG & 0x1000);
 119
 120                         if (($key eq 'image') or ($key eq 'link')
 121                                         or ($key eq 'name'))
 122                         {
 123                                 if (!defined ($Users->{$user}{$key}))
 124                                 {
 125                                         $Users->{$user}{$key} = [];
 126                                 }
 127                                 push (@{$Users->{$user}{$key}}, $val);
 128                         }
 129                         elsif (($key eq 'host') or ($key eq 'hostmask'))
 130                         {
 131                                 my $this_nick;
 132                                 my $this_user;
 133                                 my $this_host;
 134
 135                                 if ($val =~ m/^([^!]+)!([^@]+)@(.+)$/)
 136                                 {
 137                                         $this_nick = quotemeta (lc ($1));
 138                                         $this_user = quotemeta (lc ($2));
 139                                         $this_host = quotemeta (lc ($3));
 140                                 }
 141                                 else
 142                                 {
 143                                         print STDERR $/, __FILE__, ": Invalid hostmask for user $user: ``$val''";
 144                                         next;
 145                                 }
 146
 147                                 $this_nick =~ s/\\\*/[^!]*/g;
 148                                 $this_nick =~ s/\\\?/[^!]/g;
 149
 150                                 $this_user =~ s/\\\*/[^@]*/g;
 151                                 $this_user =~ s/\\\?/[^@]/g;
 152
 153                                 $this_host =~ s/\\\*/.*/g;
 154                                 $this_host =~ s/\\\?/./g;
 155
 156                                 $val = "$this_nick!$this_user\@$this_host";
 157
 158                                 if (!defined ($Users->{$user}{'host'}))
 159                                 {
 160                                         $Users->{$user}{'host'} = [];
 161                                 }
 162
 163                                 print STDERR " --> m/^$val\$/i" if ($::DEBUG & 0x1000);
 164
 165                                 push (@{$Users->{$user}{'host'}}, qr/^$val$/i);
 166                         }
 167                         else
 168                         {
 169                                 print STDERR $/, __FILE__, ": Invalid key in users_config: ``$key''";
 170                         }
 171                 }
 172
 173                 if (!defined ($Users->{$user}{'host'}))
 174                 {
 175                         print STDERR $/, __FILE__, ": No hostmask given for user $user. Ignoring him/her.";
 176                         delete ($Users->{$user});
 177                 }
 178         }
 179
 180         return (1);
 181 }
 182
 183 =head1 EXPORTED FUNCTIONS
 184
 185 =over 4
 186
 187 =item B<ident_to_name> (I<$ident>)
 188
 189 Matches the ident against the configured hostmasks. Uses caching to
 190 speed up execution. Returns the name or an empty string if not found.
 191
 192 =cut
 193
 194 sub ident_to_name
 195 {
 196         my $ident = shift;
 197         my $name = '';
 198
 199         if (defined ($IdentToName->{$ident}))
 200         {
 201                 $name = $IdentToName->{$ident};
 202         }
 203         else
 204         {
 205                 USER: for (keys (%$Users))
 206                 {
 207                         my $this_name = $_;
 208                         for (@{$Users->{$this_name}{'host'}})
 209                         {
 210                                 my $host_re = $_;
 211
 212                                 if ($ident =~ $host_re)
 213                                 {
 214                                         $name = $this_name;
 215                                         last (USER);
 216                                 }
 217                         }
 218                 }
 219
 220                 if (($::DEBUG & 0x1000) and $name)
 221                 {
 222                         print STDERR $/, __FILE__, ": Host ``$ident'' belongs to ``$name''";
 223                 }
 224         }
 225
 226         $IdentToName->{$ident} = $name;
 227         $NameToIdent->{$name} = $ident if ($name);
 228         return ($name);
 229 }
 230
 231 =item B<chatter_to_name> (I<$chatter>)
 232
 233 Passes the ident-part of I<$chatter> to B<ident_to_name>.
 234
 235 =cut
 236
 237 sub chatter_to_name
 238 {
 239         my $chatter = shift;
 240         my ($nick, $ident) = split (m/!/, $chatter);
 241
 242         return (ident_to_name ($ident));
 243 }
 244
 245 =item B<name_to_ident> (I<$name>)
 246
 247 Does the reverse of B<ident_to_name>: Returns the most recent association of
 248 I<$name> to an ident. This function should rarely be needed..
 249
 250 =cut
 251
 252 sub name_to_ident
 253 {
 254         my $name = shift;
 255
 256         if (defined ($NameToIdent->{$name}))
 257         {
 258                 return ($NameToIdent->{$name});
 259         }
 260         else
 261         {
 262                 return ('');
 263         }
 264 }
 265
 266 =item B<get_realname> (I<$name>)
 267
 268 Returns the B<real name> for this (user)name as defined in the config. Sorry
 269 for the confusing terms.
 270
 271 =cut
 272
 273 sub get_realname
 274 {
 275         my $name = shift;
 276         my $retval = '';
 277
 278         if (defined ($Users->{$name}{'name'}))
 279         {
 280                 my $tmp = int (rand (scalar (@{$Users->{$name}{'name'}})));
 281                 $retval = $Users->{$name}{'name'}[$tmp];
 282         }
 283
 284         return ($retval);
 285 }
 286
 287 =item B<get_link> (I<$name>)
 288
 289 Returns the URL defined for this name in the config.
 290
 291 =cut
 292
 293 sub get_link
 294 {
 295         my $name = shift;
 296         my $retval = '';
 297
 298         if (defined ($Users->{$name}{'link'}))
 299         {
 300                 my $tmp = int (rand (scalar (@{$Users->{$name}{'link'}})));
 301                 $retval = $Users->{$name}{'link'}[$tmp];
 302         }
 303
 304         return ($retval);
 305 }
 306
 307 =item B<get_image> (I<$name>)
 308
 309 Returns the URL of the (user)name's image, if one is configured.
 310
 311 =cut
 312
 313 sub get_image
 314 {
 315         my $name = shift;
 316         my $retval = '';
 317
 318         if (defined ($Users->{$name}{'image'}))
 319         {
 320                 my $tmp = int (rand (scalar (@{$Users->{$name}{'image'}})));
 321                 $retval = $Users->{$name}{'image'}[$tmp];
 322         }
 323
 324         return ($retval);
 325 }
 326
 327 =back
 328
 329 =head1 AUTHOR
 330
 331 Florian octo Forster E<lt>octo at verplant.orgE<gt>