Message/Field/Domain.pm


=head1 NAME

Message::Field::Domain --- A perl module for an Internet
domain name which is part of Internet Messages

=cut

package Message::Field::Domain;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);

%REG = %Message::Util::REG;

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## Initialize of this class -- called by constructors
  %DEFAULT = (
    -_ARRAY_NAME        => 'value',
    -_MEMBERS   => [qw|type port|],
    -_METHODS   => [qw|reverse type port value|],
    -allow_special_name => 1,   ## not implemented yet
    -allow_special_ipv4 => 1,   ##
    -allow_special_ipv6 => 1,   ##
    -encoding_after_encode      => 'unknown-8bit',
    -encoding_before_decode     => 'unknown-8bit',
    #field_param_name
    #field_name
    -fill_default_name  => 1,   ## host / "1" / perl-false
    -fill_default_port  => 0,
    -fill_default_value => 0,
    #format
    -format_ipv4        => '[%vd]',
    -format_ipv6        => '[IPv6:%s]',
    -format_name        => '%s',
    -format_name_literal        => '[%s]',
    #hook_encode_string
    #hook_decode_string
    -output_comment     => 0,
    -output_port        => 0,
    -separator  => '.',
    -use_comment        => 0,
    -use_domain_literal => 1,
    -use_ipv4_address   => 1,
    -use_ipv6_address   => 1,
    -use_port   => 0,
  );
sub _init ($;%) {
  my $self = shift;
  my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
  $self->SUPER::_init (%$DEFAULT, @_);
}

=item $addr = Message::Field::Domain->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

## Inherited

=item $addr = Message::Field::Domain->parse ($field-body, [%options])

Constructs a new object with given field body.  You might pass 
some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $body = shift;
  $self->_init (@_);
  ($body, @{$self->{comment}})
    = $self->Message::Util::delete_comment_to_array ($body)
    if $self->{option}->{use_comment};
  my @d;
  $body =~ s{ $REG{FWS} : $REG{FWS} ([0-9]+) $ $REG{FWS} }{
    $self->{port} = $1;
  ''}ex if $self->{option}->{use_port};
  $body =~ s{($REG{domain_literal}|[^\x5B\x2E])+}{
    my ($d, $isd) = ($&, 0);
    $d =~ s/^$REG{WSP}+//;  $d =~ s/$REG{WSP}+$//;
    ($d, $isd) = Message::Util::unquote_if_domain_literal ($d);
    my %s = &{$self->{option}->{hook_decode_string}}
        ($self, $d, type => 'domain'.($isd?'/literal':''));
    push @d, $s{value};
  }gex;
  if ($self->{option}->{use_ipv4_address} && @d == 1 && $d[0] =~ /^([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})$/) {
    $d[0] = pack 'C4', $1, $2, $3, $4;
    $self->{type} = 'ipv4';
  } elsif ($self->{option}->{use_ipv6_address} && @d == 1 && $d[0] =~ s/^IPv6://i) {
    $self->{type} = 'ipv6';
  } elsif ($self->{option}->{use_ipv6_address} && @d == 1 && $d[0] !~ /[^0-9:.]/) {
    $self->{type} = 'ipv6';
  } elsif ($self->{option}->{use_ipv4_address} && @d == 4) {
    if  ($d[0] !~ /[^0-9]/ && 0 <= $d[0] && $d[0] < 256
     &&  $d[1] !~ /[^0-9]/ && 0 <= $d[1] && $d[1] < 256
     &&  $d[2] !~ /[^0-9]/ && 0 <= $d[2] && $d[2] < 256
     &&  $d[3] !~ /[^0-9]/ && 0 <= $d[3] && $d[3] < 256) {
      $self->{type} = 'ipv4';
      @d = (pack ('C4', @d));
    }
  }
  $self->{type} ||= 'name';
  $self->{value} = \@d;
  $self;
}

