#!/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 (<FILE>) {
+ 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;
}
#!/usr/bin/env perl
+use strict;
+use warnings;
+
+my %refs;
+my %defs;
+
#
# Read in the references, and put into an associative array
#
-open FILE, "<refs" || die "Error opening refs: $!\n";
-while (<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 <<EOF;
-<!DOCTYPE HTML PUBLIC "-//w3c//dtd html 4.0 transitional//en">
+ print $OUTPUT <<EOF;
+<!DOCTYPE html>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<h1>$rfc Attribute List</h1>
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 "</ul>\n" if ($letter ne "@");
+ print $OUTPUT "</ul>\n" if $letter ne "@";
$letter = substr($key,0,1);
- print OUTPUT "\n<h3>$letter</h3>\n\n";
- print OUTPUT "<ul>\n";
+ print $OUTPUT "\n<h3>$letter</h3>\n\n";
+ print
$OUTPUT "<ul>\n";
}
- print OUTPUT "<a href=\"$refs{$key}.html#$key\">$key</a><br />\n";
+ print
$OUTPUT "<a href=\"$refs{$key}.html#$key\">$key</a><br />\n";
}
- print OUTPUT "</ul>\n";
- print OUTPUT "</body>\n";
- close OUTPUT;
+ print $OUTPUT "</ul>\n";
+ print $OUTPUT "</body>\n";
+ print $OUTPUT "</html>\n";
+ close $OUTPUT;
}
#!/usr/bin/env perl
+use strict;
+use warnings;
+
+my %refs;
+my $ref;
+
#
# Read in the references, and put into an associative array
#
-open FILE, "<refs" || die "Error opening refs: $!\n";
-while (<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 <<EOF;
+ print $OUTPUT <<EOF;
<!DOCTYPE html>
<html>
<head>
EOF
# loop over the input file
- while (<FILE>) {
- # html-ize it
- s/&/&/g;
- 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 "<a name=\"$attribute\"><h2>$_</h2></a>\n";
-
- } else {
- print OUTPUT "<h2>$_</h2>\n";
- $attribute = "zzzz";
- }
- next;
- }
-
- #
- # Mark these up special.
- #
- if ((/^ Description/) ||
- (/^ Type/) ||
- (/^ Length/) ||
- (/^ Value/)) {
- print OUTPUT "<b>$_</b>\n";
- next;
- }
-
- # Make the current attribute name bold
- s/$attribute/<b>$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/<a href="#$word">$word<\/a>/g;
- } else {
- s/$word/<a href="$refs{$word}.html#$word">$word<\/a>/g;
- }
- }
- }
-
- print OUTPUT $_, "\n";
+ while (<$FILE>) {
+ # html-ize it
+ s/&/&/g;
+ 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 "<a name=\"$attribute\"><h2>$_</h2></a>\n";
+
+ } else {
+ print $OUTPUT "<h2>$_</h2>\n";
+ $attribute = "zzzz";
+ }
+ next;
+ }
+
+ #
+ # Mark these up special.
+ #
+ if ((/^ Description/) ||
+ (/^ Type/) ||
+ (/^ Length/) ||
+ (/^ Value/)) {
+ print $OUTPUT "<b>$_</b>\n";
+ next;
+ }
+
+ # Make the current attribute name bold
+ s/$attribute/<b>$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/<a href="#$word">$word<\/a>/g;
+ } else {
+ s/$word/<a href="$refs{$word}.html#$word">$word<\/a>/g;
+ }
+ }
+ }
+
+ print $OUTPUT $_, "\n";
+
}
- print OUTPUT "</pre>\n";
- print OUTPUT "</body>\n";
- close OUTPUT;
- close FILE;
+ print $OUTPUT "</pre>\n";
+ print $OUTPUT "</body>\n";
+ print $OUTPUT "</html>\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 <<EOF;
+print $OUTPUT <<EOF;
<!DOCTYPE html>
<html>
<head>
<h2>RADIUS Attribute List</h2>
EOF
-$letter = "@";
+my $letter = "@";
-foreach $key (sort keys %refs) {
+foreach my $key (sort keys %refs) {
if (substr($key,0,1) ne $letter) {
- print OUTPUT "</ul>\n" if ($letter ne "@");
- $letter = substr($key,0,1);
- print OUTPUT "\n<h3>$letter</h3>\n\n";
- print OUTPUT "<ul>\n";
+ print $OUTPUT "</ul>\n" if $letter ne "@";
+ $letter = substr($key,0,1);
+ print $OUTPUT "\n<h3>$letter</h3>\n\n";
+ print
$OUTPUT "<ul>\n";
}
- print OUTPUT "<a href=\"$refs{$key}.html#$key\">$key</a><br>\n";
+ print
$OUTPUT "<a href=\"$refs{$key}.html#$key\">$key</a><br>\n";
}
-print OUTPUT "</ul>\n";
+print $OUTPUT "</ul>\n";
-print OUTPUT "</body>\n";
-print OUTPUT "</html>\n";
-close OUTPUT;
+print $OUTPUT "</body>\n";
+print $OUTPUT "</html>\n";
+close $OUTPUT;
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 = <FH>;
- close FH;
+ my $sub = <$FH>;
+ close $FH;
my $eval = qq{ sub handler{ $sub;} };
- eval $eval;
+ eval $eval; ## no critic
eval {main->handler;};
}
#
# $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";
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 (<OLD>) {
+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 (<OLD>) {
- 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;
# 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 <number of users>\n\n";
} 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<rand($userlen)+2; $i++) {
+ my $username = "";
+ for(my $i=0; $i<rand($userlen)+2; $i++) {
+ my $char;
do { ($char = chr((rand 25)+97))} until $char=~/[A-Za-z]/;
$username .= $char;
}
$userlist{$username} = 1;
# generate password
- $password = "";
- for($i=0; $i<rand($passlen)+2; $i++) {
+ my $password = "";
+ for(my $i=0; $i<rand($passlen)+2; $i++) {
+ my $char;
do { ($char = chr((rand 25)+97))} until $char=~/[A-Za-z]/;
$password .= $char;
}
if (length($num)%2==1) {
- $num="0".$num;
+ $num="0".$num;
}
- printf PASS "$username:%s:1001:1001:Name:/dev/null:/dev/null\n", crypt($password, $password);
- printf SHAD "$username:%s:1000:0:99999:7:::\n", crypt($password, $password);
- printf RAD "User-Name=$username, User-Password=$password,NAS-IP-Address=127.0.0.1,NAS-Port-Id=0\n\n";
- print NOCRYPT "$username:$password\n";
- print USERS "$username Password.Cleartext := \"$password\"\n\tClass=\"0x$num\"\n\n";
+ printf $PASS "$username:%s:1001:1001:Name:/dev/null:/dev/null\n", crypt($password, $password);
+ printf $SHAD "$username:%s:1000:0:99999:7:::\n", crypt($password, $password);
+ printf $RAD "User-Name=$username, User-Password=$password,NAS-IP-Address=127.0.0.1,NAS-Port-Id=0\n\n";
+ print $NOCRYPT "$username:$password\n";
+ print $USERS "$username Password.Cleartext := \"$password\"\n\tClass=\"0x$num\"\n\n";
}
-close(PASS);
-close(SHAD);
-close(RAD);
-close(NOCRYPT);
-close(USERS);
+close($PASS);
+close($SHAD);
+close($RAD);
+close($NOCRYPT);
+close($USERS);
print "\nCreated $numusers random users and passwords\n\n";
# $Id$
#
-$line = 0;
+use strict;
+use warnings;
+
+my %attributes;
+my %values;
+
+my %dup;
+my %first_ref;
+my %name2val;
+
+my $line = 0;
while (<>) {
$line++;
# 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";
}
}
# $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";
}
}
# $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 (<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+)(.*)/) {
- $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";
}
# ./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;
# $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];
#
push @output, "# Version \$", "Id: ", "\$\n";
-
- 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+(.*)/) {
- $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;
}
#!/usr/bin/perl
+use strict;
+use warnings;
+
# radius2ldif.pl
#
# To test this program, do the following
# -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)
# 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 {
# (or objectclass=groupOfNames)
#cn=$group
# Required: person (for userpasswords) and radiusprofile (<draft-aboba-radius-02.txt> 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)
# 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";
# Footer of ldif entries
-$footer = "\n\n";
-$startentry = 0;
+my $header;
+my $footer = "\n\n";
+my $startentry = 0;
+
+my @userlist;
-while ($line=<STDIN>) {
+while (my $line=<STDIN>) {
chomp $line;
if ( $line =~ /^[\s\t]*$/ && $startentry) {
$startentry = 0 ;
}
# 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 ) {
#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);
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";
}
# 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 = <PASSWD>) {
+ while (my $line = <$PASSWD>) {
chomp $line;
if ( $line =~ /^(\w+)[\t\s]+(.*?)$/ ) {
$passwords{$1}=$2;
}
}
- close PASSWD;
+ close $PASSWD;
return 0;
}
#
######################################################################
+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 (<FILE>) {
- $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;
}
#
#
# FIXME:
#
-@directories = ("src/lib", "src");
-$do_it = 0;
+my @directories = ("src/lib", "src");
+my $do_it = 0;
#
# Horrid.
#
# Bootstrap the basic C files.
#
-foreach $file (@ARGV) {
+foreach my $file (@ARGV) {
process($file);
}
# 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;
+ }
}
}
# 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;
+ }
}
}
# 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);
}
}
# 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 (<FILE>) {
- $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;
}
}
}else {
warn "no answer, $!\n";
- return undef;
+ return;
}
}
# 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;
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/ ) {
die "argh! what table is $dtable?\n";
};
-
+ my $return;
if ( $table =~ /usergroup/ ) {
if ( $dattrib =~ /static/ ) {
#Delete the "dynamic" entry...
};
-while (<USERS>) {
+while (<$USERS>) {
chop;
#Skip comment lines and blank lines...
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","");
@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));
if ( $attrib =~ /Framed-IP-Address/ ) {
#user is a static IP user...
- $static{$user} = 1;
user_attribute("group",$user,"static","");
};
};
-close USERS;
-exit($database->disconnect);
\ No newline at end of file
+close $USERS;
+exit($database->disconnect);
# 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
}
-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
$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;
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";
}
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 => "",
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/^........//;
$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;
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";
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 = <FH>;
- close FH;
+ my $sub = <$FH>;
+ close $FH;
my $eval = qq{ sub handler{ $sub;} };
- eval $eval;
+ eval $eval; ## no critic
eval {main->handler;};
}
projects / thirdparty / freeradius-server.git / commitdiff
