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