sub reverse ($) {$_[0]->{value} = [reverse @{$_[0]->{value}}];$_[0]}
sub type ($;$) {
  my $self = shift;
  my $newtype = shift;
  if ($newtype) {
    $self->{type} = $newtype;
  }
  $self->{type};
}

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  my $s = '';
  if ($option{use_ipv6_address} && $self->{type} eq 'ipv6') {
    $s = sprintf $option{format_ipv6}, $self->{value}->[0];
  } elsif ($option{use_ipv4_address} && $self->{type} eq 'ipv4') {
    $s = sprintf $option{format_ipv4}, $self->{value}->[0];
  } else {
    my $dl = 0;
    my $d = join $option{separator}, map {
      my %s = &{$option{hook_encode_string}} ($self, 
          $_, type => 'domain');
      if ($option{use_domain_literal} && $s{value} =~ /$REG{NON_atext}/) {
        $s{value} =~ s/[\x5B-\x5D]/\x5C$&/g;
        $s{value} = sprintf $option{format_name_literal}, $s{value};
      }
      $s{value};
    } @{$self->{value}};
    if ($option{fill_default_value} && !length $d) {
      if ($option{fill_default_name} == 1) {
        $d = Message::Util::get_host_fqdn;
      } else {
        $d = $option{fill_default_name};
      }
    }
    $s = sprintf $option{format_name}, $d;
  }
  if ($option{use_port} && $option{output_port}) { 
    my $port = $self->{port};
    $port = $option{fill_default_port} if !$port && $option{fill_default_value};
    $s .= ':' . (0+$self->{port}) if $port;
  }
  if ($option{use_comment} && $option{output_comment}) {
    my $c = $self->_comment_stringify;
    $s .= ' ' . $c if $c;
  }
  $s;
}

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/08/03 23:32:04 $

=cut

