selfforum-cgi/shared/Id.pm

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