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.1 $=~/\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|],
    -_METHODS   => [qw|reverse type|],
    -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
    #format
    -format_ipv4        => '[%vd]',
    -format_ipv6        => '[%s]',
    -format_name        => '%s',
    -format_name_literal        => '[%s]',
    #hook_encode_string
    #hook_decode_string
    -output_comment     => 0,
    -separator  => '.',
    -use_comment        => 0,
    -use_domain_literal => 1,
  );
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  $self->SUPER::_init (%DEFAULT, %options);
}

=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{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 (@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 (@d == 1 && $d[0] !~ /[^0-9:.]/) {
    $self->{type} = 'ipv6';
  } elsif (@d == 4) {
    if  (0 <= $d[0] && $d[0] < 256
     &&  0 <= $d[1] && $d[1] < 256
     &&  0 <= $d[2] && $d[2] < 256
     &&  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 ($self->{type} eq 'ipv6') {
    $s = sprintf $option{format_ipv6}, $self->{value}->[0];
  } elsif ($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}};
    $s = sprintf $option{format_name}, $d;
  }
  if ($option{output_comment} && @{$self->{comment}} > 0) {
    $s .= ' ' . $self->_comment_stringify;
  }
  $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/04/05 14:55:28 $

=cut

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