=head1 NAME Message::Header::Default --- Internet Messages -- Definition for Default Namespace of Header Fields =cut package Message::Header::Default; use strict; use vars qw($VERSION); $VERSION=do{my @r=(q$Revision: 1.8 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; require Message::Header; our %OPTION; ## Case sensibility of field name $OPTION{case_sensible} = 1; #$OPTION{to_be_goodcase} = \&...; $OPTION{n11n_name} = \&_name_n11n; $OPTION{n11n_prefix} = \&_name_n11n; ## Namespace URI of this namespace $OPTION{namespace_uri} = 'urn:x-suika-fam-cx:msgpm:header:default'; ## Force & hyphened prefix name of this namespace (ex. "prefix-name") $OPTION{use_ph_namespace} = 1; $OPTION{namespace_phname} = 'default'; $OPTION{namespace_phname_goodcase} = 'default'; ## `Good' & dotted prefix name of this namespace (ex. "prefix.name", "prefix2.name") $OPTION{namespace_good_prefix} = 'DEFAULT'; ## Sort fields (0 / 'alphabetic' / ref(CODE) $OPTION{field_sort} = 0; ## Field body data type (specified by package name) $OPTION{value_type} = { ':default' => ['Message::Field::Unstructured'], }; ## mailto: URL safe level $OPTION{uri_mailto_safe} = { ## 1 all (no check) 2 no trace & bcc & from ## 3 no sender's info 4 (default) (currently not used) ## 5 only a few ':default' => 1, }; ## $Message::Header::NS_phname2uri{$OPTION{namespace_phname}} = $OPTION{namespace_uri}; $Message::Header::NS_uri2phpackage{$OPTION{namespace_uri}} = __PACKAGE__; ## $self->_goodcase ($namespace_package_name, $field_name, \%option) sub _goodcase ($$$\%) { no strict 'refs'; my $self = shift; my ($nspack, $name, $option) = @_; if (${$nspack.'::OPTION'}{goodcase}->{$name}) { return ${$nspack.'::OPTION'}{goodcase}->{$name}; } $name =~ s/(?:^|-)[a-z]/uc $&/ge; $name; } sub _name_n11n ($$$) { no strict 'refs'; my $self = shift; my $nspack = shift; my $name = shift; unless (${$nspack.'::OPTION'}{case_sensible}) { lc $name; } else { $name; } } sub sort_good_practice ($$\@\%) { my ($hdr, $array, $nspack, $option) = @_; if ($option->{field_sort} eq 'good-practice') { no strict 'refs'; my $order = ${ $nspack.'::OPTION' }{field_sort_good_practice_order}; my $mynsuri = ${ $nspack.'::OPTION' }{namespace_uri}; my $mynsprefix = ${ $nspack.'::OPTION' }{namespace_phname}; return sort { if ($a->{ns} eq $b->{ns}) { if ($a->{ns} eq $mynsuri) { $order->{ $a->{name} } ||= 999; $order->{ $b->{name} } ||= 999; $order->{ $a->{name} } <=> $order->{ $b->{name} } || $a->{name} cmp $b->{name}; } else { #($a->{ns} eq $b->{ns}) my $nspack = Message::Header::_NS_uri2package ($a->{ns}); my $sort = ${ $nspack.'::OPTION' }{field_sort}; if ($sort->{'good-practice'}) { my $order = ${ $nspack.'::OPTION' }{field_sort_good_practice_order}; $order->{ $a->{name} } ||= 999; $order->{ $b->{name} } ||= 999; $order->{ $a->{name} } <=> $order->{ $b->{name} } || $a->{name} cmp $b->{name}; } elsif ($sort->{alphabetic}) { $a->{name} cmp $b->{name}; } else { 1; ## Isn't supported } } } else { ## $a->{ns} ne $b->{ns} if ($a->{ns} eq $mynsuri) { my $bp = ($hdr->{ns}->{uri2phname}->{ $b->{ns} } || '~'.$b->{ns}).'-'; $bp =~ s/^\Q$mynsprefix\E-//; $order->{ $a->{name} } ||= 999; $order->{ $bp } ||= 999; $order->{ $a->{name} } <=> $order->{ $bp } || $a->{name} cmp $bp; } elsif ($b->{ns} eq $mynsuri) { my $ap = ($hdr->{ns}->{uri2phname}->{ $a->{ns} } || '~'.$a->{ns}).'-'; $ap =~ s/^\Q$mynsprefix\E-//; $order->{ $ap } ||= 999; $order->{ $b->{name} } ||= 999; $order->{ $ap } <=> $order->{ $b->{name} } || $ap cmp $b->{name}; } else { my $ap = ($hdr->{ns}->{uri2phname}->{ $a->{ns} } || '~'.$a->{ns}).'-'; my $bp = ($hdr->{ns}->{uri2phname}->{ $b->{ns} } || '~'.$b->{ns}).'-'; $ap =~ s/^\Q$mynsprefix\E-//; $bp =~ s/^\Q$mynsprefix\E-//; $order->{ $ap } ||= 999; $order->{ $bp } ||= 999; $order->{ $ap } <=> $order->{ $bp } || $ap cmp $bp; } } } @$array; } @$array; } package Message::Header::XCGI; our %OPTION = %Message::Header::Default::OPTION; $OPTION{namespace_uri} = 'urn:x-suika-fam-cx:msgpm:header:http:cgi:x'; $OPTION{namespace_phname} = 'x-cgi'; $OPTION{namespace_phname_goodcase} = 'X-CGI'; $OPTION{case_sensible} = 0; $OPTION{to_be_goodcase} = \&Message::Header::Default::_goodcase; $Message::Header::NS_phname2uri{$OPTION{namespace_phname}} = $OPTION{namespace_uri}; $Message::Header::NS_uri2phpackage{$OPTION{namespace_uri}} = __PACKAGE__; ## require Message::Header::RFC822; require Message::Header::HTTP; require Message::Header::Message; =head1 LICENSE Copyright 2002 wakaba Ew@suika.fam.cxE. 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. $Date: 2002/07/28 00:31:38 $ =cut 1;