1 | #!/opt/bin/perl |
1 | #!/opt/bin/perl |
2 | |
2 | |
3 | # usage: res2pm >Crossfire/Data.pm |
3 | # usage: res2pm |
|
|
4 | |
|
|
5 | open STDOUT, ">:utf8", "Crossfire/Data.pm" |
|
|
6 | or die "Crossfire/Data.pm: $!"; |
4 | |
7 | |
5 | print <<EOF; |
8 | print <<EOF; |
6 | =head1 NAME |
9 | =head1 NAME |
7 | |
10 | |
8 | Crossfire::Data - various data structures useful for understanding archs and objects |
11 | Crossfire::Data - various data structures useful for understanding archs and objects |
… | |
… | |
25 | |
28 | |
26 | use Data::Dumper; |
29 | use Data::Dumper; |
27 | use XML::Parser::Grove; |
30 | use XML::Parser::Grove; |
28 | |
31 | |
29 | sub dump_hash { |
32 | sub dump_hash { |
30 | my ($name, $ref) = @_; |
33 | my ($names, $refs) = @_; |
31 | require Data::Dumper; |
34 | |
32 | $d = new Data::Dumper ([$ref], ["*$name"]); |
35 | $d = new Data::Dumper ($refs, [map "*$_", @$names]); |
33 | $d->Terse (1); |
36 | $d->Terse (1); |
34 | $d->Indent (1); |
37 | $d->Indent (1); |
35 | $d->Quotekeys (0); |
38 | $d->Quotekeys (0); |
36 | $d->Useqq (1); |
39 | $d->Useqq (0); |
|
|
40 | $d->Useperl(1); |
37 | $d->Sortkeys (sub { |
41 | $d->Sortkeys (sub { |
38 | [sort { |
42 | [sort { |
39 | $a > 0 && $b > 0 ? $a <=> $b |
43 | $a > 0 && $b > 0 ? $a <=> $b |
40 | : $a cmp $b |
44 | : $a cmp $b |
41 | } keys %{+shift}] |
45 | } keys %{+shift}] |
42 | }); |
46 | }); |
|
|
47 | |
43 | my $d = $d->Dump; |
48 | my @vals = $d->Dump; |
|
|
49 | |
|
|
50 | while (@vals) { |
|
|
51 | my $v = shift @vals; |
44 | $d =~ s/^ /\t\t/gm; |
52 | $v =~ s/^ /\t\t/gm; |
45 | $d =~ s/^ /\t/gm; |
53 | $v =~ s/^ /\t/gm; |
46 | $d =~ s/\s+$//; |
54 | $v =~ s/\s+$//; |
|
|
55 | |
|
|
56 | my $name = shift @$names; |
|
|
57 | my $ref = shift @$refs; |
|
|
58 | |
|
|
59 | my $sigil = ref $ref eq "ARRAY" ? '@' : '%'; |
|
|
60 | |
47 | print "our %$name = $d;\n\n"; |
61 | print "our $sigil$name = $v;\n\n"; |
|
|
62 | } |
48 | } |
63 | } |
49 | |
64 | |
50 | my $type = XML::Parser->new (Style => 'grove')->parsefile ("res/types.xml"); |
65 | my $type = XML::Parser->new (Style => 'grove')->parsefile ("res/types.xml"); |
51 | |
66 | |
52 | my %bitmask; |
67 | my %bitmask; |
53 | my %list; |
68 | my %list; |
54 | my %type; |
69 | my %type; |
|
|
70 | my %typename; |
|
|
71 | my @attr0; |
55 | my $attr; |
72 | my %attr; |
56 | my %ignore_list; |
73 | my %ignore_list; |
57 | my %default_attr; |
74 | my %default_attr; |
|
|
75 | my %spell; |
58 | |
76 | |
59 | sub string($) { |
77 | sub string($) { |
60 | local $_ = join "", @{shift->contents}; |
78 | local $_ = join "", @{shift->contents}; |
61 | $_ =~ s/^\s+//; |
79 | $_ =~ s/^\s+//; |
62 | $_ =~ s/\s+$//; |
80 | $_ =~ s/\s+$//; |
… | |
… | |
65 | } |
83 | } |
66 | |
84 | |
67 | sub parse_attr { |
85 | sub parse_attr { |
68 | my ($e, $sect) = @_; |
86 | my ($e, $sect) = @_; |
69 | |
87 | |
70 | $sect->{$e->attr ("arch") || $e->attr("arch_begin")} = { |
88 | my $arch = { |
|
|
89 | type => $e->attr ("type"), |
71 | name => $e->attr ("editor"), |
90 | name => $e->attr ("editor"), |
72 | type => $e->attr ("type"), |
|
|
73 | desc => string $e, |
91 | desc => string $e, |
74 | $e->attr("arch_begin") ? (end => $e->attr("arch_end")) : (), |
92 | $e->attr("arch_begin") ? (end => $e->attr("arch_end")) : (), |
75 | }; |
93 | }; |
|
|
94 | |
|
|
95 | delete $arch->{name} unless defined $arch->{name}; |
|
|
96 | delete $arch->{desc} unless length $arch->{desc}; |
|
|
97 | |
|
|
98 | if ($arch->{type} =~ s/^(bitmask)_(.*)/$1/) { |
|
|
99 | $arch->{value} = $bitmask{$2} ||= {}; |
|
|
100 | } elsif ($arch->{type} =~ s/^(list)_(.*)/$1/) { |
|
|
101 | $arch->{value} = $list{$2} ||= {}; |
|
|
102 | } elsif ($arch->{type} =~ s/^bool_special$/bool/) { |
|
|
103 | $arch->{value} = [$e->attr ("false"), $e->attr ("true")]; |
|
|
104 | } |
|
|
105 | |
|
|
106 | $sect->{$e->attr ("arch") || $e->attr("arch_begin")} = $arch; |
76 | } |
107 | } |
77 | |
108 | |
78 | sub parse_type { |
109 | sub parse_type { |
79 | my ($e, $type) = @_; |
110 | my ($e, $type) = @_; |
80 | |
111 | |
… | |
… | |
92 | } elsif ($i->name eq "attribute") { |
123 | } elsif ($i->name eq "attribute") { |
93 | push @{$type->{ignore}}, $i->attr ("arch"); |
124 | push @{$type->{ignore}}, $i->attr ("arch"); |
94 | } |
125 | } |
95 | } |
126 | } |
96 | } elsif ($e->name eq "import_type") { |
127 | } elsif ($e->name eq "import_type") { |
97 | push @{$type->{import}}, $xtype{$e->attr ("name")} ||= {}; |
128 | push @{$type->{import}}, $type{$e->attr ("name")} ||= {}; |
98 | } elsif ($e->name eq "use") { |
129 | } elsif ($e->name eq "use") { |
99 | $type->{use} = string $e; |
130 | $type->{use} = string $e; |
100 | } elsif ($e->name eq "description") { |
131 | } elsif ($e->name eq "description") { |
101 | $type->{desc} = string $e; |
132 | $type->{desc} = string $e; |
102 | } elsif ($e->name eq "section") { |
133 | } elsif ($e->name eq "section") { |
… | |
… | |
112 | $type |
143 | $type |
113 | } |
144 | } |
114 | |
145 | |
115 | for my $e (grep ref, @{$type->root->contents}) { |
146 | for my $e (grep ref, @{$type->root->contents}) { |
116 | if ($e->name eq "bitmask") { |
147 | if ($e->name eq "bitmask") { |
117 | my $bm = $bitmask{$e->attr ("name")} = {}; |
148 | my $bm = $bitmask{$e->attr ("name")} ||= {}; |
118 | for my $b (grep ref, @{$e->contents}) { |
149 | for my $b (grep ref, @{$e->contents}) { |
119 | $bm->{$b->attr ("bit")} = $b->attr ("name"); |
150 | $bm->{$b->attr ("bit")} = $b->attr ("name"); |
120 | } |
151 | } |
121 | } elsif ($e->name eq "list") { |
152 | } elsif ($e->name eq "list") { |
122 | my $list = $list{$e->attr ("name")} = {}; |
153 | my $list = $list{$e->attr ("name")} ||= {}; |
123 | for my $b (grep ref, @{$e->contents}) { |
154 | for my $b (grep ref, @{$e->contents}) { |
124 | $list->{$b->attr ("value")} = $b->attr ("name"); |
155 | $list->{$b->attr ("value")} = $b->attr ("name"); |
125 | } |
156 | } |
126 | } elsif ($e->name eq "ignore_list") { |
157 | } elsif ($e->name eq "ignore_list") { |
127 | my $list = $ignore_list{$e->attr ("name")} ||= []; |
158 | my $list = $ignore_list{$e->attr ("name")} ||= []; |
… | |
… | |
129 | push @$list, $b->attr ("arch"); |
160 | push @$list, $b->attr ("arch"); |
130 | } |
161 | } |
131 | } elsif ($e->name eq "default_type") { |
162 | } elsif ($e->name eq "default_type") { |
132 | parse_type $e, \%default_attr; |
163 | parse_type $e, \%default_attr; |
133 | } elsif ($e->name eq "type") { |
164 | } elsif ($e->name eq "type") { |
134 | my $type = $attr{$e->attr ("name")} ||= {}; |
165 | my $type = $type{$e->attr ("name")} ||= {}; |
135 | parse_type $e, $type; |
166 | parse_type $e, $type; |
136 | unshift @{$type->{import}}, \%default_attr; |
167 | #unshift @{$type->{import}}, \%default_attr; |
137 | $type{$e->attr ("number")}{type}{$e->attr ("name")} = $type; |
168 | |
|
|
169 | if ($e->attr ("number") > 0) { |
|
|
170 | $attr{$e->attr ("number")} = $type; |
|
|
171 | } elsif ($e->attr ("name") eq "Misc") { |
|
|
172 | delete $type->{required}; |
|
|
173 | } else { |
|
|
174 | push @attr0, $type; |
|
|
175 | } |
138 | |
176 | |
139 | } else { |
177 | } else { |
140 | warn "unknown types element ", $e->name; |
178 | warn "unknown types element ", $e->name; |
141 | } |
179 | } |
142 | } |
180 | } |
143 | |
181 | |
144 | my $type = XML::Parser->new (Style => 'grove')->parsefile ("res/typenumbers.xml"); |
182 | my $type = XML::Parser->new (Style => 'grove')->parsefile ("res/typenumbers.xml"); |
145 | |
183 | |
146 | for (grep ref, @{$type->root->contents}) { |
184 | for (grep ref, @{$type->root->contents}) { |
147 | $type{$_->attr ("number")}{name} = $_->attr ("name"); |
185 | $typename{$_->attr ("number")} = $_->attr ("name"); |
148 | } |
186 | } |
149 | |
|
|
150 | dump_hash "TYPE", \%type; |
|
|
151 | |
|
|
152 | dump_hash "LIST", \%list; |
|
|
153 | dump_hash "BITMASK", \%bitmask; |
|
|
154 | |
187 | |
155 | my $spell = XML::Parser->new (Style => 'grove')->parsefile ("res/spells.xml") |
188 | my $spell = XML::Parser->new (Style => 'grove')->parsefile ("res/spells.xml") |
156 | or die; |
189 | or die; |
157 | |
190 | |
158 | my %spell; |
|
|
159 | |
|
|
160 | for (grep ref, @{$spell->root->contents}) { |
191 | for (grep ref, @{$spell->root->contents}) { |
161 | $spell{$_->attr ("id")} = $_->attr ("name"); |
192 | $spell{$_->attr ("id")} = $_->attr ("name"); |
162 | } |
193 | } |
163 | |
194 | |
164 | dump_hash "SPELL", \%spell; |
195 | dump_hash ["BITMASK", "LIST", "IGNORE_LIST", "DEFAULT_ATTR", "TYPE", "ATTR0", "ATTR", "TYPENAME", "SPELL"], |
|
|
196 | [\%bitmask, \%list, \%ignore_list, \%default_attr, \%type, \@attr0, \%attr, \%typename, \%spell]; |
165 | |
197 | |
166 | print <<EOF; |
198 | print <<EOF; |
167 | |
199 | |
168 | =head1 AUTHOR |
200 | =head1 AUTHOR |
169 | |
201 | |