From lon-capa-cvs@mail.lon-capa.org Mon Feb 18 20:44:59 2002 From: lon-capa-cvs@mail.lon-capa.org (www) Date: Mon, 18 Feb 2002 20:44:59 -0000 Subject: [LON-CAPA-cvs] cvs: loncom /cgi lonversions.pl Message-ID: www Mon Feb 18 15:44:59 2002 EDT Added files: /loncom/cgi lonversions.pl Log: Version query Index: loncom/cgi/lonversions.pl +++ loncom/cgi/lonversions.pl #!/usr/bin/perl $|=1; # The LearningOnline Network with CAPA # Versions # (Running loncron # 09/06/01 Gerd Kortemeyer) # 02/18/02 Gerd Kortemeyer # print "Content-type: text/html\n\n". "

Handler Versions

". "Please be patient

\n";
open (DFH,
"grep '\$Id' /home/httpd/perl/* /home/httpd/lib/perl/Apache/*.pm /home/httpd/html/res/adm/includes/* /home/httpd/html/res/adm/pages/*|");
while ($line=) { 
   print "$line"; 
}
close(DFH);
print "

"; From lon-capa-cvs@mail.lon-capa.org Mon Feb 18 20:59:36 2002 From: lon-capa-cvs@mail.lon-capa.org (www) Date: Mon, 18 Feb 2002 20:59:36 -0000 Subject: [LON-CAPA-cvs] cvs: loncom /cgi ping.pl Message-ID: www Mon Feb 18 15:59:36 2002 EDT Added files: /loncom/cgi ping.pl Log: Ping cgi-bin script Index: loncom/cgi/ping.pl +++ loncom/cgi/ping.pl #!/usr/bin/perl # The LearningOnline Network with CAPA # ping cgi-script $|=1; use IO::File; use IO::Socket; # -------------------------------------------------- Non-critical communication sub reply { my ($cmd,$server)=@_; my $peerfile="$perlvar{'lonSockDir'}/$server"; my $client=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10) or return "con_lost"; print $client "$cmd\n"; my $answer=<$client>; chomp($answer); if (!$answer) { $answer="con_lost"; } return $answer; } # ------------------------------------------------------------ Read access.conf { my $config=IO::File->new("/etc/httpd/conf/access.conf"); while (my $configline=<$config>) { if ($configline =~ /PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); $perlvar{$varname}=$varvalue; } } delete $perlvar{'lonReceipt'}; # remove since sensitive and not needed delete $perlvar{'lonSqlAccess'}; # remove since sensitive and not needed } $testhost=$ENV{'QUERY_STRING'}; $testhost=~s/\W//g; print "Content-type: text/plain\n\n". &reply('ping',$testhost)."\n"; From lon-capa-cvs@mail.lon-capa.org Mon Feb 18 21:38:39 2002 From: lon-capa-cvs@mail.lon-capa.org (harris41) Date: Mon, 18 Feb 2002 21:38:39 -0000 Subject: [LON-CAPA-cvs] cvs: doc /loncapafiles loncapafiles.lpml Message-ID: harris41 Mon Feb 18 16:38:39 2002 EDT Modified files: /doc/loncapafiles loncapafiles.lpml Log: adding lonversions.pl and ping.pl Index: doc/loncapafiles/loncapafiles.lpml diff -u doc/loncapafiles/loncapafiles.lpml:1.99 doc/loncapafiles/loncapafiles.lpml:1.100 --- doc/loncapafiles/loncapafiles.lpml:1.99 Sat Feb 16 19:35:59 2002 +++ doc/loncapafiles/loncapafiles.lpml Mon Feb 18 16:38:39 2002 @@ -1,7 +1,7 @@ - + - + -ENDENVIRONMENTFORM -#------------------ end of forms to be output - -################################################################ -# Handler subroutines # -################################################################ # # Write lonnet::passwd to do the call below. # Use: # my $answer=reply("encrypt:passwd:$udom:$uname:$upass",$tryserver); # -# I really should write some javascript to check on the client side for -# mismatched passwords, but other problems are more pressing -# ################################################## # password associated functions # ################################################## sub des_keys { - # Make a new key for DES encryption - # Each key has two parts which are returned seperately + # Make a new key for DES encryption. + # Each key has two parts which are returned seperately. + # Please note: Each key must be passed through the &hex function + # before it is output to the web browser. The hex versions cannot + # be used to decrypt. my @hexstr=('0','1','2','3','4','5','6','7', '8','9','a','b','c','d','e','f'); my $lkey=''; @@ -119,16 +91,23 @@ $cypher->decrypt(unpack("a8",pack("H16",substr($cyphertext,0,16)))); $plaintext.= $cypher->decrypt(unpack("a8",pack("H16",substr($cyphertext,16,16)))); - $plaintext=unpack("a8",$plaintext); - $plaintext=substr($plaintext,1,ord(substr($plaintext,0,1))); - unpack("a8",$plaintext); + $plaintext=substr($plaintext,1,ord(substr($plaintext,0,1)) ); return $plaintext; } +################################################################ +# Handler subroutines # +################################################################ + +###################################################### +# password handler subroutines # +###################################################### sub passwordchanger { + # This function is a bit of a mess.... # Passwords are encrypted using londes.js (DES encryption) - # my $r = shift; + my $errormessage = shift; + $errormessage = ($errormessage || ''); my $user = $ENV{'user.name'}; my $domain = $ENV{'user.domain'}; my $homeserver = $ENV{'user.home'}; @@ -140,14 +119,14 @@ my ($lkey_cpass ,$ukey_cpass ) = &des_keys(); my ($lkey_npass1,$ukey_npass1) = &des_keys(); my ($lkey_npass2,$ukey_npass2) = &des_keys(); - # Store the keys + # Store the keys in the log files my $lonhost = $r->dir_config('lonHostID'); my $logtoken=Apache::lonnet::reply('tmpput:' .$ukey_cpass . $lkey_cpass .'&' .$ukey_npass1 . $lkey_npass1.'&' .$ukey_npass2 . $lkey_npass2, $lonhost); - # Hexify these keys + # Hexify the keys for output as javascript variables $ukey_cpass = hex($ukey_cpass); $lkey_cpass = hex($lkey_cpass); $ukey_npass1= hex($ukey_npass1); @@ -155,13 +134,7 @@ $ukey_npass2= hex($ukey_npass2); $lkey_npass2= hex($lkey_npass2); # Output javascript to deal with passwords - $r->print(< - -The LearningOnline Network with CAPA - -ENDHEADER - # Output DES javascript + # Output DES javascript { my $include = $r->dir_config('lonIncludes'); my $jsh=Apache::File->new($include."/londes.js"); @@ -199,6 +172,7 @@