1;
1
2	=head1 NAME
3
4	Message::Field::Domain --- A perl module for an Internet
5	domain name which is part of Internet Messages
6
7	=cut
8
9	package Message::Field::Domain;
10	require 5.6.0;
11	use strict;
12	use re 'eval';
13	use vars qw(%DEFAULT @ISA %REG $VERSION);
14	$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15	require Message::Field::Structured;
16	push @ISA, qw(Message::Field::Structured);
17
18	%REG = %Message::Util::REG;
19
20	=head1 CONSTRUCTORS
21
22	The following methods construct new objects:
23
24	=over 4
25
26	=cut
27
28	## Initialize of this class -- called by constructors
29	%DEFAULT = (
30	-_ARRAY_NAME => 'value',
31	-_MEMBERS => [qw\|type port\|],
32	-_METHODS => [qw\|reverse type port value\|],
33	-allow_special_name => 1, ## not implemented yet
34	-allow_special_ipv4 => 1, ##
35	-allow_special_ipv6 => 1, ##
36	-encoding_after_encode => 'unknown-8bit',
37	-encoding_before_decode => 'unknown-8bit',
38	#field_param_name
39	#field_name
40	-fill_default_name => 1, ## host / "1" / perl-false
41	-fill_default_port => 0,
42	-fill_default_value => 0,
43	#format
44	-format_ipv4 => '[%vd]',
45	-format_ipv6 => '[IPv6:%s]',
46	-format_name => '%s',
47	-format_name_literal => '[%s]',
48	#hook_encode_string
49	#hook_decode_string
50	-output_comment => 0,
51	-output_port => 0,
52	-separator => '.',
53	-use_comment => 0,
54	-use_domain_literal => 1,
55	-use_ipv4_address => 1,
56	-use_ipv6_address => 1,
57	-use_port => 0,
58	);
59	sub _init ($;%) {
60	my $self = shift;
61	my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
62	$self->SUPER::_init (%$DEFAULT, @_);
63	}
64
65	=item $addr = Message::Field::Domain->new ([%options])
66
67	Constructs a new object. You might pass some options as parameters
68	to the constructor.
69
70	=cut
71
72	## Inherited
73
74	=item $addr = Message::Field::Domain->parse ($field-body, [%options])
75
76	Constructs a new object with given field body. You might pass
77	some options as parameters to the constructor.
78
79	=cut
80
81	sub parse ($$;%) {
82	my $class = shift;
83	my $self = bless {}, $class;
84	my $body = shift;
85	$self->_init (@_);
86	($body, @{$self->{comment}})
87	= $self->Message::Util::delete_comment_to_array ($body)
88	if $self->{option}->{use_comment};
89	my @d;
90	$body =~ s{ $REG{FWS} : $REG{FWS} ([0-9]+) $ $REG{FWS} }{
91	$self->{port} = $1;
92	''}ex if $self->{option}->{use_port};
93	$body =~ s{($REG{domain_literal}\|[^\x5B\x2E])+}{
94	my ($d, $isd) = ($&, 0);
95	$d =~ s/^$REG{WSP}+//; $d =~ s/$REG{WSP}+$//;
96	($d, $isd) = Message::Util::unquote_if_domain_literal ($d);
97	my %s = &{$self->{option}->{hook_decode_string}}
98	($self, $d, type => 'domain'.($isd?'/literal':''));
99	push @d, $s{value};
100	}gex;
101	if ($self->{option}->{use_ipv4_address} && @d == 1 && $d[0] =~ /^([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})$/) {
102	$d[0] = pack 'C4', $1, $2, $3, $4;
103	$self->{type} = 'ipv4';
104	} elsif ($self->{option}->{use_ipv6_address} && @d == 1 && $d[0] =~ s/^IPv6://i) {
105	$self->{type} = 'ipv6';
106	} elsif ($self->{option}->{use_ipv6_address} && @d == 1 && $d[0] !~ /[^0-9:.]/) {
107	$self->{type} = 'ipv6';
108	} elsif ($self->{option}->{use_ipv4_address} && @d == 4) {
109	if ($d[0] !~ /[^0-9]/ && 0 <= $d[0] && $d[0] < 256
110	&& $d[1] !~ /[^0-9]/ && 0 <= $d[1] && $d[1] < 256
111	&& $d[2] !~ /[^0-9]/ && 0 <= $d[2] && $d[2] < 256
112	&& $d[3] !~ /[^0-9]/ && 0 <= $d[3] && $d[3] < 256) {
113	$self->{type} = 'ipv4';
114	@d = (pack ('C4', @d));
115	}
116	}
117	$self->{type} \|\|= 'name';
118	$self->{value} = \@d;
119	$self;
120	}
121
122	sub reverse ($) {$_[0]->{value} = [reverse @{$_[0]->{value}}];$_[0]}
123	sub type ($;$) {
124	my $self = shift;
125	my $newtype = shift;
126	if ($newtype) {
127	$self->{type} = $newtype;
128	}
129	$self->{type};
130	}
131
132	sub stringify ($;%) {
133	my $self = shift;
134	my %o = @_; my %option = %{$self->{option}};
135	for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
136	my $s = '';
137	if ($option{use_ipv6_address} && $self->{type} eq 'ipv6') {
138	$s = sprintf $option{format_ipv6}, $self->{value}->[0];
139	} elsif ($option{use_ipv4_address} && $self->{type} eq 'ipv4') {
140	$s = sprintf $option{format_ipv4}, $self->{value}->[0];
141	} else {
142	my $dl = 0;
143	my $d = join $option{separator}, map {
144	my %s = &{$option{hook_encode_string}} ($self,
145	$_, type => 'domain');
146	if ($option{use_domain_literal} && $s{value} =~ /$REG{NON_atext}/) {
147	$s{value} =~ s/[\x5B-\x5D]/\x5C$&/g;
148	$s{value} = sprintf $option{format_name_literal}, $s{value};
149	}
150	$s{value};
151	} @{$self->{value}};
152	if ($option{fill_default_value} && !length $d) {
153	if ($option{fill_default_name} == 1) {
154	$d = Message::Util::get_host_fqdn;
155	} else {
156	$d = $option{fill_default_name};
157	}
158	}
159	$s = sprintf $option{format_name}, $d;
160	}
161	if ($option{use_port} && $option{output_port}) {
162	my $port = $self->{port};
163	$port = $option{fill_default_port} if !$port && $option{fill_default_value};
164	$s .= ':' . (0+$self->{port}) if $port;
165	}
166	if ($option{use_comment} && $option{output_comment}) {
167	my $c = $self->_comment_stringify;
168	$s .= ' ' . $c if $c;
169	}
170	$s;
171	}
172
173	=head1 LICENSE
174
175	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
176
177	This program is free software; you can redistribute it and/or modify
178	it under the terms of the GNU General Public License as published by
179	the Free Software Foundation; either version 2 of the License, or
180	(at your option) any later version.
181
182	This program is distributed in the hope that it will be useful,
183	but WITHOUT ANY WARRANTY; without even the implied warranty of
184	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
185	GNU General Public License for more details.
186
187	You should have received a copy of the GNU General Public License
188	along with this program; see the file COPYING. If not, write to
189	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
190	Boston, MA 02111-1307, USA.
191
192	=head1 CHANGE
193
194	See F<ChangeLog>.
195	$Date: 2002/08/03 23:32:04 $
196
197	=cut
198
199	1;