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