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