Return to make_slots.pl CVS log

Up to [LON-CAPA] / loncom / debugging_tools

Annotation of loncom/debugging_tools/make_slots.pl, revision 1.1

1.1     ! albertel    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: }