[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.100 and 1.105

version 1.100, 2002/09/30 21:38:18 version 1.105, 2003/01/13 21:52:11
Line 340  sub status { Line 340  sub status {
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     $status=$local.': '.$what;      $status=$local.': '.$what;
       $0='lond: '.$what.' '.$local;
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
Line 720  sub make_new_child { Line 721  sub make_new_child {
       }        }
       }        }
                           } elsif ($howpwd eq 'krb4') {                            } elsif ($howpwd eq 'krb4') {
                              $null=pack("C",0);                                $null=pack("C",0);
      unless ($upass=~/$null/) {                                unless ($upass=~/$null/) {
                               $pwdcorrect=(                                    my $krb4_error = &Authen::Krb4::get_pw_in_tkt
                                  Authen::Krb4::get_pw_in_tkt($uname,"",                                        ($uname,"",$contentpwd,'krbtgt',
                                         $contentpwd,'krbtgt',$contentpwd,1,                                         $contentpwd,1,$upass);
      $upass) == 0);                                    if (!$krb4_error) {
      } else { $pwdcorrect=0; }                                        $pwdcorrect = 1;
                                     } else { 
                                         $pwdcorrect=0; 
                                         # log error if it is not a bad password
                                         if ($krb4_error != 62) {
          &logthis('krb4:'.$uname.','.$contentpwd.','.
                   &Authen::Krb4::get_err_txt($Authen::Krb4::error));
                                         }
                                     }
                                 }
                           } elsif ($howpwd eq 'krb5') {                            } elsif ($howpwd eq 'krb5') {
       $null=pack("C",0);        $null=pack("C",0);
       unless ($upass=~/$null/) {        unless ($upass=~/$null/) {
Line 1015  sub make_new_child { Line 1025  sub make_new_child {
 # ------------------------------------------------------------------- subscribe  # ------------------------------------------------------------------- subscribe
                    } elsif ($userinput =~ /^sub/) {                     } elsif ($userinput =~ /^sub/) {
        print $client &subscribe($userinput,$clientip);         print $client &subscribe($userinput,$clientip);
   # ------------------------------------------------------------- current version
                      } elsif ($userinput =~ /^currentversion/) {
                          my ($cmd,$fname)=split(/:/,$userinput);
          print $client &currentversion($fname)."\n";
 # ------------------------------------------------------------------------- log  # ------------------------------------------------------------------------- log
                    } elsif ($userinput =~ /^log/) {                     } elsif ($userinput =~ /^log/) {
                        my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);                         my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
Line 1213  sub make_new_child { Line 1227  sub make_new_child {
                        } else {                         } else {
                            print $client "error:$!\n";                             print $client "error:$!\n";
                        }                         }
   # ----------------------------------------------------------------- dumpcurrent
                      } elsif ($userinput =~ /^dumpcurrent/) {
                          my ($cmd,$udom,$uname,$namespace)
                             =split(/:/,$userinput);
                          $namespace=~s/\//\_/g;
                          $namespace=~s/\W//g;
                          my $qresult='';
                          my $proname=propath($udom,$uname);
                          if (tie(%hash,'GDBM_File',
                                  "$proname/$namespace.db",
                                  &GDBM_READER(),0640)) {
                              # Structure of %data:
                              # $data{$symb}->{$parameter}=$value;
                              # $data{$symb}->{'v.'.$parameter}=$version;
                              # since $parameter will be unescaped, we do not
                              # have to worry about silly parameter names...
                              my %data = ();
                              while (my ($key,$value) = each(%hash)) {
                                 my ($v,$symb,$param) = split(/:/,$key);
                                 next if ($v eq 'version' || $symb eq 'keys');
                                 next if (exists($data{$symb}) && 
                                          exists($data{$symb}->{$param}) &&
                                          $data{$symb}->{'v.'.$param} > $v);
                                 #&logthis("v = ".$v." p = ".$param." s = ".$symb);
                                 $data{$symb}->{$param}=$value;
                                 $data{$symb}->{'v.'.$param}=$value;
                              }
                              if (untie(%hash)) {
                                while (my ($symb,$param_hash) = each(%data)) {
                                  while(my ($param,$value) = each (%$param_hash)){
                                    next if ($param =~ /^v\./);
                                    $qresult.=$symb.':'.$param.'='.$value.'&';
                                  }
                                }
                                chop($qresult);
                                print $client "$qresult\n";
                              } else {
                                print $client "error:$!\n";
                              }
                          } else {
                              print $client "error:$!\n";
                          }
 # ------------------------------------------------------------------------ dump  # ------------------------------------------------------------------------ dump
                    } elsif ($userinput =~ /^dump/) {                     } elsif ($userinput =~ /^dump/) {
                        my ($cmd,$udom,$uname,$namespace,$regexp)                         my ($cmd,$udom,$uname,$namespace,$regexp)
Line 1647  sub unsub { Line 1703  sub unsub {
     return $result;      return $result;
 }  }
   
   sub currentversion {
       my $fname=shift;
       my $version=-1;
       my $ulsdir='';
       if ($fname=~/^(.+)\/[^\/]+$/) {
          $ulsdir=$1;
       }
       $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
       $fname=~s/\.(\w+(?:\.meta)*)$/\.\(\\d\+\)\.$1\$/;
   
       if (-e $fname) { $version=1; }
       if (-e $ulsdir) {
          if(-d $ulsdir) {
             if (opendir(LSDIR,$ulsdir)) {
                while ($ulsfn=readdir(LSDIR)) {
   # see if this is a regular file (ignore links produced earlier)
                    my $thisfile=$ulsdir.'/'.$ulsfn;
                    unless (-l $thisfile) {
       if ($thisfile=~/$fname/) {
           if ($1>$version) { $version=$1; }
                       }
    }
                }
                closedir(LSDIR);
                $version++;
             }
         }
      }
      return $version;
   }
   
   sub thisversion {
       my $fname=shift;
       my $version=-1;
       if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
    $version=$1;
       }
       return $version;
   }
   
 sub subscribe {  sub subscribe {
     my ($userinput,$clientip)=@_;      my ($userinput,$clientip)=@_;
     my $result;      my $result;
     my ($cmd,$fname)=split(/:/,$userinput);      my ($cmd,$fname)=split(/:/,$userinput);
     my $ownership=&ishome($fname);      my $ownership=&ishome($fname);
     if ($ownership eq 'owner') {      if ($ownership eq 'owner') {
   # explitly asking for the current version?
           unless (-e $fname) {
               my $currentversion=&currentversion($fname);
       if (&thisversion($fname)==$currentversion) {
                   if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
       my $root=$1;
                       my $extension=$2;
                       symlink($root.'.'.$extension,
                               $root.'.'.$currentversion.'.'.$extension);
                       unless ($extension=~/\.meta$/) {
                          symlink($root.'.'.$extension.'.meta',
                               $root.'.'.$currentversion.'.'.$extension.'.meta');
       }
                   }
               }
           }
  if (-e $fname) {   if (-e $fname) {
     if (-d $fname) {      if (-d $fname) {
  $result="directory\n";   $result="directory\n";
Removed from v.1.100  
changed lines
  Added in v.1.105

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>