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   $VERSION
  18 );
  19
  20 ################################################################################
  21 #
  22 # Version check
  23 #
  24 $VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
  25
  26 ################################################################################
  27 #
  28 # Export
  29 #
  30 use base qw(Exporter);
  31 @EXPORT = qw(
  32   unique_id
  33   may_id
  34 );
  35
  36 ### sub unique_id () ###########################################################
  37 #
  38 # compose an unique ID
  39 #
  40 # Params: ~none~
  41 #
  42 # Return: Scalar: unique ID
  43 #
  44 sub unique_id () {
  45   my $id;
  46
  47   my $ip=$ENV{REMOTE_ADDR};
  48   my $time=time;
  49   my $port=$ENV{REMOTE_PORT};
  50   my $rand=int(rand(time));
  51
  52   # works only with IPv4! (will be changed later...)
  53   #
  54   $ip = hex(join ('',map {sprintf ('%02X',$_)} split (/\./,$ip)));
  55
  56   join '' => map {to_base64 ($_)} ($time, $port, $ip, $rand, $$);
  57 }
  58
  59 ### sub to_base64 ($) ##########################################################
  60 #
  61 # only converts (max.) 32-bit numbers into a system with base 64
  62 #
  63 # Params: $x - number to convert
  64 #
  65 # Return: converted number ;-)
  66 #
  67 sub to_base64 ($) {
  68   my $x = shift;
  69   return '' unless defined $x;
  70
  71   my $y = $table[$x % 64];
  72
  73   $y = $table[$x % 64].$y while ($x = int ($x/64));
  74
  75   $y;
  76 }
  77
  78 BEGIN {
  79   # 64 'digits' (for our base 64 system)
  80   #
  81   @table = ('a'..'z','-','0'..'9','A'..'Z','_');
  82
  83   # define sub may_id
  84   #
  85   *may_id = eval join quotemeta join ('' => @table) => (
  86     q[sub {local $_=shift; defined and length and not y/],
  87     q[//cd;}]
  88   );
  89 }
  90
  91 # keep 'require' happy
  92 1;
  93
  94 #
  95 #
  96 ### end of Id ##################################################################