Commit: f2c9736b4ee41d8287f4961fae6d87f53fb2f63f - libnet-dhcp6-perl (git)

恥ずかしい勘違いから生まれた、DHCP6の不要かつ部分的な実装

Commit MetaInfo

• Revision: f2c9736b4ee41d8287f4961fae6d87f53fb2f63f (tree)
• Time: 2021-08-12 21:47:29
• Author: dyknon <dyknon@user...>
• Commiter: dyknon

Log Message

Domain Search List Option

Change Summary

• add: Net/DHCP6/AbstractOption/DomainNameList.pm
• add: Net/DHCP6/Option/DomainList.pm
• add: Net/DHCP6/Value/DomainName.pm

Incremental Difference

--- /dev/null
+++ b/Net/DHCP6/AbstractOption/DomainNameList.pm
@@ -0,0 +1,27 @@
+package Net::DHCP6::AbstractOption::DomainNameList;
+# base class for DHCP option containing a domain name list
+# RFC8415 10.
+
+use strict;
+use warnings;
+use Net::DHCP6::AbstractOption::List;
+use Net::DHCP6::Value::DomainName;
+
+our $VERSION = "0.001";
+our @ISA = qw/Net::DHCP6::AbstractOption::List/;
+
+# must overridden
+#sub code { ... }
+
+sub serialize_elem {
+    my $class_or_self = shift;
+    shift->serialize;
+}
+
+sub consume_elem {
+    my $class_or_self = shift;
+    my $buf = shift;
+    Net::DHCP6::Value::DomainName->consume_buf($buf);
+}
+
+1;

--- /dev/null
+++ b/Net/DHCP6/Option/DomainList.pm
@@ -0,0 +1,16 @@
+package Net::DHCP6::Option::DomainList;
+# RFC3646 4.
+
+use strict;
+use warnings;
+use Net::DHCP6::AbstractOption::DomainNameList;
+use Net::DHCP6::Parameters qw/DHCP6_OPT_DOMAIN_LIST/;
+
+our $VERSION = "0.001";
+our @ISA = qw/Net::DHCP6::AbstractOption::DomainNameList/;
+
+use constant code   => DHCP6_OPT_DOMAIN_LIST;
+use constant name   => "DomainList";
+
+__PACKAGE__->register_option;
+1;

--- /dev/null
+++ b/Net/DHCP6/Value/DomainName.pm
@@ -0,0 +1,105 @@
+package Net::DHCP6::Value::DomainName;
+# RFC8415 10.
+# RFC1035 2.3.1.
+# RFC1035 2.3.4.
+# RFC1035 3.1.
+
+use strict;
+use warnings;
+
+our $VERSION = "0.001";
+
+sub root {
+    my $class = shift;
+    my $self = [""];
+    bless $self, $class;
+}
+
+sub new {
+    my $class = shift;
+    if(@_ == 1){
+        if($_[0] eq "." || $_[0] eq ""){
+            return $class->root;
+        }
+        my @label = split(/\./, $_[0], -1);
+        if(@label == 1){
+            push @label, "";
+        }
+        $class->new(@label);
+    }else{
+        push @label, "" if($_[$#_] ne "");
+        if(join "", map{length $_ > 63} @_){
+            die "length of domain label > 63";
+        }
+        if(length join(".", @_) > 254){
+            die "length of domain name > 255";
+        }
+        if(join "",
+            map{$_ !~ /^[A-Za-z](?:[A-Za-z0-9-]*[A-Za-z0-9])?$/}
+            @_[0 .. ($#_-1)]
+        ){
+            die "invalid domain name";
+        }
+        my $self = [@_];
+        bless $self, $class;
+    }
+}
+
+sub new_relaxed {
+    my $class = shift;
+    if(@_ == 1 && ref $_[0] ne ""){
+        $class->new_relaxed(@{$_[0]});
+    }else{
+        my $self = [@_];
+        bless $self, $class;
+    }
+}
+
+sub consume_buf {
+    my $class = shift;
+    my $buf = shift;
+    my @label;
+    while(1){
+        die "null-label not found" if(length $$buf < 1);
+        my $len = unpack("C", substr $$buf, 0, 1);
+        if($len == 0){
+            push @label, "";
+            last;
+        }
+        die "imcomplete label" if(length $$buf < 1 + $len);
+        push @label, substr($$buf, 1, $len);
+        $$buf = substr($$buf, 1 + $len);
+    }
+    $class->new_relaxed(@label);
+}
+
+sub labels {
+    my $self = shift;
+    @$self;
+}
+
+sub str {
+    my $self = shift;
+    my @label = $self->labels;
+    @label = map{s/([^0-9A-Za-z-])/"\x".sprintf("%02x", ord($_))/ge} @label;
+    join(".", @label);
+}
+
+sub serialize {
+    my $self = shift;
+    my @label = $self->labels;
+    die "not a FQDN" if($label[$#label] ne "");
+    join "", map{
+        die "length of label > 255" if(length $_ > 255);
+        pack("C", length $_) . $_;
+    } @label;
+}
+
+use overload (
+    '""' => sub {
+        my $self = shift;
+        $self->str;
+    }
+);
+
+1;