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$';
  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<ident_to_name> (I<$ident>)
 200
 201 Matches the ident against the configured hostmasks. Uses caching to
 202 speed up execution. Returns the name or an empty string if not found.
 203
 204 =cut
 205
 206 sub ident_to_name
 207 {
 208         my $ident = shift;
 209         my $name = '';
 210
 211         if (defined ($IdentToName->{$ident}))
 212         {
 213                 $name = $IdentToName->{$ident};
 214         }
 215         else
 216         {
 217                 USER: for (keys (%$Users))
 218                 {
 219                         my $this_name = $_;
 220                         for (@{$Users->{$this_name}{'host'}})
 221                         {
 222                                 my $host_re = $_;
 223
 224                                 if ($ident =~ $host_re)
 225                                 {
 226                                         $name = $this_name;
 227                                         last (USER);
 228                                 }
 229                         }
 230                 }
 231
 232                 if (($::DEBUG & 0x1000) and $name)
 233                 {
 234                         print STDERR $/, __FILE__, ": Host ``$ident'' belongs to ``$name''";
 235                 }
 236         }
 237
 238         $IdentToName->{$ident} = $name;
 239         $NameToIdent->{$name} = $ident if ($name);
 240         return ($name);
 241 }
 242
 243 =item B<chatter_to_name> (I<$chatter>)
 244
 245 Passes the ident-part of I<$chatter> to B<ident_to_name>.
 246
 247 =cut
 248
 249 sub chatter_to_name
 250 {
 251         my $chatter = shift;
 252         my ($nick, $ident) = split (m/!/, $chatter);
 253
 254         return (ident_to_name ($ident));
 255 }
 256
 257 =item B<name_to_ident> (I<$name>)
 258
 259 Does the reverse of B<ident_to_name>: Returns the most recent association of
 260 I<$name> to an ident. This function should rarely be needed..
 261
 262 =cut
 263
 264 sub name_to_ident
 265 {
 266         my $name = shift;
 267
 268         if (defined ($NameToIdent->{$name}))
 269         {
 270                 return ($NameToIdent->{$name});
 271         }
 272         else
 273         {
 274                 return ('');
 275         }
 276 }
 277
 278 =item B<get_realname> (I<$name>)
 279
 280 Returns the B<real name> for this (user)name as defined in the config. Sorry
 281 for the confusing terms.
 282
 283 =cut
 284
 285 sub get_realname
 286 {
 287         my $name = shift;
 288         my $retval = '';
 289
 290         if (defined ($Users->{$name}{'name'}))
 291         {
 292                 my $tmp = int (rand (scalar (@{$Users->{$name}{'name'}})));
 293                 $retval = $Users->{$name}{'name'}[$tmp];
 294         }
 295
 296         return ($retval);
 297 }
 298
 299 =item B<get_link> (I<$name>)
 300
 301 Returns the URL defined for this name in the config.
 302
 303 =cut
 304
 305 sub get_link
 306 {
 307         my $name = shift;
 308         my $retval = '';
 309
 310         if (defined ($Users->{$name}{'link'}))
 311         {
 312                 my $tmp = int (rand (scalar (@{$Users->{$name}{'link'}})));
 313                 $retval = $Users->{$name}{'link'}[$tmp];
 314         }
 315
 316         return ($retval);
 317 }
 318
 319 =item B<get_image> (I<$name>)
 320
 321 Returns the URL of the (user)name's image, if one is configured.
 322
 323 =cut
 324
 325 sub get_image
 326 {
 327         my $name = shift;
 328         my $retval = '';
 329
 330         if (defined ($Users->{$name}{'image'}))
 331         {
 332                 my $tmp = int (rand (scalar (@{$Users->{$name}{'image'}})));
 333                 $retval = $Users->{$name}{'image'}[$tmp];
 334         }
 335
 336         return ($retval);
 337 }
 338
 339 =back
 340
 341 =head1 AUTHOR
 342
 343 Florian octo Forster E<lt>octo at verplant.orgE<gt>