Preferences for $user

$user is a member of domain $domain

+$errormessage

Change password for $user

@@ -211,23 +185,23 @@ - - + +

- - - - - - + + + + + +

Current password:
New password:
Confirm password:
Current password:
New password:
Confirm password:

- - + + @@ -245,47 +219,105 @@ my $domain = $ENV{'user.domain'}; my $homeserver = $ENV{'user.home'}; my $currentauth=&Apache::lonnet::queryauthenticate($user,$domain); + # Check for authentication types that allow changing of the password. + return if ($currentauth !~ /^(unix|internal):/); # - $r->print("

verify and change password

\n"); + $r->print(< + +LON-CAPA Preferences: Change password for $user + +ENDHEADER # my $currentpass = $ENV{'form.currentpass'}; my $newpass1 = $ENV{'form.newpass_1'}; my $newpass2 = $ENV{'form.newpass_2'}; my $logtoken = $ENV{'form.logtoken'}; # Check for empty data - if (!(defined($currentpass) && - defined($newpass1) && - defined($newpass2))){ - $r->print("ERROR Password data was ". - "blank.\n"); + unless (defined($currentpass) && + defined($newpass1) && + defined($newpass2) ){ + &passwordchanger($r,"

\nERROR". + "Password data was blank.\n

"); return; } # Get the keys my $lonhost = $r->dir_config('lonHostID'); my $tmpinfo = Apache::lonnet::reply('tmpget:'.$logtoken,$lonhost); if (($tmpinfo=~/^error/) || ($tmpinfo eq 'con_lost')) { + # I do not a have a better idea about how to handle this $r->print(< ERROR: Unable to retrieve stored token for -password decryption. +password decryption. Please log out and try again.

ENDERROR + # Probably should log an error here return; } my ($ckey,$n1key,$n2key)=split(/&/,$tmpinfo); - # decrypt + # my $currentpass = &des_decrypt($ckey ,$currentpass); my $newpass1 = &des_decrypt($n1key,$newpass1); my $newpass2 = &des_decrypt($n2key,$newpass2); - # Sanity check + # if ($newpass1 ne $newpass2) { - $r->print('ERROR:The new passwords you '. - 'entered do not match. Please try again.'); - &passwordchanger($r); + &passwordchanger($r, + 'ERROR:'. + 'The new passwords you entered do not match. '. + 'Please try again.'); + return; + } + if (length($newpass1) < 7) { + &passwordchanger($r, + 'ERROR:'. + 'Passwords must be a minimum of 7 characters long. '. + 'Please try again.'); return; } + # + # Check for bad characters + my $badpassword = 0; + foreach (split(//,$newpass1)) { + $badpassword = 1 if ((ord($_)<32)||(ord($_)>126)); + } + if ($badpassword) { + # I can't figure out how to enter bad characters on my browser. + &passwordchanger($r,<ERROR: +The password you entered contained illegal characters.
+Valid characters are: space and
+

