From: Terry Burton Date: Wed, 24 Mar 2021 13:58:20 +0000 (+0000) Subject: Linter: Perl fixes (#4019) X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=faf0cacb7343ae85a584d6e7ff9ae9d55fa4c1ab;p=thirdparty%2Ffreeradius-server.git Linter: Perl fixes (#4019) --- diff --git a/doc/rfc/genref.pl b/doc/rfc/genref.pl index 61486ee5626..5a4d1d97d4f 100755 --- a/doc/rfc/genref.pl +++ b/doc/rfc/genref.pl @@ -1,24 +1,32 @@ #!/usr/bin/env perl -foreach $file (@ARGV) { - open FILE, "<$file" || die "Error opening $file: $!\n"; - $ref = $file; +use strict; +use warnings; + + +my %file; + +foreach my $file (@ARGV) { + open(my $FILE, '<', $file) || die "Error opening $file: $!\n"; + + my $ref = $file; $ref =~ s/\..*//g; - while () { + while (<$FILE>) { + next if (!/^(\d+\.)+\s+([a-zA-Z]+-)+[a-zA-Z]/); chop; - split; + @_ = split; - next if ($_[1] =~ /,/); + next if $_[1] =~ /,/; - next if (defined($file{$_[1]})); + next if defined $file{$_[1]}; print $ref, "\t", $_[1], "\n"; $file{$_[1]} = $ref; } - close FILE; + close $FILE; } diff --git a/doc/rfc/per-rfc.pl b/doc/rfc/per-rfc.pl index 4bec00a1736..0b2b6565e26 100755 --- a/doc/rfc/per-rfc.pl +++ b/doc/rfc/per-rfc.pl @@ -1,40 +1,46 @@ #!/usr/bin/env perl +use strict; +use warnings; + +my %refs; +my %defs; + # # Read in the references, and put into an associative array # -open FILE, ") { +open(my $FILE, "<", "refs") || die "Error opening refs: $!\n"; +while (<$FILE>) { chop; - split; + @_ = split; $refs{$_[1]} = $_[0]; $defs{$_[0]}{$_[1]}++; } -close FILE; +close $FILE; # # now loop over the input RFC's. # -foreach $file (@ARGV) { - $def=$file; +foreach my $file (@ARGV) { + my $def=$file; $def =~ s/\.txt//; - $attribute = "zzzzz"; + my $attribute = "zzzzz"; # get the current reference - $ref = $file; + my $ref = $file; $ref =~ s/\..*//g; - $rfc = $ref; + my $rfc = $ref; $ref = "attributes-$ref"; - open OUTPUT, ">$ref.html" || die "Error creating $ref.html: $!\n"; + open(my $OUTPUT, ">", "$ref.html") || die "Error creating $ref.html: $!\n"; # # Print out the HTML header # - print OUTPUT < + print $OUTPUT < @@ -45,21 +51,22 @@ foreach $file (@ARGV) {

$rfc Attribute List

EOF - $letter = "@"; + my $letter = "@"; - foreach $key (sort keys %{$defs{$def}}) { + foreach my $key (sort keys %{$defs{$def}}) { if (substr($key,0,1) ne $letter) { - print OUTPUT "\n" if ($letter ne "@"); + print $OUTPUT "\n" if $letter ne "@"; $letter = substr($key,0,1); - print OUTPUT "\n

$letter

\n\n"; - print OUTPUT "
    \n"; + print $OUTPUT "\n

    $letter

    \n\n"; + print $OUTPUT "
      \n"; } - print OUTPUT "$key
      \n"; + print $OUTPUT "$key
      \n"; } - print OUTPUT "
    \n"; - print OUTPUT "\n"; - close OUTPUT; + print $OUTPUT "
\n"; + print $OUTPUT "\n"; + print $OUTPUT "\n"; + close $OUTPUT; } diff --git a/doc/rfc/rewrite.pl b/doc/rfc/rewrite.pl index afd39c741fb..1318296ff84 100755 --- a/doc/rfc/rewrite.pl +++ b/doc/rfc/rewrite.pl @@ -1,35 +1,41 @@ #!/usr/bin/env perl +use strict; +use warnings; + +my %refs; +my $ref; + # # Read in the references, and put into an associative array # -open FILE, ") { +open(my $FILE, '<' ,'refs') || die "Error opening refs: $!\n"; +while (<$FILE>) { chop; - split; + @_ = split; $refs{$_[1]} = $_[0]; } -close FILE; +close $FILE; # # now loop over the input RFC's. # -foreach $file (@ARGV) { - open FILE, "<$file" || die "Error opening $file: $!\n"; +foreach my $file (@ARGV) { + open (my $FILE, '<', $file) || die "Error opening $file: $!\n"; - $attribute = "zzzzz"; + my $attribute = "zzzzz"; # get the current reference $ref = $file; $ref =~ s/\..*//g; - open OUTPUT, ">$ref.html" || die "Error creating $ref.html: $!\n"; + open(my $OUTPUT, '>', "$ref.html") || die "Error creating $ref.html: $!\n"; # # Print out the HTML header # - print OUTPUT < @@ -43,91 +49,93 @@ foreach $file (@ARGV) { EOF # loop over the input file - while () { - # html-ize it - s/&/&/g; - s//>/g; - - if (/\[Page/) { - print OUTPUT; - next; - } - - if (/^RFC \d+/) { - print OUTPUT; - next; - } - - chop; - - # - # Attribute name header. - # - if (/^\d+\./ && !/\d$/) { - split; - - if ($refs{$_[1]} ne "") { - $attribute = $_[1]; - - print OUTPUT "

$_

\n"; - - } else { - print OUTPUT "

$_

\n"; - $attribute = "zzzz"; - } - next; - } - - # - # Mark these up special. - # - if ((/^ Description/) || - (/^ Type/) || - (/^ Length/) || - (/^ Value/)) { - print OUTPUT "$_\n"; - next; - } - - # Make the current attribute name bold - s/$attribute/$attribute<\/b>/g; - - split; - - # - # Re-write the output with links to where-ever - # - foreach $word (@_) { - $word =~ s/[^-a-zA-Z]//g; - - if ($refs{$word} ne "") { - if ($refs{$word} eq $ref) { - s/$word/$word<\/a>/g; - } else { - s/$word/$word<\/a>/g; - } - } - } - - print OUTPUT $_, "\n"; + while (<$FILE>) { + # html-ize it + s/&/&/g; + s//>/g; + + if (/\[Page/) { + print $OUTPUT ""; + next; + } + + if (/^RFC \d+/) { + print $OUTPUT ""; + next; + } + + chop; + + # + # Attribute name header. + # + if (/^\d+\./ && !/\d$/) { + @_ = split; + + if ($refs{$_[1]} && $refs{$_[1]} ne "") { + $attribute = $_[1]; + + print $OUTPUT "

$_

\n"; + + } else { + print $OUTPUT "

$_

\n"; + $attribute = "zzzz"; + } + next; + } + + # + # Mark these up special. + # + if ((/^ Description/) || + (/^ Type/) || + (/^ Length/) || + (/^ Value/)) { + print $OUTPUT "$_\n"; + next; + } + + # Make the current attribute name bold + s/$attribute/$attribute<\/b>/g; + + @_ = split; + + # + # Re-write the output with links to where-ever + # + foreach my $word (@_) { + $word =~ s/[^-a-zA-Z]//g; + + if ($refs{$word} && $refs{$word} ne "") { + if ($refs{$word} eq $ref) { + s/$word/$word<\/a>/g; + } else { + s/$word/$word<\/a>/g; + } + } + } + + print $OUTPUT $_, "\n"; + } - print OUTPUT "\n"; - print OUTPUT "\n"; - close OUTPUT; - close FILE; + print $OUTPUT "\n"; + print $OUTPUT "\n"; + print $OUTPUT "\n"; + close $OUTPUT; + close $FILE; } # # And finally, create the index. # -open OUTPUT, ">attributes.html" || die "Error creating attributes.html: $!\n"; +open(my $OUTPUT, '>', "attributes.html") || die "Error creating attributes.html: $!\n"; # # Print out the HTML header # -print OUTPUT < @@ -140,21 +148,21 @@ print OUTPUT <RADIUS Attribute List EOF -$letter = "@"; +my $letter = "@"; -foreach $key (sort keys %refs) { +foreach my $key (sort keys %refs) { if (substr($key,0,1) ne $letter) { - print OUTPUT "\n" if ($letter ne "@"); - $letter = substr($key,0,1); - print OUTPUT "\n

$letter

\n\n"; - print OUTPUT "
    \n"; + print $OUTPUT "
\n" if $letter ne "@"; + $letter = substr($key,0,1); + print $OUTPUT "\n

$letter

\n\n"; + print $OUTPUT "\n"; +print $OUTPUT "\n"; -print OUTPUT "\n"; -print OUTPUT "\n"; -close OUTPUT; +print $OUTPUT "\n"; +print $OUTPUT "\n"; +close $OUTPUT; diff --git a/raddb/mods-config/perl/example.pl b/raddb/mods-config/perl/example.pl index 8aaa19152ab..0dc1693dfc1 100644 --- a/raddb/mods-config/perl/example.pl +++ b/raddb/mods-config/perl/example.pl @@ -188,13 +188,12 @@ sub xlat { my ($filename,$a,$b,$c,$d) = @_; radiusd::radlog(L_DBG, "From xlat $filename"); radiusd::radlog(L_DBG,"From xlat $a $b $c $d"); - local *FH; - open FH, $filename or die "open '$filename' $!"; + open(my $FH, '<', $filename) or die "open '$filename' $!"; local($/) = undef; - my $sub = ; - close FH; + my $sub = <$FH>; + close $FH; my $eval = qq{ sub handler{ $sub;} }; - eval $eval; + eval $eval; ## no critic eval {main->handler;}; } diff --git a/scripts/clients.pl b/scripts/clients.pl index 40ed5eebd5d..71621431523 100755 --- a/scripts/clients.pl +++ b/scripts/clients.pl @@ -9,6 +9,10 @@ # # $Id$ # + +use strict; +use warnings; + if (($#ARGV < 1) || ($#ARGV > 2)) { print "Usage: clients.pl clients [naslist] new-clients.conf\n"; print " The \"new-clients.conf\" will be created if it does not exist.\n"; @@ -16,53 +20,59 @@ if (($#ARGV < 1) || ($#ARGV > 2)) { exit(1); } -$old = shift; -$new = shift; +my $naslist; +my %clients; + +my $old = shift; +my $new = shift; if ($new =~ /naslist/) { $naslist = $new; $new = shift; } -open OLD, "< $old" or die "Failed to open $old: $!\n"; +open(my $OLD, "<", $old) or die "Failed to open $old: $!\n"; -while () { +while (<$OLD>) { next if (/^\s*\#/); next if (/^\s*$/); - split; + @_ = split; $clients{$_[0]}{"secret"} = $_[1]; } -close OLD; +close $OLD; if (defined $naslist) { - open OLD, "< $naslist" or die "Failed to open $naslist: $!\n"; + open(my $OLD, "<", $naslist) or die "Failed to open $naslist: $!\n"; - while () { - next if (/^\s*\#/); - next if (/^\s*$/); + while (<$OLD>) { + next if (/^\s*\#/); + next if (/^\s*$/); - split; + @_ = split; - if (!defined $clients{$_[0]}) { - print "WARNING! client $_[0] is defined in naslist, but not in clients!"; - next; - } + if (!defined $clients{$_[0]}) { + print "WARNING! client $_[0] is defined in naslist, but not in clients!"; + next; + } - $clients{$_[0]}{"shortname"} = $_[1]; - $clients{$_[0]}{"nas_type"} = $_[2]; + $clients{$_[0]}{"shortname"} = $_[1]; + $clients{$_[0]}{"nas_type"} = $_[2]; } + + close $OLD; } -open NEW, "> $new" or die "Failed to open $new: $!\n"; -foreach $client (keys %clients) { - print NEW "client $client {\n"; - print NEW "\tsecret = ", $clients{$client}{"secret"}, "\n"; +open(my $NEW, ">", $new) or die "Failed to open $new: $!\n"; +foreach my $client (keys %clients) { + print $NEW "client $client {\n"; + print $NEW "\tsecret = ", $clients{$client}{"secret"}, "\n"; if (defined $clients{$client}{"shortname"}) { - print NEW "\tshortname = ", $clients{$client}{"shortname"}, "\n"; - print NEW "\tnas_type = ", $clients{$client}{"nas_type"}, "\n"; + print $NEW "\tshortname = ", $clients{$client}{"shortname"}, "\n"; + print $NEW "\tnas_type = ", $clients{$client}{"nas_type"}, "\n"; } - print NEW "}\n"; - print NEW "\n"; + print $NEW "}\n"; + print $NEW "\n"; } +close $NEW; diff --git a/scripts/create-users.pl b/scripts/create-users.pl index 38128d5df13..1b045eba587 100755 --- a/scripts/create-users.pl +++ b/scripts/create-users.pl @@ -4,11 +4,17 @@ # for testing your radius server # Read doc/README.testing for more information -$passfile = "./passwd"; -$shadfile = "./shadow"; -$radfile = "./radius.test"; -$nocrypt = "./passwd.nocrypt"; -$users = "./radius.users"; +use strict; +use warnings; + +my $passfile = "./passwd"; +my $shadfile = "./shadow"; +my $radfile = "./radius.test"; +my $nocrypt = "./passwd.nocrypt"; +my $users = "./radius.users"; + +my $numusers; +my %userlist; if($ARGV[0] eq "") { print "\n\tUsage: $0 \n\n"; @@ -16,19 +22,20 @@ if($ARGV[0] eq "") { } else { $numusers = $ARGV[0]; } -$userlen = 6; -$passlen = 6; +my $userlen = 6; +my $passlen = 6; -open(PASS, ">$passfile") || die "Can't open $passfile"; -open(SHAD, ">$shadfile") || die "Can't open $shadfile"; -open(RAD, ">$radfile") || die "Can't open $radfile"; -open(NOCRYPT, ">$nocrypt") || die "Can't open $nocrypt"; -open(USERS, ">$users") || die "Can't open $users"; +open(my $PASS, ">", $passfile) || die "Can't open $passfile"; +open(my $SHAD, ">", $shadfile) || die "Can't open $shadfile"; +open(my $RAD, ">", $radfile) || die "Can't open $radfile"; +open(my $NOCRYPT, ">", $nocrypt) || die "Can't open $nocrypt"; +open(my $USERS, ">", $users) || die "Can't open $users"; -for ($num=0; $num<$numusers; $num++) { +for (my $num=0; $num<$numusers; $num++) { # generate username - $username = ""; - for($i=0; $i) { $line++; @@ -21,73 +31,75 @@ while (<>) { # Get attribute. # if (/^ATTRIBUTE\s+([\w-]+)\s+(\w+)\s+(\w+)(.*)/) { - $name=$1; - $value = $2; - $type = $3; - $stuff = $4; - - $value =~ tr/[A-F]/[a-f]/; # normal form for hex - $value =~ tr/X/x/; - - if ($value =~ /^0x/) { - $index = hex $value; - } else { - $index = $value; - } - - if (defined $attributes{$index}) { - $dup{$index}++; - } else { - $first_ref{$line} = $index; - } - - $attributes{$index} = "$name $value $type$stuff"; - $name2val{$name} = $index; - next; + my $name = $1; + my $value = $2; + my $type = $3; + my $stuff = $4; + + $value =~ tr/[A-F]/[a-f]/; # normal form for hex + $value =~ tr/X/x/; + + my $index; + if ($value =~ /^0x/) { + $index = hex $value; + } else { + $index = $value; + } + + if (defined $attributes{$index}) { + $dup{$index}++; + } else { + $first_ref{$line} = $index; + } + + $attributes{$index} = "$name $value $type$stuff"; + $name2val{$name} = $index; + next; } # # Values. # - if (/^VALUE\s+([\w-]+)\s+([\w-\/,.]+)\s+(\w+)(.*)/) { - $attr = $1; - $name = $2; - $value = $3; - $stuff = $d; - - $value =~ tr/[A-F]/[a-f]/; # normal form for hex - $value =~ tr/X/x/; - - if ($value =~ /^0x/) { - $index = hex $value; - } else { - $index = $value; - } - - if (!defined $name2val{$attr}) { - print "# FIXME: FORWARD REF?\nVALUE $attr $name $value$stuff\n"; - next; - } - - $values{$name2val{$attr}}{$index} = "$attr $name $value$stuff"; - next; + if (/^VALUE\s+([\w-]+)\s+([\w\/,.-]+)\s+(\w+)(.*)/) { + my $attr = $1; + my $name = $2; + my $value = $3; + my $stuff = $4; + + $value =~ tr/[A-F]/[a-f]/; # normal form for hex + $value =~ tr/X/x/; + + my $index; + if ($value =~ /^0x/) { + $index = hex $value; + } else { + $index = $value; + } + + if (!defined $name2val{$attr}) { + print "# FIXME: FORWARD REF?\nVALUE $attr $name $value$stuff\n"; + next; + } + + $values{$name2val{$attr}}{$index} = "$attr $name $value$stuff"; + next; } } # # Print out the attributes sorted by number. # -foreach $line (sort {$a <=> $b} keys %first_ref) { - $attr_val = $first_ref{$line}; +foreach my $line (sort {$a <=> $b} keys %first_ref) { + my $attr_val = $first_ref{$line}; next if (defined $dup{$attr_val}); print "ATTRIBUTE ", $attributes{$attr_val}, "\n"; - next if (!defined %{$values{$attr_val}}); + next if (!defined $values{$attr_val}); - foreach $value (sort {$a <=> $b} keys %{$values{$attr_val}}) { - print "VALUE ", $values{$attr_val}{$value}, "\n"; + foreach my $value (sort {$a <=> $b} keys %{$values{$attr_val}}) { + print "VALUE ", $values{$attr_val}{$value}, "\n"; } } diff --git a/scripts/dict/attrsort.pl b/scripts/dict/attrsort.pl index 8967259f766..4ffc4a60a42 100755 --- a/scripts/dict/attrsort.pl +++ b/scripts/dict/attrsort.pl @@ -11,77 +11,86 @@ # $Id$ # +use strict; +use warnings; + +my %attributes; +my %values; +my %name2val; + while (<>) { # # Get attribute. # if (/^ATTRIBUTE\s+([\w-]+)\s+(\w+)\s+(\w+)(.*)/) { - $name=$1; - $value = $2; - $type = $3; - $stuff = $4; - - $value =~ tr/[A-F]/[a-f]/; # normal form for hex - $value =~ tr/X/x/; - - if ($value =~ /^0x/) { - $index = hex $value; - } else { - $index = $value; - } - - $attributes{$index} = "$name $value $type$stuff"; - $name2val{$name} = $index; - next; + my $name=$1; + my $value = $2; + my $type = $3; + my $stuff = $4; + + $value =~ tr/[A-F]/[a-f]/; # normal form for hex + $value =~ tr/X/x/; + + my $index; + if ($value =~ /^0x/) { + $index = hex $value; + } else { + $index = $value; + } + + $attributes{$index} = "$name $value $type$stuff"; + $name2val{$name} = $index; + next; } # # Values. # - if (/^VALUE\s+([\w-]+)\s+([\w-\/,.]+)\s+(\w+)(.*)/) { - $attr = $1; - $name = $2; - $value = $3; - $stuff = $d; - - $value =~ tr/[A-F]/[a-f]/; # normal form for hex - $value =~ tr/X/x/; - - if ($value =~ /^0x/) { - $index = hex $value; - } else { - $index = $value; - } - - if (!defined $name2val{$attr}) { - print "# FIXME: FORWARD REF?\nVALUE $attr $name $value$stuff\n"; - next; - } - - $values{$name2val{$attr}}{$index} = "$attr $name $value$stuff"; - next; + if (/^VALUE\s+([\w-]+)\s+([\w\/,.-]+)\s+(\w+)(.*)/) { + my $attr = $1; + my $name = $2; + my $value = $3; + my $stuff = ''; + + $value =~ tr/[A-F]/[a-f]/; # normal form for hex + $value =~ tr/X/x/; + + my $index; + if ($value =~ /^0x/) { + $index = hex $value; + } else { + $index = $value; + } + + if (!defined $name2val{$attr}) { + print "# FIXME: FORWARD REF?\nVALUE $attr $name $value$stuff\n"; + next; + } + + $values{$name2val{$attr}}{$index} = "$attr $name $value$stuff"; + next; } } # # Print out the attributes sorted by number. # -foreach $attr_val (sort {$a <=> $b} keys %attributes) { +foreach my $attr_val (sort {$a <=> $b} keys %attributes) { print "ATTRIBUTE ", $attributes{$attr_val}, "\n"; } -foreach $value (sort {$a <=> $b} keys %values) { +foreach my $value (sort {$a <=> $b} keys %values) { print $value, "\t", $attributes{$value}, "\n"; } # # And again, this time printing out values. # -foreach $attr_val (sort {$a <=> $b} keys %attributes) { +foreach my $attr_val (sort {$a <=> $b} keys %attributes) { - next if (!defined %{$values{$attr_val}}); + next if (!defined $values{$attr_val}); - foreach $value (sort {$a <=> $b} keys %{$values{$attr_val}}) { - print "VALUE ", $values{$attr_val}{$value}, "\n"; + foreach my $value (sort {$a <=> $b} keys %{$values{$attr_val}}) { + print "VALUE ", $values{$attr_val}{$value}, "\n"; } } diff --git a/scripts/dict/backref.pl b/scripts/dict/backref.pl index 0630022ecff..9dfe20217a8 100755 --- a/scripts/dict/backref.pl +++ b/scripts/dict/backref.pl @@ -5,188 +5,201 @@ # $Id$ # -$begin_vendor = 0; -$blank = 0; +use strict; +use warnings; + +my %file; +my %name; while (@ARGV) { - $filename = shift; - - open FILE, "<$filename" or die "Failed to open $filename: $!\n"; - - @output = (); - - while () { - # - # Clear out trailing whitespace - # - s/[ \t]+$//; - - # - # And CR's - # - s/\r//g; - - # - # Suppress multiple blank lines - # - if (/^\s+$/) { - next if ($blank == 1); - $blank = 1; - next; - } - $blank = 0; - - # - # Remember the vendor - # - if (/^VENDOR\s+([\w-]+)\s+(\w+)(.*)/) { - $name=$1; - $len = length $name; - if ($len < 32) { - $lenx = 32 - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - $tabs = "\t" x $lenx; - } else { - $tabs = " "; - } - $vendor = $name; - next; - } - - # - # Remember if we did begin-vendor. - # - if (/^BEGIN-VENDOR\s+([\w-]+)/) { - $begin_vendor = 1; - if (!defined $vendor) { - $vendor = $1; - } elsif ($vendor ne $1) { - # do something smart - } - - next; - } - - # - # Get attribute. - # - if (/^ATTRIBUTE\s+([\w-]+)\s+(\w+)\s+(\w+)(.*)/) { - $name=$1; - $len = length $name; - if ($len < 40) { - $lenx = 40 - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - $tabs = "\t" x $lenx; - if ($tabs eq "") { - $tabs = " "; - } - } else { - $tabs = " "; - } - - $value = $2; - $type = $3; - $stuff = $4; - - if ($begin_vendor == 0) { - # - # FIXME: Catch and print conflicting attributes. - # - $file{$value} = $filename; - $file{$value} =~ s/dictionary\.//; - $name{$value} = $name . $tabs; - } - - # - # See if it's old format, with the vendor at the end of - # the line. If so, make it the new format. - # - if ($stuff =~ /$vendor/) { - if ($begin_vendor == 0) { - $begin_vendor = 1; - } - $stuff =~ s/$vendor//; - $stuff =~ s/\s+$//; - } - - next; - } - - # - # Values. - # - if (/^VALUE\s+([\w-]+)\s+([\w-\/,.]+)\s+(\w+)(.*)/) { - $attr=$1; - $len = length $attr; - if ($len < 32) { - $lenx = 32 - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - $tabsa = "\t" x $lenx; - if ($tabsa eq "") { - $tabsa = " "; - $len += 1; - } else { - $len -= $len % 8; - $len += 8 * length $tabsa; - } - } else { - $tabsa = " "; - $len += 1; - } - - # - # For the code below, we assume that the attribute lengths - # - if ($len < 32) { - $lena = 0; - } else { - $lena = $len - 32; - } - - $name = $2; - $len = length $name; - if ($len < 24) { - $lenx = 24 - $lena - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - $tabsn = "\t" x $lenx; - if ($tabsn eq "") { - $tabsn = " "; - } - } else { - $tabsn = " "; - } - - next; - } - - # - # Remember if we did this. - # - if (/^END-VENDOR/) { - $begin_vendor = 0; - } - - # - # Everything else gets dumped out as-is. - # + my $filename = shift; + + open(my $FILE, "<", $filename) or die "Failed to open $filename: $!\n"; + + my @output = (); + + my $begin_vendor = 0; + my $blank = 0; + my $vendor; + my $tabsa; + my $tabsn; + + while (<$FILE>) { + + # + # Clear out trailing whitespace + # + s/[ \t]+$//; + + # + # And CR's + # + s/\r//g; + + # + # Suppress multiple blank lines + # + if (/^\s+$/) { + next if ($blank == 1); + $blank = 1; + next; + } + $blank = 0; + + # + # Remember the vendor + # + if (/^VENDOR\s+([\w-]+)\s+(\w+)(.*)/) { + my $name=$1; + my $len = length $name; + my $tabs; + if ($len < 32) { + my $lenx = 32 - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + $tabs = "\t" x $lenx; + } else { + $tabs = " "; + } + $vendor = $name; + next; + } + + # + # Remember if we did begin-vendor. + # + if (/^BEGIN-VENDOR\s+([\w-]+)/) { + $begin_vendor = 1; + if (!defined $vendor) { + $vendor = $1; + } elsif ($vendor ne $1) { + # do something smart + } + + next; + } + + # + # Get attribute. + # + if (/^ATTRIBUTE\s+([\w-]+)\s+(\w+)\s+(\w+)(.*)/) { + my $name=$1; + my $len = length $name; + my $tabs; + if ($len < 40) { + my $lenx = 40 - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + $tabs = "\t" x $lenx; + if ($tabs eq "") { + $tabs = " "; + } + } else { + $tabs = " "; + } + + my $value = $2; + my $type = $3; + my $stuff = $4; + + if ($begin_vendor == 0) { + # + # FIXME: Catch and print conflicting attributes. + # + $file{$value} = $filename; + $file{$value} =~ s/dictionary\.//; + $name{$value} = $name . $tabs; + } + + # + # See if it's old format, with the vendor at the end of + # the line. If so, make it the new format. + # + if (defined $vendor && $stuff =~ /$vendor/) { + if ($begin_vendor == 0) { + $begin_vendor = 1; + } + $stuff =~ s/$vendor//; + $stuff =~ s/\s+$//; + } + + next; + } + + # + # Values. + # + if (/^VALUE\s+([\w-]+)\s+([\w\/,.-]+)\s+(\w+)(.*)/) { + my $attr=$1; + my $len = length $attr; + if ($len < 32) { + my $lenx = 32 - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + $tabsa = "\t" x $lenx; + if ($tabsa eq "") { + $tabsa = " "; + $len += 1; + } else { + $len -= $len % 8; + $len += 8 * length $tabsa; + } + } else { + $tabsa = " "; + $len += 1; + } + + # + # For the code below, we assume that the attribute lengths + # + my $lena; + if ($len < 32) { + $lena = 0; + } else { + $lena = $len - 32; + } + + my $name = $2; + $len = length $name; + if ($len < 24) { + my $lenx = 24 - $lena - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + $tabsn = "\t" x $lenx; + if ($tabsn eq "") { + $tabsn = " "; + } + } else { + $tabsn = " "; + } + + next; + } + + # + # Remember if we did this. + # + if (/^END-VENDOR/) { + $begin_vendor = 0; + } + + # + # Everything else gets dumped out as-is. + # } - close FILE; + close $FILE; } # # Print out the attributes. # -foreach $attr (sort {$a <=> $b} keys %file) { +foreach my $attr (sort {$a <=> $b} keys %file) { print $name{$attr}, $attr, "\t", $file{$attr}, "\n"; } diff --git a/scripts/dict/dct2fr b/scripts/dict/dct2fr index e61fb83b24a..6f3ce797b68 100755 --- a/scripts/dict/dct2fr +++ b/scripts/dict/dct2fr @@ -12,6 +12,12 @@ # ./format.pl dictionary.foo # +use strict; +use warnings; + +my $name; +my $vendor; + while (<>) { if (/^MACRO\s+([^ \t\(]+)\(t,s\)\s+26\s+\[vid=(\d+)\s+type1=\%t\%\s+len1=\+2\s+data=\%s\%/) { $name = $1; diff --git a/scripts/dict/format.pl b/scripts/dict/format.pl index 5d438df72bb..316a83bd0d6 100755 --- a/scripts/dict/format.pl +++ b/scripts/dict/format.pl @@ -34,33 +34,32 @@ # $Id$ # -$begin_vendor = 0; -$blank = 0; -$previous = ""; - +use strict; +use warnings; sub tabs { - my $width = shift; - my $name = shift; - my $len, $lenx; + my $width = shift; + my $name = shift; + my $len; + my $lenx; - $len = length $name; + $len = length $name; - return " " if ($len >= $width); + return " " if ($len >= $width); - $lenx = $width - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - return "\t" x $lenx; + $lenx = $width - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + return "\t" x $lenx; } while (@ARGV) { - $filename = shift; + my $filename = shift; - open FILE, "<$filename" or die "Failed to open $filename: $!\n"; + open(my $FILE, "<", $filename) or die "Failed to open $filename: $!\n"; - @output = (); + my @output = (); my $year = 1900 + (localtime)[5]; @@ -76,324 +75,327 @@ while (@ARGV) { # push @output, "# Version \$", "Id: ", "\$\n"; - - while () { - # - # Suppress any existing header - # - next if (/^# -\*- text/); - next if (/^# Copyright/); - next if (/^# This work is licensed/); - next if (/^# Version \$/); - - # - # Clear out trailing whitespace - # - s/[ \t]+$//; - - # - # And CR's - # - s/\r//g; - - # - # Suppress multiple blank lines - # - if (/^\s+$/) { - next if ($blank == 1); - $blank = 1; - push @output, "\n"; - next; - } - $blank = 0; - - s/\s*$/\n/; - - # - # Suppress leading whitespace, so long as it's - # not followed by a comment.. - # - s/^\s*([^#])/$1/; - - # - # Not an ATTRIBUTE? Suppress "previous" checks. - # - if (!/^ATTRIBUTE/) { - $previous = ""; - } - - # - # Remember the protocol - # - if (/^PROTOCOL\s+([-\w]+)\s+(\w+)\s+(.*)/) { - $name=$1; - $format = $3; - $tabs = tabs(16, $name); - - $format = "\t$format" if ($format); - - push @output, "PROTOCOL\t$name$tabs$2$format\n"; - next; - } - - # - # Remember the vendor - # - if (/^VENDOR\s+([-\w]+)\s+(\w+)(.*)/) { - $name=$1; - $tabs = tabs(32, $name); - - push @output, "VENDOR\t\t$name$tabs$2$3\n"; - $vendor = $name; - next; - } - - # - # Remember if we did BEGIN-VENDOR format= - # - if (/^BEGIN-VENDOR\s+([-\w]+)\s+(format=[-\w]+)/) { - $begin_vendor = 1; - if (!defined $vendor) { - $vendor = $1; - } elsif ($vendor ne $1) { - # do something smart - } - - push @output, "BEGIN-VENDOR\t$vendor $2\n"; - next; - } - - # - # Or just a plain BEGIN-VENDOR - # - if (/^BEGIN-VENDOR\s+([-\w]+)/) { - $begin_vendor = 1; - if (!defined $vendor) { - $vendor = $1; - } elsif ($vendor ne $1) { - # do something smart - } - - push @output, "BEGIN-VENDOR\t$vendor\n"; - next; - } - - # - # Get attribute. - # - if (/^ATTRIBUTE\s+([-\w]+)\s+([\w.]+)\s+(\w+)(.*)/) { - $name=$1; - $tabs = tabs(40, $name); - - $value = $2; - $type = $3; - $stuff = $4; - - # - # See if it's old format, with the vendor at the end of - # the line. If so, make it the new format. - # - if ($stuff =~ /$vendor/) { - if ($begin_vendor == 0) { - push @output, "BEGIN-VENDOR\t$vendor\n\n"; - $begin_vendor = 1; - } - $stuff =~ s/$vendor//; - $stuff =~ s/\s+$//; - } - - # - # The numerical value doesn't start with ".". - # - # If the current attribute is a child of the previous - # one, then just print out the child values. - # - # Otherwise, remember this attribute as the new "previous" - # - if ($value !~ /^\./) { - if ($value =~ /^$previous(\..+)$/) { - $value = $1; - } else { - $previous = $value; - } - } - - push @output, "ATTRIBUTE\t$name$tabs$value\t$type$stuff\n"; - next; - } - - # - # Get MEMBER - # - if (/^MEMBER\s+([-\w]+)\s+(\w+)(.*)/) { - $name=$1; - $tabs = tabs(40, $name); - - $type = $2; - $stuff = $3; - - push @output, "MEMBER\t\t$name$tabs$type$stuff\n"; - next; - } - - # - # STRUCT name attr value - # - if (/^STRUCT\s+([-\w]+)\s+([-\w\/,.]+)\s+(\w+)(.*)/) { - $attr=$2; - $len = length $attr; - - - if ($len < 32) { - $lenx = 32 - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - $tabsa = "\t" x $lenx; - if ($tabsa eq "") { - $tabsa = " "; - $len += 1; - } else { - $len -= $len % 8; - $len += 8 * length $tabsa; - } - } else { - $tabsa = " "; - $len += 1; - } - - # - # For the code below, we assume that the attribute lengths - # - if ($len < 32) { - $lena = 0; - } else { - $lena = $len - 32; - } - - $name = $1; - $len = length $name; - if ($len < 24) { - $lenx = 24 - $lena - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - $tabsn = "\t" x $lenx; - if ($tabsn eq "") { - $tabsn = " "; - } - } else { - $tabsn = " "; - } - - push @output, "STRUCT\t$name$tabsa$attr$tabsn$3$4\n"; - next; - } - - # - # Get ALIAS - # - if (/^ALIAS\s+([-\w]+)\s+(\w+)(.*)/) { - $name=$1; - $tabs = tabs(40, $name); - - $ref = $2; - $stuff = $3; - - push @output, "ALIAS\t\t$name$tabs$ref$stuff\n"; - next; - } - - # - # VALUE attr name value - # - if (/^VALUE\s+([-\w]+)\s+([-\w\/,.]+)\s+(\w+)(.*)/) { - $attr=$1; - $len = length $attr; - - - if ($len < 32) { - $lenx = 32 - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - $tabsa = "\t" x $lenx; - if ($tabsa eq "") { - $tabsa = " "; - $len += 1; - } else { - $len -= $len % 8; - $len += 8 * length $tabsa; - } - } else { - $tabsa = " "; - $len += 1; - } - - # - # For the code below, we assume that the attribute lengths - # - if ($len < 32) { - $lena = 0; - } else { - $lena = $len - 32; - } - - $name = $2; - $len = length $name; - if ($len < 24) { - $lenx = 24 - $lena - $len; - $lenx += 7; # round up - $lenx /= 8; - $lenx = int $lenx; - $tabsn = "\t" x $lenx; - if ($tabsn eq "") { - $tabsn = " "; - } - } else { - $tabsn = " "; - } - - push @output, "VALUE\t$attr$tabsa$name$tabsn$3$4\n"; - next; - } - - # - # Get flags. - # - if (/^FLAGS\s+([!-\w]+)\s+(.*)/) { - $name=$1; - $tabs = tabs(40, $name); - - push @output, "FLAGS\t$name$2\n"; - next; - } - - # - # Remember if we did this. - # - if (/^END-VENDOR/) { - $begin_vendor = 0; - } - - # - # Everything else gets dumped out as-is. - # - push @output, $_; + my $begin_vendor = 0; + my $blank = 0; + my $previous = ""; + my $vendor; + my $tabsa; + my $tabsn; + + while (<$FILE>) { + # + # Suppress any existing header + # + next if (/^# -\*- text/); + next if (/^# Copyright/); + next if (/^# This work is licensed/); + next if (/^# Version \$/); + + # + # Clear out trailing whitespace + # + s/[ \t]+$//; + + # + # And CR's + # + s/\r//g; + + # + # Suppress multiple blank lines + # + if (/^\s+$/) { + next if ($blank == 1); + $blank = 1; + push @output, "\n"; + next; + } + $blank = 0; + + s/\s*$/\n/; + + # + # Suppress leading whitespace, so long as it's + # not followed by a comment.. + # + s/^\s*([^#])/$1/; + + # + # Not an ATTRIBUTE? Suppress "previous" checks. + # + if (!/^ATTRIBUTE/) { + $previous = ""; + } + + # + # Remember the protocol + # + if (/^PROTOCOL\s+([-\w]+)\s+(\w+)\s+(.*)/) { + my $name = $1; + my $format = $3; + my $tabs = tabs(16, $name); + + $format = "\t$format" if ($format); + + push @output, "PROTOCOL\t$name$tabs$2$format\n"; + next; + } + + # + # Remember the vendor + # + if (/^VENDOR\s+([-\w]+)\s+(\w+)(.*)/) { + my $name = $1; + my $tabs = tabs(32, $name); + + push @output, "VENDOR\t\t$name$tabs$2$3\n"; + $vendor = $name; + next; + } + + # + # Remember if we did BEGIN-VENDOR format= + # + if (/^BEGIN-VENDOR\s+([-\w]+)\s+(format=[-\w]+)/) { + $begin_vendor = 1; + if (!defined $vendor) { + $vendor = $1; + } elsif ($vendor ne $1) { + # do something smart + } + + push @output, "BEGIN-VENDOR\t$vendor $2\n"; + next; + } + + # + # Or just a plain BEGIN-VENDOR + # + if (/^BEGIN-VENDOR\s+([-\w]+)/) { + $begin_vendor = 1; + if (!defined $vendor) { + $vendor = $1; + } elsif ($vendor ne $1) { + # do something smart + } + + push @output, "BEGIN-VENDOR\t$vendor\n"; + next; + } + + # + # Get attribute. + # + if (/^ATTRIBUTE\s+([-\w]+)\s+([\w.]+)\s+(\w+)(.*)/) { + my $name = $1; + my $tabs = tabs(40, $name); + + my $value = $2; + my $type = $3; + my $stuff = $4; + + # + # See if it's old format, with the vendor at the end of + # the line. If so, make it the new format. + # + if (defined $vendor && $stuff =~ /$vendor/) { + if ($begin_vendor == 0) { + push @output, "BEGIN-VENDOR\t$vendor\n\n"; + $begin_vendor = 1; + } + $stuff =~ s/$vendor//; + $stuff =~ s/\s+$//; + } + + # + # The numerical value doesn't start with ".". + # + # If the current attribute is a child of the previous + # one, then just print out the child values. + # + # Otherwise, remember this attribute as the new "previous" + # + if ($value !~ /^\./) { + if ($value =~ /^$previous(\..+)$/) { + $value = $1; + } else { + $previous = $value; + } + } + + push @output, "ATTRIBUTE\t$name$tabs$value\t$type$stuff\n"; + next; + } + + # + # Get MEMBER + # + if (/^MEMBER\s+([-\w]+)\s+(\w+)(.*)/) { + my $name = $1; + my $tabs = tabs(40, $name); + + my $type = $2; + my $stuff = $3; + + push @output, "MEMBER\t\t$name$tabs$type$stuff\n"; + next; + } + + # + # STRUCT name attr value + # + if (/^STRUCT\s+([-\w]+)\s+([-\w\/,.]+)\s+(\w+)(.*)/) { + my $attr = $2; + my $len = length $attr; + + if ($len < 32) { + my $lenx = 32 - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + $tabsa = "\t" x $lenx; + if ($tabsa eq "") { + $tabsa = " "; + $len += 1; + } else { + $len -= $len % 8; + $len += 8 * length $tabsa; + } + } else { + $tabsa = " "; + $len += 1; + } + + # + # For the code below, we assume that the attribute lengths + # + my $lena; + if ($len < 32) { + $lena = 0; + } else { + $lena = $len - 32; + } + + my $name = $1; + $len = length $name; + if ($len < 24) { + my $lenx = 24 - $lena - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + $tabsn = "\t" x $lenx; + if ($tabsn eq "") { + $tabsn = " "; + } + } else { + $tabsn = " "; + } + + push @output, "STRUCT\t$name$tabsa$attr$tabsn$3$4\n"; + next; + } + + # + # Get ALIAS + # + if (/^ALIAS\s+([-\w]+)\s+(\w+)(.*)/) { + my $name = $1; + my $tabs = tabs(40, $name); + + my $ref = $2; + my $stuff = $3; + + push @output, "ALIAS\t\t$name$tabs$ref$stuff\n"; + next; + } + + # + # VALUE attr name value + # + if (/^VALUE\s+([-\w]+)\s+([-\w\/,.]+)\s+(\w+)(.*)/) { + my $attr = $1; + my $len = length $attr; + + if ($len < 32) { + my $lenx = 32 - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + $tabsa = "\t" x $lenx; + if ($tabsa eq "") { + $tabsa = " "; + $len += 1; + } else { + $len -= $len % 8; + $len += 8 * length $tabsa; + } + } else { + $tabsa = " "; + $len += 1; + } + + # + # For the code below, we assume that the attribute lengths + # + my $lena; + if ($len < 32) { + $lena = 0; + } else { + $lena = $len - 32; + } + + my $name = $2; + $len = length $name; + if ($len < 24) { + my $lenx = 24 - $lena - $len; + $lenx += 7; # round up + $lenx /= 8; + $lenx = int $lenx; + $tabsn = "\t" x $lenx; + if ($tabsn eq "") { + $tabsn = " "; + } + } else { + $tabsn = " "; + } + + push @output, "VALUE\t$attr$tabsa$name$tabsn$3$4\n"; + next; + } + + # + # Get flags. + # + if (/^FLAGS\s+([!\w-]+)\s+(.*)/) { + my $name = $1; + + push @output, "FLAGS\t$name$2\n"; + next; + } + + # + # Remember if we did this. + # + if (/^END-VENDOR/) { + $begin_vendor = 0; + } + + # + # Everything else gets dumped out as-is. + # + push @output, $_; } # # If we changed the format, print the end vendor, too. # if ($begin_vendor) { - push @output, "\nEND-VENDOR\t$vendor\n"; + push @output, "\nEND-VENDOR\t$vendor\n"; } - close FILE; - - open FILE, ">$filename" or die "Failed to open $filename: $!\n"; - - print FILE @output; + close $FILE; - close FILE; + open($FILE, ">", $filename) or die "Failed to open $filename: $!\n"; + print $FILE @output; + close $FILE; } diff --git a/scripts/ldap/radiusd2ldif.pl b/scripts/ldap/radiusd2ldif.pl index 4dbd04f7e2e..14847517eb5 100755 --- a/scripts/ldap/radiusd2ldif.pl +++ b/scripts/ldap/radiusd2ldif.pl @@ -1,5 +1,8 @@ #!/usr/bin/perl +use strict; +use warnings; + # radius2ldif.pl # # To test this program, do the following @@ -68,11 +71,13 @@ # -p : give only password # -m : set entry to modify ldap attributes # -f : read encrypted passwords from file + +our ($opt_d, $opt_p, $opt_m, $opt_f); use Getopt::Std; getopts('dpmf:'); -$debug = $opt_d; +my $debug = $opt_d; -%passwords; +my %passwords; # This might or might not be necessary depending if your LDAP server # when importing from ldif introduces crypted passwords in the LDAP db # (not necessary for Netscape's Directory Server) @@ -80,18 +85,18 @@ read_passwds ($opt_f) if $opt_f; # USER CONFIGURATION # ------------------ -$usermatch = ".*"; # only add users matching this +my $usermatch = ".*"; # only add users matching this # WARNING: in order to add *all* users set this to ".*" NOT "" # LDAP configuration -$domain = "o=icm.es"; -$basedn = ", ou=Hardware, ou=EDUCAMADRID, ou=People, $domain"; -$predn = "dn: cn="; -$uniquemembers = 1; -$groupname = "RadiusUser"; # group to add in the LDAP, if null will not add -$group = "\n\ndn: ou=$groupname, ou=Groups, $domain"; +my $domain = "o=icm.es"; +my $basedn = ", ou=Hardware, ou=EDUCAMADRID, ou=People, $domain"; +my $predn = "dn: cn="; +my $uniquemembers = 1; +my $groupname = "RadiusUser"; # group to add in the LDAP, if null will not add +my $group = "\n\ndn: ou=$groupname, ou=Groups, $domain"; # Only useful for adding the group (not yet implemented) -$addgroup = $group."\ndescription: $groupname\nobjectclass: top"; +my $addgroup = $group."\ndescription: $groupname\nobjectclass: top"; if ( $uniquemembers ) { $addgroup = $addgroup."\nobjectclass: groupOfUniqueNames"; } else { @@ -107,7 +112,7 @@ $addgroup = $addgroup."\ncn: $groupname"; # (or objectclass=groupOfNames) #cn=$group # Required: person (for userpasswords) and radiusprofile ( 5 February 1998) -@objectClass = ( "top", "person" , "radiusprofile" ); +my @objectClass = ( "top", "person" , "radiusprofile" ); # Mapping of entries (use lower case so no check needs to be make) @@ -154,6 +159,7 @@ $addgroup = $addgroup."\ncn: $groupname"; # However NDS does the cyphering even if sending plain passwords # (do all LDAP's do this?) # TODO: test with OpenLDAP +my %mapping; $mapping{'password'} = "userpassword"; $mapping{'service-type'} = "radiusServiceType"; $mapping{'framed-protocol'} = "radiusFramedProtocol"; @@ -200,10 +206,13 @@ $mapping{'callback_number'} = "radiusCallbackNumber"; # Footer of ldif entries -$footer = "\n\n"; -$startentry = 0; +my $header; +my $footer = "\n\n"; +my $startentry = 0; + +my @userlist; -while ($line=) { +while (my $line=) { chomp $line; if ( $line =~ /^[\s\t]*$/ && $startentry) { $startentry = 0 ; @@ -211,13 +220,15 @@ while ($line=) { } # Start line is hardcoded must be uid followed by password # this could be changed to use any other parameter however + my $uid; + my $password; if ( $line =~ /^(\w+)\s*\t*(?:User-)?Password=(\w+)/ ) { $uid = $1; $password= $2; $password = $passwords{$password} if $opt_f; if ( $uid =~ /$usermatch/ ) { $startentry = 1; - $dn=$predn.$uid.$basedn; # Start of LDIF entry + my $dn=$predn.$uid.$basedn; # Start of LDIF entry $header = "$dn\n"; push @userlist, $dn; if ( $opt_m ) { @@ -244,8 +255,8 @@ while ($line=) { #Take anything that starts with a tab or spaces # and ends (sometimes) with a comma if ( $line =~ /^[\t\s]+(.*?)\s+=\s+(.*?),*$/ ) { - $parameter = lc $1; - $value = $2; + my $parameter = lc $1; + my $value = $2; print "DEBUG: Got :$parameter=$value\n" if $debug; if ( defined $mapping{$parameter} && $mapping{$parameter} ne "" ) { print_entry ($mapping{$parameter},$value); @@ -268,8 +279,8 @@ if ( $group ) { print "\n\n$group\n"; print "changetype: modify\n" ; } - foreach $user ( @userlist ) { - $member = "member: "; + foreach my $user ( @userlist ) { + my $member = "member: "; $member = "uniquemember: " if $uniquemembers; print "$member$user\n"; } @@ -282,15 +293,15 @@ sub read_passwds { # version, the file must be of the following format: # password cryptedversion my ($file)=@_; - open (PASSWD,"< $file") or die ("Could not open $file: $!\n"); + open (my $PASSWD,"<",$file) or die ("Could not open $file: $!\n"); - while ($line = ) { + while (my $line = <$PASSWD>) { chomp $line; if ( $line =~ /^(\w+)[\t\s]+(.*?)$/ ) { $passwords{$1}=$2; } } - close PASSWD; + close $PASSWD; return 0; } diff --git a/scripts/min-includes.pl b/scripts/min-includes.pl index c29173ad552..9f0d7a358ba 100755 --- a/scripts/min-includes.pl +++ b/scripts/min-includes.pl @@ -34,44 +34,55 @@ # ###################################################################### +use strict; +use warnings; + my %processed; -$any_dups = 0; -$debug = 0; +my $any_dups = 0; +my $debug = 0; + +my %refs; +my %include; +my %maps; +my %forward; +my %reverse; +my %duplicate; +my %delete_line; # # Find the #include's for one file. # -sub process($) { +sub process { my $file = shift; return if ($processed{$file}); $processed{$file}++; - open FILE, "<$file" or die "Failed to open $file: $!\n"; + open(my $FILE, "<", $file) or die "Failed to open $file: $!\n"; - $line = 0; - while () { - $line++; + my $line = 0; + while (<$FILE>) { + $line++; - next if (!/^\s*\#\s*include\s+/); + next if (!/^\s*\#\s*include\s+/); - if (/^\s*\#\s*include\s+"(.+?)"/) { - $refs{$file}{$1} = $line; + if (/^\s*\#\s*include\s+"(.+?)"/) { + $refs{$file}{$1} = $line; - # FIXME: local header files? - # src/foo/bar.c: #include "foo.h" - # src/foo/foo.h do stuff.. + # FIXME: local header files? + # src/foo/bar.c: #include "foo.h" + # src/foo/foo.h do stuff.. - $include{$1}++; - } elsif (/^\s*\#\s*include\s+<(.+?)>/) { - $refs{$file}{$1} = $line; - $include{$1}++; - } + $include{$1}++; + } elsif (/^\s*\#\s*include\s+<(.+?)>/) { + $refs{$file}{$1} = $line; + $include{$1}++; + } } - close FILE; + close $FILE; } # @@ -79,8 +90,8 @@ sub process($) { # # FIXME: # -@directories = ("src/lib", "src"); -$do_it = 0; +my @directories = ("src/lib", "src"); +my $do_it = 0; # # Horrid. @@ -93,7 +104,7 @@ if ($ARGV[0] eq "+n") { # # Bootstrap the basic C files. # -foreach $file (@ARGV) { +foreach my $file (@ARGV) { process($file); } @@ -104,30 +115,30 @@ foreach $file (@ARGV) { # than walking over %include, because the process() function adds # entries to the %include hash. # -@work = sort keys %include; -foreach $inc (@work) { +my @work = sort keys %include; +foreach my $inc (@work) { - foreach $dir (@directories) { - $path = $dir . "/" . $inc; + foreach my $dir (@directories) { + my $path = $dir . "/" . $inc; - # normalize path - $path =~ s:/.*?/\.\.::; - $path =~ s:/.*?/\.\.::; + # normalize path + $path =~ s:/.*?/\.\.::; + $path =~ s:/.*?/\.\.::; - next if (! -e $path); - process($path); - $forward{$inc} = $path; - $reverse{$path} = $inc; + next if (! -e $path); + process($path); + $forward{$inc} = $path; + $reverse{$path} = $inc; - # ignore system include files - next if ((scalar keys %{$refs{$path}}) == 0); + # ignore system include files + next if ((scalar keys %{$refs{$path}}) == 0); - # Remember that X includes Y, and push Y onto the list - # of files to scan. - foreach $inc2 (sort keys %{$refs{$path}}) { - $maps{$inc}{$inc2} = 0; - push @work, $inc2; - } + # Remember that X includes Y, and push Y onto the list + # of files to scan. + foreach my $inc2 (sort keys %{$refs{$path}}) { + $maps{$inc}{$inc2} = 0; + push @work, $inc2; + } } } @@ -138,14 +149,14 @@ foreach $inc (@work) { # This doesn't find the shortest path from A to B, but it does # find one path. # -foreach $inc (sort keys %maps) { - foreach $inc2 (sort keys %{$maps{$inc}}) { - foreach $inc3 (sort keys %{$maps{$inc2}}) { - # map is already there... - next if (defined $maps{$inc}{$inc3}); +foreach my $inc (sort keys %maps) { + foreach my $inc2 (sort keys %{$maps{$inc}}) { + foreach my $inc3 (sort keys %{$maps{$inc2}}) { + # map is already there... + next if (defined $maps{$inc}{$inc3}); - $maps{$inc}{$inc3} = $maps{$inc2}{$inc3} + 1; - } + $maps{$inc}{$inc3} = $maps{$inc2}{$inc3} + 1; + } } } @@ -153,43 +164,43 @@ foreach $inc (sort keys %maps) { # Walk through the files again, looking for includes that are # unnecessary. Note that we process header files, too. # -foreach $file (sort keys %refs) { +foreach my $file (sort keys %refs) { # print out some debugging information. if ($debug > 0) { - if (defined $reverse{$file}) { - print $file, "\t(", $reverse{$file}, ")\n"; - } else { - print $file, "\n"; - } + if (defined $reverse{$file}) { + print $file, "\t(", $reverse{$file}, ")\n"; + } else { + print $file, "\n"; + } } # walk of the list of include's in this file - foreach $ref (sort keys %{$refs{$file}}) { - - # walk over the include files we include, or included by - # files that we include. - foreach $inc2 (sort keys %{$maps{$ref}}) { - # - # If we include X, and X includes Y, and we include - # Y ourselves *after* X, it's a definite dupe. - # - # Note that this is a *guaranteed* duplicate. - # - # Sometimes order matters, so we can't always delete X if - # we include Y after X, and Y includes X - # - if (defined $refs{$file}{$inc2} && - ($refs{$file}{$inc2} > $refs{$file}{$ref})) { - $duplicate{$file}{$inc2} = $ref; - - # mark the line to be deleted. - $delete_line{$file}{$refs{$file}{$inc2}}++; - - $any_dups++; - } - } - print "\t", $ref, "\n" if ($debug > 0); + foreach my $ref (sort keys %{$refs{$file}}) { + + # walk over the include files we include, or included by + # files that we include. + foreach my $inc2 (sort keys %{$maps{$ref}}) { + # + # If we include X, and X includes Y, and we include + # Y ourselves *after* X, it's a definite dupe. + # + # Note that this is a *guaranteed* duplicate. + # + # Sometimes order matters, so we can't always delete X if + # we include Y after X, and Y includes X + # + if (defined $refs{$file}{$inc2} && + ($refs{$file}{$inc2} > $refs{$file}{$ref})) { + $duplicate{$file}{$inc2} = $ref; + + # mark the line to be deleted. + $delete_line{$file}{$refs{$file}{$inc2}}++; + + $any_dups++; + } + } + print "\t", $ref, "\n" if ($debug > 0); } } @@ -201,29 +212,32 @@ if ($debug > 0) { # Maybe just print out the dups so that a person can validate them. # if (!$do_it) { - foreach $file (sort keys %duplicate) { - print $file, "\n"; + foreach my $file (sort keys %duplicate) { + print $file, "\n"; - foreach $inc (sort keys %{$duplicate{$file}}) { - print "\t[", $refs{$file}{$inc}, "] ", $inc, " (", $duplicate{$file}{$inc}, " at ", $refs{$file}{$duplicate{$file}{$inc}}, ")\n"; - } + foreach my $inc (sort keys %{$duplicate{$file}}) { + print "\t[", $refs{$file}{$inc}, "] ", $inc, " (", $duplicate{$file}{$inc}, " at ", $refs{$file}{$duplicate{$file}{$inc}}, ")\n"; + } } } else { - foreach $file (sort keys %duplicate) { - open FILE, "<$file" or die "Failed to open $file: $!\n"; - open OUTPUT, ">$file.tmp" or die "Failed to create $file.tmp: $!\n"; + foreach my $file (sort keys %duplicate) { + open(my $FILE, "<", $file) or die "Failed to open $file: $!\n"; + open(my $OUTPUT, ">", "$file.tmp") or die "Failed to create $file.tmp: $!\n"; + + my $line = 0; + while (<$FILE>) { + $line++; - $line = 0; - while () { - $line++; + # supposed to delete this line, don't print it to the output. + next if (defined $delete_line{$file}{$line}); - # supposed to delete this line, don't print it to the output. - next if (defined $delete_line{$file}{$line}); + print $OUTPUT $_; + } - print OUTPUT; - } + close $OUTPUT; + close $FILE; - rename "$file.tmp", $file; + rename "$file.tmp", $file; } } diff --git a/scripts/snmp-proxy/freeradius-snmp.pl b/scripts/snmp-proxy/freeradius-snmp.pl index b650151435d..50aa59cc726 100644 --- a/scripts/snmp-proxy/freeradius-snmp.pl +++ b/scripts/snmp-proxy/freeradius-snmp.pl @@ -132,7 +132,7 @@ sub radius_stats_get { }else { warn "no answer, $!\n"; - return undef; + return; } } diff --git a/scripts/sql/users2mysql.pl b/scripts/sql/users2mysql.pl index abaa9c09f30..34d257ba428 100644 --- a/scripts/sql/users2mysql.pl +++ b/scripts/sql/users2mysql.pl @@ -9,49 +9,49 @@ # last change: Aug 8th, 2002. # - +use strict; #Modify to suit your db. -$database="radius"; -$hostname="localhost"; -$user="radius"; -$password="passwd"; +my $db="radius"; +my $hostname="localhost"; +my $user="radius"; +my $password="passwd"; #location of source users file: -$users_file="/etc/raddb_cistron_backup/users"; +my $users_file="/etc/raddb_cistron_backup/users"; #The following are defaults from freeradius 0.7 # ...shouldn't have to change. -$groups_table="usergroup"; -$check_table="radcheck"; -$reply_table="radreply"; +my $groups_table="usergroup"; +my $check_table="radcheck"; +my $reply_table="radreply"; -$debug=3; +my $debug=3; use DBD::mysql; #open the users file, and the db. -open USERS, $users_file or die "ERROR: Unable to open $users_file $!\n"; -$database = DBI->connect("DBI:mysql:$database:$hostname",$user, $password) or die "ERROR: Unable to connect to $database on $hostname $!\n"; +open(my $USERS, '<', $users_file) or die "ERROR: Unable to open $users_file $!\n"; +my $database = DBI->connect("DBI:mysql:$db:$hostname",$user, $password) or die "ERROR: Unable to connect to $db on $hostname $!\n"; sub check_attribs { if (!defined($_[0]) or !defined($_[1])) { print "undefined parameter!\n"; - return undef; + return; }; - $attr = $_[0]; - $val = $_[1]; + my $attr = $_[0]; + my $val = $_[1]; if ($attr !~ /Password|Framed-IP-Address|Framed-IP-Netmask|Framed-IP-Routing|Framed-Routing|Framed-IP-Route|Password|Simultaneous-Use|Idle-Timeout|Auth-Type|Service-Type|Netmask|Framed-Protocol/ ) { print "unrecognized attribute: $attr\n" if $debug>1; - return undef; + return; }; - return undef if ( (! defined($val) ) or + return if ( (! defined($val) ) or ( ($attr =~ /Simultaneous\-Use/i) && ( $val !~ /^[0-9]*$/ ) ) ); print "attribs ok!\n" if $debug>3; @@ -71,14 +71,15 @@ sub cleanup { sub user_attribute { #push values into db... - $dtable=$_[0]; - $duser=$_[1]; - $dattrib=$_[2]; - $dval=$_[3]; + my $dtable=$_[0]; + my $duser=$_[1]; + my $dattrib=$_[2]; + my $dval=$_[3]; print "inserting \"$dattrib\", \"$dval\" for \"$duser\" in rad$dtable\n" if ( $dtable !~ /group/ and $debug>2); print "inserting \"$duser\" into usergroup table as member of \"$dattrib\"\n" if ( $dtable =~ /group/ and $debug>2); + my $table; if ( $dtable =~ /group/ ) { $table = "usergroup"; } elsif ( $dtable =~ /check/ ) { @@ -89,7 +90,7 @@ sub user_attribute { die "argh! what table is $dtable?\n"; }; - + my $return; if ( $table =~ /usergroup/ ) { if ( $dattrib =~ /static/ ) { #Delete the "dynamic" entry... @@ -104,7 +105,7 @@ sub user_attribute { }; -while () { +while (<$USERS>) { chop; #Skip comment lines and blank lines... @@ -112,9 +113,10 @@ while () { next if ( /^$/ ); next if ( /^\s*$/ ); + my @attribs; if ( /^[a-zA-Z0-9]+/ ) { print "located a user entry: $_\n" if $debug>6; - ($user,$rest) = split /\s/, $_, 2; + my ($user,$rest) = split /\s/, $_, 2; #Put user into usergroup as dynamic, if the user's attributes # include an IP address, the script will change that later... user_attribute("group",$user,"dynamic",""); @@ -124,8 +126,8 @@ while () { @attribs = $_; }; - foreach $attr (@attribs) { - ($attrib,$value) = split /=/, $attr, 2; + foreach my $attr (@attribs) { + my ($attrib,$value) = split /=/, $attr, 2; #TODO: insert sanity checks here! $value = cleanup($value) if (defined($value)); $attrib = cleanup($attrib) if (defined($attrib)); @@ -137,7 +139,6 @@ while () { if ( $attrib =~ /Framed-IP-Address/ ) { #user is a static IP user... - $static{$user} = 1; user_attribute("group",$user,"static",""); }; @@ -153,5 +154,5 @@ while () { }; -close USERS; -exit($database->disconnect); \ No newline at end of file +close $USERS; +exit($database->disconnect); diff --git a/src/protocols/vmps/vqpcli.pl b/src/protocols/vmps/vqpcli.pl index a87f2d5ec62..e41d00b2d3c 100755 --- a/src/protocols/vmps/vqpcli.pl +++ b/src/protocols/vmps/vqpcli.pl @@ -18,59 +18,63 @@ # vqpcli.pl -s localhost -v mydomain -w 10.0.0.1 -i 2/4 -m 0010.a49f.30e3 # +use strict; +use warnings; + use Socket; $|=0; -$DEBUG=0; +my $DEBUG=0; -sub formatItem($$) { +sub formatItem { my $mybuf; undef($mybuf); - $itemheader = shift; - $itemvalue = shift; + my $itemheader = shift; + my $itemvalue = shift; - $mybuf = $mybuf . pack("H*",(unpack("a*",$itemheader))); # Add header + $mybuf = pack("H*",(unpack("a*",$itemheader))); # Add header - $payload = pack("a*",(unpack("a*",$itemvalue))); - $length=length($payload); - $length= pack("H*",(unpack("a*",sprintf("%04x",$length)))); + my $payload = pack("a*",(unpack("a*",$itemvalue))); + my $length = length($payload); + $length = pack("H*",(unpack("a*",sprintf("%04x",$length)))); $mybuf = $mybuf . $length . $payload; # Add payload + length return $mybuf; } -sub parseOpts() { +sub parseOpts { use Getopt::Std; my $errors = ""; - + + our %opt; getopts("s:p:v:w:i:m:t:c:x",\%opt) or usage(); usage() if $opt{h}; my %request = ( server_ip => $opt{s} || "", client_ip => $opt{w} || "127.0.0.1", # IP to say we are - VMPS doesn't care port_name => $opt{i} || "Fa0/1", # Default port name to use - vlan => $opt{c} || "", # Isn't really needed. + vlan => $opt{c} || "", # Isn't really needed. port => $opt{p} || "1589", # UDP port vtp_domain => $opt{v} || "", # Is kinda important macaddr => $opt{m} || "", # Likewise... debug => $opt{x} || "0", # do debugging? ); - $opt{m} =~ tr/A-Z/a-z/; - $errors=$errors . "MAC address must be in nnnn.nnnn.nnnn format\n" - if ($opt{m} !~ /[a-z0-9][a-z0-9][a-z0-9][a-z0-9]\.[a-z0-9][a-z0-9][a-z0-9][a-z0-9]\.[a-z0-9][a-z0-9][a-z0-9][a-z0-9]/); - $errors=$errors . "VTP Domain must be specified\n" if ($opt{v} !~ /.*/); - $errors=$errors . "No Server name specified\n" if ($opt{s} =~ /^$/); + $errors=$errors . "MAC address must be in nnnn.nnnn.nnnn format\n" + unless $opt{m} && $opt{m} =~ /[a-z0-9][a-z0-9][a-z0-9][a-z0-9]\.[a-z0-9][a-z0-9][a-z0-9][a-z0-9]\.[a-z0-9][a-z0-9][a-z0-9][a-z0-9]/; + $opt{m} =~ tr/A-Z/a-z/ if $opt{m}; + $errors=$errors . "VTP Domain must be specified\n" unless defined $opt{v}; + $errors=$errors . "No Server name specified\n" unless defined $opt{s}; print STDERR $errors if ($errors); usage() if ($errors); $request{macaddr} =~ s/\.//g; - + return %request; } -sub usage() { +sub usage { print STDERR << "EOO"; Options: -s ip VMPS Server to query @@ -86,13 +90,12 @@ EOO } -sub makeVQPrequest($) { +sub makeVQPrequest { - my $request = $_; - my $buf; + my %request = %{$_[0]}; # Header... - $buf = $buf . pack("H*",(unpack("a*","01"))); # Header bit + my $buf = pack("H*",(unpack("a*","01"))); # Header bit # Is a request to join a vlan $buf = $buf . pack("H*",(unpack("a*","01"))); # Is a request @@ -110,25 +113,25 @@ sub makeVQPrequest($) { $buf = $buf . formatItem("000 0c01",(sprintf("%s",unpack("a*",inet_aton($request{client_ip}))))); # Add Port Name - $buf = $buf . formatItem("000 0c02",$request{port_name}); # Payload + $buf = $buf . formatItem("000 0c02",$request{port_name}); # Payload # Add VLAN to confirm to buffer - $buf = $buf . formatItem("000 0c03",$request{vlan}); # Payload + $buf = $buf . formatItem("000 0c03",$request{vlan}); # Payload # Add VTP domain name - $buf = $buf . formatItem("000 0c04",$request{vtp_domain}); # Payload + $buf = $buf . formatItem("000 0c04",$request{vtp_domain}); # Payload # Add UNKNOWN data to buffer... $buf = $buf . pack("H*",(unpack("a*","000 0c07"))); # Header $buf = $buf . pack("H*",(unpack("a*","0001 0"))); # Unknown filler # Add MAC address to buffer - $buf = $buf . formatItem("000 0c06",sprintf("%s",pack("H*",(unpack("a*",$request{macaddr}))))); # Payload + $buf = $buf . formatItem("000 0c06",sprintf("%s",pack("H*",(unpack("a*",$request{macaddr}))))); # Payload return "$buf"; } -sub sendVQP($$$) { +sub sendVQP { my $HOSTNAME= shift; my $PORTNO=shift; @@ -137,10 +140,10 @@ sub sendVQP($$$) { if ($DEBUG==1) { print "==============================\n"; print "MESSAGE SENT:\n"; - open (HEX, "|/usr/bin/hexdump"); - select HEX; + open(my $HEX, "|", "/usr/bin/hexdump"); + select $HEX; print $buf; - close HEX; + close $HEX; select STDOUT; print "==============================\n"; } @@ -156,17 +159,17 @@ sub sendVQP($$$) { if ($DEBUG==1) { print "MESSAGE RECV:\n"; - open (HEX, "|/usr/bin/hexdump"); - select HEX; + open(my $HEX, "|", "/usr/bin/hexdump"); + select $HEX; print $buf; - close HEX; + close $HEX; select STDOUT; print "==============================\n"; } return "$buf"; } -sub parseVQPresp($) { +sub parseVQPresp { my %response = ( status => "", @@ -176,7 +179,7 @@ sub parseVQPresp($) { my $buf = shift; $buf =~ /^(.)(.)(.)(.)(....)/; - my ($header,$type,$status,$size,$sequence) = + my ($header,$type,$status,$size,$sequence) = (ord($1),ord($2),ord($3),ord($4),pack("a*",(unpack("H*",$5)))); $buf =~ s/^........//; @@ -186,11 +189,11 @@ sub parseVQPresp($) { $response{status}="SHUTDOWN" if ($status == 4); $response{status}="WRONG_DOMAIN" if ($status == 5); - for ($i=1;$i<=$size;$i++) { + for (my $i=1;$i<=$size;$i++) { - $payload_type=pack("a*",(unpack("H*",substr($buf,0,4)))); - $payload_size=sprintf("%d",hex(pack("a*",(unpack("H*",substr($buf,4,2)))))); - $payload=substr($buf,6,$payload_size); + my $payload_type=pack("a*",(unpack("H*",substr($buf,0,4)))); + my $payload_size=sprintf("%d",hex(pack("a*",(unpack("H*",substr($buf,4,2)))))); + my $payload=substr($buf,6,$payload_size); if ($payload_type eq "00000c03") { $response{vlan}=$payload; @@ -202,10 +205,10 @@ sub parseVQPresp($) { return %response; } -%request=parseOpts(); +my %request=parseOpts(); $DEBUG = $request{debug}; -$buf = makeVQPrequest(%request); +my $buf = makeVQPrequest(\%request); $buf = sendVQP($request{server_ip},$request{port},$buf); -%response = parseVQPresp($buf); +my %response = parseVQPresp($buf); print "Vlan: $response{vlan}\nMAC Address: $response{macaddr} \nStatus: $response{status}\n"; diff --git a/src/tests/modules/perl/test.pl b/src/tests/modules/perl/test.pl index ac4e8df08ee..40274fdb69b 100644 --- a/src/tests/modules/perl/test.pl +++ b/src/tests/modules/perl/test.pl @@ -132,13 +132,12 @@ sub xlat { my ($filename,$a,$b,$c,$d) = @_; radiusd::radlog(L_DBG, "From xlat $filename"); radiusd::radlog(L_DBG,"From xlat $a $b $c $d"); - local *FH; - open FH, $filename or die "open '$filename' $!"; + open(my $FH, '<', $filename) or die "open '$filename' $!"; local($/) = undef; - my $sub = ; - close FH; + my $sub = <$FH>; + close $FH; my $eval = qq{ sub handler{ $sub;} }; - eval $eval; + eval $eval; ## no critic eval {main->handler;}; }