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