+!"\#$%&\'()*+,-./0123456789:;<=>?\@
+ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_\`abcdefghijklmnopqrstuvwxyz{|}~
+

+ENDERROR + } + # + # Change the password (finally) + my $result = &Apache::lonnet::changepass + ($user,$domain,$currentpass,$newpass1,$homeserver); + # Inform the user the password has (not?) been changed + if ($result =~ /^ok$/) { + $r->print(<<"ENDTEXT"); +

Password for $user was successfully changed

+ENDTEXT + } else { + # error error: run in circles, scream and shout + $r->print(<Password for $user was not changed +There was an internal error when attempting to change your password. +Please contact your instructor or the domain coordinator. +ENDERROR + } + return; } +###################################################### +# other handler subroutines # +###################################################### + + ################################################################ # Main handler # ################################################################ @@ -294,6 +326,8 @@ my $user = $ENV{'user.name'}; my $domain = $ENV{'user.domain'}; $r->content_type('text/html'); + # Some pages contain DES keys and should not be cached. + &Apache::loncommon::no_cache($r); $r->send_http_header; return OK if $r->header_only; # Spit out the header @@ -305,7 +339,7 @@ $r->print(< -The LearningOnline Network with CAPA +LON-CAPA Preferences

Preferences for $user

@@ -314,11 +348,15 @@ # Determine current authentication method my $currentauth=&Apache::lonnet::queryauthenticate($user,$domain); if ($currentauth =~ /^(unix|internal):/) { - $r->print($passwordform); + $r->print(< + + + +ENDPASSWORDFORM + # Other preference setting code should be added here } - $r->print($environmentform); } - # Spit out the footer $r->print(< --matthew1014155440-- From lon-capa-cvs@mail.lon-capa.org Tue Feb 19 21:51:09 2002 From: lon-capa-cvs@mail.lon-capa.org (matthew) Date: Tue, 19 Feb 2002 21:51:09 -0000 Subject: [LON-CAPA-cvs] cvs: loncom / lcpasswd pwchange Message-ID: matthew Tue Feb 19 16:51:09 2002 EDT Modified files: /loncom lcpasswd pwchange Log: Fixed silly bug in checking for invalid password characters. Index: loncom/lcpasswd diff -u loncom/lcpasswd:1.14 loncom/lcpasswd:1.15 --- loncom/lcpasswd:1.14 Thu Feb 14 17:09:14 2002 +++ loncom/lcpasswd Tue Feb 19 16:51:09 2002 @@ -10,8 +10,11 @@ # # YEAR=2001 # 10/22,10/23,11/13,11/15 Scott Harrison +# +# YEAR=2002 +# 02/19 Matthew Hall # -# $Id: lcpasswd,v 1.14 2002/02/14 22:09:14 harris41 Exp $ +# $Id: lcpasswd,v 1.15 2002/02/19 21:51:09 matthew Exp $ ### ############################################################################### @@ -131,8 +134,8 @@ exit 9; } my $pbad=0; -foreach (split(//,$password1)) {if (($_<32)&&($_>126)){$pbad=1;}} -foreach (split(//,$password2)) {if (($_<32)&&($_>126)){$pbad=1;}} +foreach (split(//,$password1)) {if ((ord($_)<32)||(ord($_)>126)){$pbad=1;}} +foreach (split(//,$password2)) {if ((ord($_)<32)||(ord($_)>126)){$pbad=1;}} if ($pbad) { print "Error. A password entry had an invalid character.\n"; unlink('/tmp/lock_lcpasswd'); Index: loncom/pwchange diff -u loncom/pwchange:1.5 loncom/pwchange:1.6 --- loncom/pwchange:1.5 Fri Nov 16 01:10:41 2001 +++ loncom/pwchange Tue Feb 19 16:51:09 2002 @@ -7,7 +7,10 @@ # YEAR=2001 # 10/23,11/13,11/15 Scott Harrison # -# $Id: pwchange,v 1.5 2001/11/16 06:10:41 harris41 Exp $ +# YEAR=2002 +# 02/19 Matthew Hall +# +# $Id: pwchange,v 1.6 2002/02/19 21:51:09 matthew Exp $ ### use strict; @@ -37,7 +40,7 @@ } my $pbad=0; -map {if (($_<32)&&($_>126)){$pbad=1;}} (split(//,$pword)); +foreach (split(//,$pword)) {if ((ord($_)<32)||(ord($_)>126)){$pbad=1;}} exit 3 if $pbad; # --------------------------------------------------------- Call system command From lon-capa-cvs@mail.lon-capa.org Tue Feb 19 21:52:54 2002 From: lon-capa-cvs@mail.lon-capa.org (matthew) Date: Tue, 19 Feb 2002 21:52:54 -0000 Subject: [LON-CAPA-cvs] cvs: loncom / lond Message-ID: matthew Tue Feb 19 16:52:54 2002 EDT Modified files: /loncom lond Log: Added unix (filesystem) authentication handling to passwd handler. Index: loncom/lond diff -u loncom/lond:1.71 loncom/lond:1.72 --- loncom/lond:1.71 Tue Feb 12 18:08:27 2002 +++ loncom/lond Tue Feb 19 16:52:54 2002 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.71 2002/02/12 23:08:27 www Exp $ +# $Id: lond,v 1.72 2002/02/19 21:52:54 matthew Exp $ # # Copyright Michigan State University Board of Trustees # @@ -670,7 +670,8 @@ chomp($npass); $upass=&unescape($upass); $npass=&unescape($npass); - my $proname=propath($udom,$uname); + &logthis("Trying to change password for $uname"); + my $proname=propath($udom,$uname); my $passfilename="$proname/passwd"; if (-e $passfilename) { my $realpasswd; @@ -685,11 +686,42 @@ my $ncpass=crypt($npass,$salt); { my $pf = IO::File->new(">$passfilename"); print $pf "internal:$ncpass\n"; } + &logthis("Result of password change for $uname: pwchange_success"); print $client "ok\n"; } else { print $client "non_authorized\n"; } - } else { + } elsif ($howpwd eq 'unix') { + # Unix means we have to access /etc/password + # one way or another. + # First: Make sure the current password is + # correct + $contentpwd=(getpwnam($uname))[1]; + my $pwdcorrect = "0"; + my $pwauth_path="/usr/local/sbin/pwauth"; + unless ($contentpwd eq 'x') { + $pwdcorrect= + (crypt($upass,$contentpwd) eq $contentpwd); + } elsif (-e $pwauth_path) { + open PWAUTH, "|$pwauth_path" or + die "Cannot invoke authentication"; + print PWAUTH "$uname\n$upass\n"; + close PWAUTH; + $pwdcorrect=!$?; + } + if ($pwdcorrect) { + my $execdir=$perlvar{'lonDaemons'}; + my $pf = IO::File->new("|$execdir/lcpasswd"); + print $pf "$uname\n$npass\n$npass\n"; + close $pf; + my $result = ($?>0 ? 'pwchange_failure' + : 'ok'); + &logthis("Result of password change for $uname: $result"); + print $client "$result\n"; + } else { + print $client "non_authorized\n"; + } + } else { print $client "auth_mode_error\n"; } } else { From lon-capa-cvs@mail.lon-capa.org Tue Feb 19 21:53:42 2002 From: lon-capa-cvs@mail.lon-capa.org (matthew) Date: Tue, 19 Feb 2002 21:53:42 -0000 Subject: [LON-CAPA-cvs] cvs: loncom /lonnet/perl lonnet.pm Message-ID: matthew Tue Feb 19 16:53:42 2002 EDT Modified files: /loncom/lonnet/perl lonnet.pm Log: Added &changepass() to allow the user to change their password. Index: loncom/lonnet/perl/lonnet.pm diff -u loncom/lonnet/perl/lonnet.pm:1.201 loncom/lonnet/perl/lonnet.pm:1.202 --- loncom/lonnet/perl/lonnet.pm:1.201 Thu Feb 14 15:44:26 2002 +++ loncom/lonnet/perl/lonnet.pm Tue Feb 19 16:53:42 2002 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.201 2002/02/14 20:44:26 albertel Exp $ +# $Id: lonnet.pm,v 1.202 2002/02/19 21:53:42 matthew Exp $ # # Copyright Michigan State University Board of Trustees # @@ -346,6 +346,41 @@ } } return $spareserver; +} + +# --------------------------------------------- Try to change a user's password + +sub changepass { + my ($uname,$udom,$currentpass,$newpass,$server)=@_; + $currentpass = &escape($currentpass); + $newpass = &escape($newpass); + my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass", + $server); + if (! $answer) { + &logthis("No reply on password change request to $server ". + "by $uname in domain $udom."); + } elsif ($answer =~ "^ok") { + &logthis("$uname in $udom successfully changed their password ". + "on $server."); + } elsif ($answer =~ "^pwchange_failure") { + &logthis("$uname in $udom was unable to change their password ". + "on $server. The action was blocked by either lcpasswd ". + "or pwchange"); + } elsif ($answer =~ "^non_authorized") { + &logthis("$uname in $udom did not get their password correct when ". + "attempting to change it on $server."); + } elsif ($answer =~ "^auth_mode_error") { + &logthis("$uname in $udom attempted to change their password despite ". + "not being locally or internally authenticated on $server."); + } elsif ($answer =~ "^unknown_user") { + &logthis("$uname in $udom attempted to change their password ". + "on $server but were unable to because $server is not ". + "their home server."); + } elsif ($answer =~ "^refused") { + &logthis("$server refused to change $uname in $udom password because ". + "it was sent an unencrypted request to change the password."); + } + return $answer; } # ----------------------- Try to determine user's current authentication scheme From lon-capa-cvs@mail.lon-capa.org Tue Feb 19 22:51:14 2002 From: lon-capa-cvs@mail.lon-capa.org (www) Date: Tue, 19 Feb 2002 22:51:14 -0000 Subject: [LON-CAPA-cvs] cvs: loncom / lonc Message-ID: www Tue Feb 19 17:51:14 2002 EDT Modified files: /loncom lonc Log: Skip empty lines in broken hosts.tabs Index: loncom/lonc diff -u loncom/lonc:1.27 loncom/lonc:1.28 --- loncom/lonc:1.27 Tue Feb 19 16:49:12 2002 +++ loncom/lonc Tue Feb 19 17:51:13 2002 @@ -5,7 +5,7 @@ # provides persistent TCP connections to the other servers in the network # through multiplexed domain sockets # -# $Id: lonc,v 1.27 2002/02/19 21:49:12 www Exp $ +# $Id: lonc,v 1.28 2002/02/19 22:51:13 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -160,8 +160,10 @@ while ($configline=) { my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); chomp($ip); - $hostip{$id}=$ip; - $hostname{$id}=$name; + if ($ip) { + $hostip{$id}=$ip; + $hostname{$id}=$name; + } } close(CONFIG); From lon-capa-cvs@mail.lon-capa.org Wed Feb 20 00:21:42 2002 From: lon-capa-cvs@mail.lon-capa.org (harris41) Date: Wed, 20 Feb 2002 00:21:42 -0000 Subject: [LON-CAPA-cvs] cvs: loncom /build xfml_parse.pl Message-ID: This is a MIME encoded message --harris411014164502 Content-Type: text/plain harris41 Tue Feb 19 19:21:42 2002 EDT Modified files: /loncom/build xfml_parse.pl Log: a cleaner leaner script (major rewrite) --harris411014164502 Content-Type: text/plain Content-Disposition: attachment; filename="harris41-20020219192142.txt" Index: loncom/build/xfml_parse.pl diff -u loncom/build/xfml_parse.pl:1.2 loncom/build/xfml_parse.pl:1.3 --- loncom/build/xfml_parse.pl:1.2 Fri Feb 1 05:56:41 2002 +++ loncom/build/xfml_parse.pl Tue Feb 19 19:21:42 2002 @@ -12,22 +12,15 @@ ## ## ## ORGANIZATION OF THIS PERL SCRIPT ## ## 1. Notes ## -## 2. Get command line arguments ## -## 3. First pass through (grab distribution-specific information) ## -## 4. Second pass through (parse out what is not necessary) ## -## 5. Third pass through (translate markup according to specified mode) ## -## 6. Functions (most all just format contents of different markup tags) ## -## 7. POD (plain old documentation, CPAN style) ## +## 2. Read in filter file ## +## 3. Initialize and clear conditions ## +## 4. Run through and apply clauses ## ## ## ############################################################################### # ----------------------------------------------------------------------- Notes # -# I am using a multiple pass-through approach to parsing -# the xfml file. This saves memory and makes sure the server -# will never be overloaded. -# -# This is meant to parse files meeting the piml document type. +# This is meant to parse files meeting the xfml document type. # See xfml.dtd. XFML=XML Filtering Markup Language. use HTML::TokeParser; @@ -43,26 +36,26 @@ } my %eh; -my %ih; + +# ---------------------------------------------- Read in filter file from @ARGV my $tofilter=shift @ARGV; -open IN,"<$tofilter"; -my @lines=; my $parsestring=join('',@lines); undef @lines; -close IN; +open IN,"<$tofilter"; my @lines=; +my $parsestring=join('',@lines); undef @lines; close IN; my $parser = HTML::TokeParser->new(\$parsestring) or die('can\'t create TokeParser object'); $parser->xml_mode('1'); -# Define handling methods for mode-dependent text rendering - +# --------------------------------------------- initialize and clear conditions my %conditions; &cc; +# Define handling methods for mode-dependent text rendering $parser->{textify}={ - xfml => \&format_xfml, + 'xfml' => \&format_xfml, 'when:name' => \&format_when_name, 'when:attribute' => \&format_when_attribute, 'when:cdata' => \&format_when_cdata, - 'choice:include' => \&format_choice_include, 'choice:exclude' => \&format_choice_exclude, + 'clause' => \&format_clause, }; my $text; @@ -70,158 +63,156 @@ my $wloc=0; my %eha; -while (my $token = $parser->get_tag('xfml')) { - &format_xfml(@{$token}); - $text = $parser->get_text('/xfml'); - $token = $parser->get_tag('/xfml'); -} - -#open IN,"<$tofilter"; -my @lines2=<>; my $parsestring2=join('',@lines2); undef @lines2; -$parser = HTML::TokeParser->new(\$parsestring2) or +# ----------------------------------------------- Run through and apply clauses +my @lines2=<>; my $output=join('',@lines2); undef @lines2; +my $lparser = HTML::TokeParser->new(\$output) or die('can\'t create TokeParser object'); -$parser->xml_mode('1'); - -my $token; -my $hloc=0; -my %ts; -my $tr; -my $echild=0; -my $exclude=0; -my $excluden=0; -my $excludea=0; -my $et=0; -my $cdata=''; -my $excludenold=0; -my $ign=0; - -while ($token = $parser->get_token()) { - if ($token->[0] eq 'D') { - print $token->[1]; - } - elsif ($token->[0] eq 'C') { - print $token->[1]; - } - elsif ($token->[0] eq 'S') { - $cdata=''; - $hloc++; -# if token can be excluded, then pretend it is until all conditions are -# run (eha); then output during end tag processing -# else, output - -# a token can be excluded when it is an eh key, or a child node of -# an eh key - - if ($eh{$token->[1]}) { - $echild=$token->[1]; +$lparser->xml_mode('1'); +my $parsestring2; +while (my $token = $parser->get_tag('clause')) { + $parsestring2=$output; + $lparser = HTML::TokeParser->new(\$parsestring2); + $lparser->xml_mode('1'); + $output=''; + &format_clause(@{$token}); + $text = $parser->get_text('/clause'); + $token = $parser->get_tag('/clause'); + + my $token=''; + my $ttype=''; + my $excludeflag=0; + my $outcache=''; + while ($token = $lparser->get_token()) { + if ($token->[0] eq 'D') { $ttype='D'; $output.=$token->[1]; } + elsif ($token->[0] eq 'C') { $ttype='C'; $output.=$token->[1]; } + elsif ($token->[0] eq 'T') { + if ($ttype eq 'D' or $ttype eq 'C' or $ttype eq 'S' + or $ttype eq 'E') { + $output.=$token->[1]; + } + else { + $outcache.=$token->[1]; + } } - if ($echild) { - # run through names for echild - # then attributes and/or values and/or cdata - my $name=$token->[1]; - my @attributes=@{$token->[3]}; - my %atthash=%{$token->[2]}; - foreach my $namemlist (@{$eha{$echild}->{'name'}}) { - foreach my $namematch (@{$namemlist}) { - my $nm=$namematch; $nm=~s/^.//; $nm=~s/.$//; - if ($name=~/$nm/) { - $excludenold=$excluden; - $excluden++; - foreach my $attributemlist - (@{$eha{$echild}->{'attribute'}}) { - foreach my $attributematch - (@{$attributemlist}) { - my ($an,$am)= - split(/\=/,$attributematch,2); - $am=~s/^.//; - $am=~s/.$//; - if ($atthash{$an}) { - if ($atthash{$an}=~/$am/) { - $excludea++; - } - } - } - } - } - } + elsif ($token->[0] eq 'S') { + if ($eh{$token->[1]} or $excludeflag==1) { + $ttype=''; + $excludeflag=1; + $outcache.=$token->[4]; + } + else { + $ttype='S'; + $output.=$token->[4]; + } + if ($excludeflag==1) { + } - $tr.=$token->[4]; } - else { - print $token->[4]; + elsif ($token->[0] eq 'E') { + if ($eh{$token->[1]} and $excludeflag==1) { + $ttype='E'; + $excludeflag=0; + $outcache.=$token->[2]; + my $retval=&evalconditions($outcache); + if (&evalconditions($outcache)) { + $output.=$outcache; + } + else { + $output.=''; + } + $outcache=''; + } + elsif ($excludeflag==1) { + $ttype=''; + $outcache.=$token->[2]; + } + else { + $output.=$token->[2]; + $ttype='E'; + } } } - elsif ($token->[0] eq 'E') { - if ($echild) { - $tr.=$token->[2]; - if ($excluden) { - my $i=0; - CDATALOOP: - foreach my $cdatamlist (@{$eha{$echild}->{'cdata'}}) { - $i++; - my $j; - foreach my $cdatamatch (@{$cdatamlist}) { - $j++; -# print "CDATA: $cdatamatch, $cdata\n"; - my $cm=$cdatamatch; - my $not=0; - if ($cm=~/\!/) { - $not=1; - $cm=~s/^.//; + &cc; +} +print $output; + +# -------------------------------------------------------------- evalconditions +sub evalconditions { + my ($parsetext)=@_; + my $eparser = HTML::TokeParser->new(\$parsetext); + unless (@{$conditions{'name'}} or + @{$conditions{'attribute'}}) { + return 0; + } + my $nameflag=0; + my $cdataflag=0; + my $matchflag=0; + my $Ttoken=''; + while (my $token = $eparser->get_token()) { + if ($token->[0] eq 'S') { + foreach my $name (@{$conditions{'name'}}) { + my $flag=0; + my $match=$name; + if ($match=~/^\!/) { + $match=~s/^\!//g; + $flag=1; + } + $match=~s/^\///g; + $match=~s/\/$//g; + if ((!$flag and $token->[1]=~/$match/) or + ($flag and $token->[1]!~/$match/)) { + $nameflag=1; + } + } + $Ttoken=''; + } + elsif ($token->[0] eq 'E') { + foreach my $name (@{$conditions{'name'}}) { + my $flag=0; + my $match=$name; + if ($match=~/^\!/) { + $match=~s/^\!//g; + $flag=1; + } + $match=~s/^\///g; + $match=~s/\/$//g; + if ((!$flag and $token->[1]=~/$match/) or + ($flag and $token->[1]!~/$match/)) { + foreach my $cdata (@{$conditions{'cdata'}}) { + my $flag=0; + my $match=$cdata; + if ($match=~/^\!/) { + $match=~s/^\!//g; + $flag=1; } - $cm=~s/^.//; $cm=~s/.$//; - if ($not and $cdata=~/$cm/) { - $ign=1; $exclude=0; + $match=~s/^\///g; + $match=~s/\/$//g; + if ((!$flag and $Ttoken=~/$match/) or + ($flag and $Ttoken!~/$match/)) { + $cdataflag=1; } - if ((!$not and $cdata!~/$cm/) - or ($not and $cdata=~/$cm/)) { -# nothing happens -# $exclude=0; + } + if (@{$conditions{'cdata'}}) { + if ($cdataflag) { + return 0; } - elsif (($not and $cdata!~/$cm/) - or (!$not and $cdata=~/$cm/)) { - $exclude++ unless $ign; + } + else { + if ($nameflag) { + return 0; } } + $nameflag=0; } } } - if ($eh{$token->[1]}) { - $ign=0; - $echild=0; - if (!$exclude and !$excludea) { - print $tr; -# print $token->[2]; - $tr=''; - } - elsif ($exclude>0 or $excludea>0) { -# print "EXCLUDING $token->[1] $exclude $excludea $excluden\n"; - $exclude=0; $excluden=0; $excludea=0; - $tr=''; - } - $exclude=0; $excluden=0; $excludea=0; - } - else { - if ($echild) { -# $tr.=$token->[2]; + elsif ($token->[0] eq 'T') { + if ($nameflag) { + $Ttoken.=$token->[1]; } - else { - print $token->[2]; - $tr=''; - } - } - $hloc--; - } - elsif ($token->[0] eq 'T') { - if ($echild) { - $tr.=$token->[1]; - $cdata=$token->[1]; - } - else { - print $token->[1]; - $tr=''; } } + return 1; } # ------------------------------------------------------------ clear conditions @@ -230,6 +221,7 @@ @{$conditions{'attribute'}}=(); pop @{$conditions{'attribute'}}; @{$conditions{'value'}}=(); pop @{$conditions{'value'}}; @{$conditions{'cdata'}}=(); pop @{$conditions{'cdata'}}; + %eh=(1,1); delete $eh{1}; } # --------------------------------------- remove starting and ending whitespace @@ -239,35 +231,29 @@ + # --------------------------------------------------------- Format xfml section sub format_xfml { my (@tokeninfo)=@_; return ''; } +# ------------------------------------------------------- Format clause section +sub format_clause { + my (@tokeninfo)=@_; + return ''; +} + # ---------------------------------------------------- Format when:name section sub format_when_name { my (@tokeninfo)=@_; - $wloc++; +# $wloc++; my $att_match=$tokeninfo[2]->{'match'}; push @{$conditions{'name'}},$att_match; my $text=&trim($parser->get_text('/when:name')); $parser->get_tag('/when:name'); - $wloc--; - &cc unless $wloc; - return ''; -} - -# ----------------------------------------------- Format when:attribute section -sub format_when_attribute { - my (@tokeninfo)=@_; - $wloc++; - my $att_match=$tokeninfo[2]->{'match'}; - push @{$conditions{'attribute'}},$att_match; - my $text=&trim($parser->get_text('/when:attribute')); - $parser->get_tag('/when:attribute'); - $wloc--; - &cc unless $wloc; +# $wloc--; +# &cc unless $wloc; return ''; } @@ -280,16 +266,7 @@ my $text=&trim($parser->get_text('/when:cdata')); $parser->get_tag('/when:cdata'); $wloc--; - &cc unless $wloc; - return ''; -} - -# ----------------------------------------------- Format choice:include section -sub format_choice_include { - my (@tokeninfo)=@_; - my $text=&trim($parser->get_text('/choice:include')); - $parser->get_tag('/choice:include'); - $ih{$tokeninfo[2]->{'match'}}++; +# &cc unless $wloc; return ''; } --harris411014164502-- From lon-capa-cvs@mail.lon-capa.org Wed Feb 20 00:23:24 2002 From: lon-capa-cvs@mail.lon-capa.org (harris41) Date: Wed, 20 Feb 2002 00:23:24 -0000 Subject: [LON-CAPA-cvs] cvs: loncom /build Makefile Message-ID: harris41 Tue Feb 19 19:23:24 2002 EDT Modified files: /loncom/build Makefile Log: fixing up filtering for hosts.tab Index: loncom/build/Makefile diff -u loncom/build/Makefile:1.69 loncom/build/Makefile:1.70 --- loncom/build/Makefile:1.69 Wed Feb 13 10:03:47 2002 +++ loncom/build/Makefile Tue Feb 19 19:23:24 2002 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Scott Harrison -# $Id: Makefile,v 1.69 2002/02/13 15:03:47 harris41 Exp $ +# $Id: Makefile,v 1.70 2002/02/20 00:23:24 harris41 Exp $ DIST="default" CATEGORY="development" @@ -87,8 +87,6 @@ hosts_tab: TEST_hosts_tab cat ../../doc/loncapafiles/loncapafiles.lpml | \ perl xfml_parse.pl ../../doc/loncapafiles/valid_hosts.xfml | \ - perl xfml_parse.pl ../../doc/loncapafiles/no_globs.xfml | \ - perl xfml_parse.pl ../../doc/loncapafiles/no_links.xfml | \ perl lpml_parse.pl install $(CATEGORY) $(DIST) "$(SOURCE)" \ "$(TARGET)" > Makefile.install make -f Makefile.install directories From lon-capa-cvs@mail.lon-capa.org Wed Feb 20 00:24:33 2002 From: lon-capa-cvs@mail.lon-capa.org (harris41) Date: Wed, 20 Feb 2002 00:24:33 -0000 Subject: [LON-CAPA-cvs] cvs: doc /loncapafiles no_globs.xfml no_links.xfml valid_hosts.xfml Message-ID: harris41 Tue Feb 19 19:24:33 2002 EDT Modified files: /doc/loncapafiles no_globs.xfml no_links.xfml valid_hosts.xfml Log: fixing up filter files to work better with new xfml_parse.pl Index: doc/loncapafiles/no_globs.xfml diff -u doc/loncapafiles/no_globs.xfml:1.1 doc/loncapafiles/no_globs.xfml:1.2 --- doc/loncapafiles/no_globs.xfml:1.1 Thu Jan 31 15:33:56 2002 +++ doc/loncapafiles/no_globs.xfml Tue Feb 19 19:24:32 2002 @@ -1,7 +1,7 @@ - + - + - + - +