24 $DATA{fn}{$self} = $arg{file}; |
24 $DATA{fn}{$self} = $arg{file}; |
25 $DATA{fh}{$self} = my $fh = IO::File->new($DATA{fn}{$self}) |
25 $DATA{fh}{$self} = my $fh = IO::File->new($DATA{fn}{$self}) |
26 or die "Can't open $DATA{fn}{$self}: $!\n"; |
26 or die "Can't open $DATA{fn}{$self}: $!\n"; |
27 |
27 |
28 local $/ = ""; |
28 local $/ = ""; |
29 $DATA{header}{$self} = <$fh>; |
29 chomp($DATA{header}{$self} = <$fh>); |
30 $DATA{body_pos}{$self} = tell($fh); |
30 $DATA{body_pos}{$self} = tell($fh); |
31 |
31 |
32 return $self; |
32 return $self; |
33 } |
33 } |
34 |
34 |
35 sub __header_fields { |
35 sub header_fields { |
36 my $self = shift; |
36 my ($self, $pattern) = @_; |
37 my %h; |
37 $pattern //= qr/\S+/; |
38 @h{ $DATA{header}{$self} =~ /^(\S+?[: ])/mg } = (); |
38 return grep /$pattern/i => $DATA{header}{$self} =~ /^(\S+?[: ])/mg; |
39 return keys %h; |
|
40 } |
39 } |
41 |
40 |
42 sub header_content { |
41 sub header_lines { |
|
42 my $self = shift; |
|
43 my $field = shift // qr/.*/; |
|
44 my @r = grep /$field/i => $DATA{header}{$self} =~ /(^\S+?[: ]\s*.*?\n)(?=^\S|\Z)/imsg; |
|
45 return @r if wantarray; |
|
46 |
|
47 foreach (@r) { s/\s*?\n\s+/ /mg; } |
|
48 return join "" => @r; |
|
49 } |
|
50 |
|
51 sub remove_header_lines { |
|
52 my $self = shift; |
|
53 my $pattern = shift // die "Need a pattern!"; |
|
54 $DATA{header}{$self} =~ s/^$pattern.*?(?=^\S|\Z)//imsg; |
|
55 } |
|
56 |
|
57 sub add_header_line { |
|
58 my $self = shift; |
|
59 my $_ = shift; |
|
60 $_ .= "\n" unless /\n$/; |
|
61 $DATA{header}{$self} .= $_; |
|
62 } |
|
63 |
|
64 sub header_contents { |
43 my $self = shift; |
65 my $self = shift; |
44 my $field = shift; |
66 my $field = shift // qr/.*/; |
45 |
67 |
46 ### assert: $field =~ /[: ]$/ |
68 my @r = map { (split /[: ]/, $_, 2)[1] } $self->header_lines($field); |
|
69 return @r if wantarray; |
47 |
70 |
48 # FIXME: not sure if the space following the header field name |
71 foreach (@r) { s/\s*?\n\s+/ /mg; } |
49 # is optional or required |
72 return join "" => @r; |
50 return $DATA{header}{$self} =~ /^$field\s+(.*?)(?=^\S)/imsg; |
|
51 } |
73 } |
|
74 |
52 |
75 |
53 sub orig_header { |
76 sub orig_header { |
54 my $self = shift; |
77 my $self = shift; |
55 my $fh = $DATA{fh}{$self}; |
78 my $fh = $DATA{fh}{$self}; |
56 seek($fh, 0, 0); |
79 seek($fh, 0, 0); |
103 =item B<new>(file => I<file>) |
126 =item B<new>(file => I<file>) |
104 |
127 |
105 The construcor. The file is opened r/o and read. The file will not be |
128 The construcor. The file is opened r/o and read. The file will not be |
106 closed until the object disappears. |
129 closed until the object disappears. |
107 |
130 |
108 =item @list = B<header_content>(I<field>) |
131 =item @list = B<header_fields>([I<pattern>]) |
109 |
132 |
110 Returns a list (*always* a list) with the contents of the specified |
133 Return a list of existing header fields, matching the pattern. |
111 header field. The I<field> has to include the colon ":" or space " ", |
134 See B<header_contents()> for information about the |
|
135 returned format. (default pattern: /.*/) |
|
136 |
|
137 |
|
138 =item @list = B<header_lines>([I<pattern>]) |
|
139 |
|
140 Returns the header line matching the I<pattern>. See B<header_contents()> |
|
141 about the returned format. (default pattern: /.*/) |
|
142 |
|
143 =item @list = B<header_contents>([I<pattern>]) |
|
144 |
|
145 Returns the contents of the header lines matching the pattern. (default |
|
146 pattern: /.*/) |
|
147 |
|
148 In list context a list of B<unmodified> header lines is returned. |
|
149 In scalar context the header lines are de-wrapped and then returned, |
|
150 delimited by single linebreak. |
|
151 |
|
152 The I<field> has to include the colon ":" or space " ", |
112 since it is considered a part of the field name. I<field> is case |
153 since it is considered a part of the field name. I<field> is case |
113 insensitive! |
154 insensitive! |
114 |
155 |
115 =item $scalar = $B<orig_header>() |
156 =item $scalar = $B<orig_header>() |
116 |
157 |