selfforum-cgi/shared/Id.pm

   1 package Id;
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        shared/Id.pm                                                    #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>, 2001-05-03                          #
   8 #                                                                              #
   9 # Description: compose an unique ID (in CGI context)                           #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw(
  15   @table
  16   @EXPORT
  17 );
  18
  19 ################################################################################
  20 #
  21 # Export
  22 #
  23 use base qw(Exporter);
  24 @EXPORT = qw(
  25   unique_id
  26   may_id
  27 );
  28
  29 ### sub unique_id () ###########################################################
  30 #
  31 # compose an unique ID
  32 #
  33 # Params: ~none~
  34 #
  35 # Return: Scalar: unique ID
  36 #
  37 sub unique_id () {
  38   my $id;
  39
  40   my $ip=$ENV{REMOTE_ADDR};
  41   my $time=time;
  42   my $port=$ENV{REMOTE_PORT};
  43   my $rand=int(rand(time));
  44
  45   # works only with IPv4! (will be changed later...)
  46   #
  47   $ip = hex(join ('',map {sprintf ('%02X',$_)} split (/\./,$ip)));
  48
  49   join '' => map {to_base64 ($_)} ($time, $port, $ip, $rand, $$);
  50 }
  51
  52 ### sub to_base64 ($) ##########################################################
  53 #
  54 # only converts (max.) 32-bit numbers into a system with base 64
  55 #
  56 # Params: $x - number to convert
  57 #
  58 # Return: converted number ;-)
  59 #
  60 sub to_base64 ($) {
  61   my $x = shift;
  62   my $y = $table[$x % 64];
  63
  64   $y = $table[$x % 64].$y while ($x = int ($x/64));
  65
  66   $y;
  67 }
  68
  69 BEGIN {
  70   # 64 'digits' (for our base 64 system)
  71   #
  72   @table = ('a'..'z','-','0'..'9','A'..'Z','_');
  73
  74   # define sub may_id
  75   #
  76   *may_id = eval join quotemeta join ('' => @table) => (
  77     q[sub {local $_=shift; defined and length and not y/],
  78     q[//cd;}]
  79   );
  80 }
  81
  82 # keep require happy
  83 1;
  84
  85 #
  86 #
  87 ### end of Id ##################################################################