Return to make_slots.pl CVS log

Up to [LON-CAPA] / loncom / debugging_tools

- implement dslot getting and checking

    1: use Date::Manip;
    2: use GDBM_File;
    3: use Storable qw(nfreeze thaw);
    4: 
    5: my $fname="/home/httpd/lonUsers/annarbor/9/7/7/9778182de3942c1annarborl2/slots.db";
    6: my %db;
    7: if (! tie(%db,'GDBM_File',$fname,&GDBM_WRITER(),0640)) {
    8:     warn "Unable to tie to $fname";
    9:     exit;
   10: }
   11: $db{'slot1'}=
   12:     &freeze_escape({
   13: 	'starttime' => &UnixDate("Aug 30th 00:00:00 2004","%s"),
   14: 	'endtime'   => &UnixDate("Aug 30th 01:00:00 2004","%s"),
   15: 	'ip'        => "*albertelli.com",
   16:     });
   17: $db{'slot2'}=
   18:     &freeze_escape({
   19: 	'starttime' => &UnixDate("Aug 30th 00:00:00 2006","%s"),
   20: 	'endtime'   => &UnixDate("Aug 30th 00:00:00 2006","%s"),
   21: 	'ip'        => "*albertelli.com",
   22:     });
   23: $db{'slot3'}=
   24:     &freeze_escape({
   25: 	'starttime' => &UnixDate("Aug 30th 00:00:00 2004","%s"),
   26: 	'endtime'   => &UnixDate("Aug 30th 00:00:00 2006","%s"),
   27: 	'ip'        => "1.2.3.4",
   28:     });
   29: $db{'slot4'}=
   30:     &freeze_escape({
   31: 	'starttime' => &UnixDate("Aug 30th 00:00:00 2004","%s"),
   32: 	'endtime'   => &UnixDate("Aug 30th 00:00:00 2006","%s"),
   33: 	'ip'        => "*albertelli.com",
   34:     });
   35: 
   36: sub freeze_escape {
   37:     my ($value)=@_;
   38:     if (ref($value)) {
   39: 	$value=&nfreeze($value);
   40: 	return '__FROZEN__'.&escape($value);
   41:     }
   42:     return &escape($value);
   43: }
   44: 
   45: sub escape {
   46:     my $str=shift;
   47:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
   48:     return $str;
   49: }
   50: 
   51: sub thaw_unescape {
   52:     my ($value)=@_;
   53:     if ($value =~ /^__FROZEN__/) {
   54: 	substr($value,0,10,undef);
   55: 	$value=&unescape($value);
   56: 	return &thaw($value);
   57:     }
   58:     return &unescape($value);
   59: }
   60: 
   61: sub unescape {
   62:     my $str=shift;
   63:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
   64:     return $str;
   65: }