| … | |
… | |
| 46 | \%pak |
46 | \%pak |
| 47 | } |
47 | } |
| 48 | } |
48 | } |
| 49 | |
49 | |
| 50 | sub read_arch($;$) { |
50 | sub read_arch($;$) { |
| 51 | my ($path, $cache) = @_; |
51 | my ($path) = @_; |
| 52 | |
52 | |
| 53 | eval { |
|
|
| 54 | $cache |
|
|
| 55 | && -M "$VARDIR/$path.pst" < -M $path |
|
|
| 56 | && Storable::retrieve "$VARDIR/$path.pst" |
|
|
| 57 | } or do { |
|
|
| 58 | my %arc; |
53 | my %arc; |
| 59 | my ($more, $prev); |
54 | my ($more, $prev); |
| 60 | |
55 | |
| 61 | open my $fh, "<:raw", $path |
56 | open my $fh, "<:raw", $path |
| 62 | or die "$path: $!"; |
57 | or die "$path: $!"; |
| 63 | |
58 | |
| 64 | my $parse_block; $parse_block = sub { |
59 | my $parse_block; $parse_block = sub { |
| 65 | my %arc = @_; |
60 | my %arc = @_; |
| 66 | |
|
|
| 67 | while (<$fh>) { |
|
|
| 68 | s/\s+$//; |
|
|
| 69 | if (/^end$/i) { |
|
|
| 70 | last; |
|
|
| 71 | } elsif (/^arch (\S+)$/) { |
|
|
| 72 | push @{ $arc{inventory} }, $parse_block->(_name => $1); |
|
|
| 73 | } elsif (/^lore$/) { |
|
|
| 74 | while (<$fh>) { |
|
|
| 75 | last if /^endlore\s*$/i; |
|
|
| 76 | $arc{lore} .= $_; |
|
|
| 77 | } |
|
|
| 78 | } elsif (/^msg$/) { |
|
|
| 79 | while (<$fh>) { |
|
|
| 80 | last if /^endmsg\s*$/i; |
|
|
| 81 | $arc{msg} .= $_; |
|
|
| 82 | } |
|
|
| 83 | } elsif (/^(\S+)\s*(.*)$/) { |
|
|
| 84 | $arc{lc $1} = $2; |
|
|
| 85 | } elsif (/^\s*($|#)/) { |
|
|
| 86 | # |
|
|
| 87 | } else { |
|
|
| 88 | warn "$path: unparsable line '$_' in arch $arc{_name}"; |
|
|
| 89 | } |
|
|
| 90 | } |
|
|
| 91 | |
|
|
| 92 | \%arc |
|
|
| 93 | }; |
|
|
| 94 | |
61 | |
| 95 | while (<$fh>) { |
62 | while (<$fh>) { |
| 96 | s/\s+$//; |
63 | s/\s+$//; |
| 97 | if (/^more$/i) { |
64 | if (/^end$/i) { |
| 98 | $more = $prev; |
65 | last; |
| 99 | } elsif (/^object (\S+)$/i) { |
66 | } elsif (/^arch (\S+)$/) { |
| 100 | my $name = $1; |
|
|
| 101 | my $arc = $parse_block->(_name => $name); |
67 | push @{ $arc{inventory} }, $parse_block->(_name => $1); |
| 102 | |
68 | } elsif (/^lore$/) { |
| 103 | if ($more) { |
69 | while (<$fh>) { |
| 104 | $more->{more} = $arc; |
70 | last if /^endlore\s*$/i; |
| 105 | } else { |
|
|
| 106 | $arc{$name} = $arc; |
71 | $arc{lore} .= $_; |
| 107 | } |
72 | } |
| 108 | $prev = $arc; |
73 | } elsif (/^msg$/) { |
| 109 | $more = undef; |
74 | while (<$fh>) { |
|
|
75 | last if /^endmsg\s*$/i; |
|
|
76 | $arc{msg} .= $_; |
|
|
77 | } |
| 110 | } elsif (/^arch (\S+)$/i) { |
78 | } elsif (/^(\S+)\s*(.*)$/) { |
| 111 | push @{ $arc{arch} }, $parse_block->(_name => $1); |
79 | $arc{lc $1} = $2; |
| 112 | } elsif (/^\s*($|#)/) { |
80 | } elsif (/^\s*($|#)/) { |
| 113 | # |
81 | # |
| 114 | } else { |
82 | } else { |
| 115 | warn "$path: unparseable top-level line '$_'"; |
83 | warn "$path: unparsable line '$_' in arch $arc{_name}"; |
| 116 | } |
|
|
| 117 | } |
84 | } |
| 118 | |
|
|
| 119 | undef $parse_block; # work around bug in perl not freeing $fh etc. |
|
|
| 120 | |
|
|
| 121 | if ($cache) { |
|
|
| 122 | Storable::nstore \%arc, "$path.pst"; |
|
|
| 123 | utime +(stat $path)[8,9], "$path.pst"; |
|
|
| 124 | } |
85 | } |
| 125 | |
86 | |
| 126 | \%arc |
87 | \%arc |
| 127 | } |
88 | }; |
|
|
89 | |
|
|
90 | while (<$fh>) { |
|
|
91 | s/\s+$//; |
|
|
92 | if (/^more$/i) { |
|
|
93 | $more = $prev; |
|
|
94 | } elsif (/^object (\S+)$/i) { |
|
|
95 | my $name = $1; |
|
|
96 | my $arc = $parse_block->(_name => $name); |
|
|
97 | |
|
|
98 | if ($more) { |
|
|
99 | $more->{more} = $arc; |
|
|
100 | } else { |
|
|
101 | $arc{$name} = $arc; |
|
|
102 | } |
|
|
103 | $prev = $arc; |
|
|
104 | $more = undef; |
|
|
105 | } elsif (/^arch (\S+)$/i) { |
|
|
106 | push @{ $arc{arch} }, $parse_block->(_name => $1); |
|
|
107 | } elsif (/^\s*($|#)/) { |
|
|
108 | # |
|
|
109 | } else { |
|
|
110 | warn "$path: unparseable top-level line '$_'"; |
|
|
111 | } |
|
|
112 | } |
|
|
113 | |
|
|
114 | undef $parse_block; # work around bug in perl not freeing $fh etc. |
|
|
115 | |
|
|
116 | \%arc |
| 128 | } |
117 | } |
| 129 | |
118 | |
| 130 | sub cfmap_meta($;$) { |
119 | sub cfmap_meta($;$) { |
| 131 | my ($self, $mapa, $mapname) = @_; |
120 | my ($self, $mapa, $mapname) = @_; |
| 132 | |
121 | |
