ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cf.schmorp.de/maps/perl/cf.pm
Revision: 1.4
Committed: Fri Feb 3 19:49:32 2006 UTC (18 years, 5 months ago) by root
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +0 -0 lines
State: FILE REMOVED
Log Message:
*** empty log message ***

File Contents

# Content
1 package cf;
2
3 use Symbol;
4 use List::Util;
5
6 use strict;
7
8 our %COMMAND;
9 our @EVENT;
10 our %PROP_TYPE;
11 our %PROP_IDX;
12
13 BEGIN {
14 @EVENT = map lc, @EVENT;
15
16 *CORE::GLOBAL::warn = sub {
17 my $msg = join "", @_;
18 $msg .= "\n"
19 unless $msg =~ /\n$/;
20
21 print STDERR "cfperl: $msg";
22 LOG llevError, "cfperl: $msg";
23 };
24 }
25
26 # generate property mutators
27 sub prop_gen {
28 my ($prefix, $class) = @_;
29
30 no strict 'refs';
31
32 for my $prop (keys %PROP_TYPE) {
33 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
34 my $sub = lc $1;
35
36 my $type = $PROP_TYPE{$prop};
37 my $idx = $PROP_IDX {$prop};
38
39 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
40 $_[0]->get_property ($type, $idx)
41 };
42
43 *{"$class\::set_$sub"} = sub {
44 $_[0]->set_property ($type, $idx, $_[1]);
45 };
46 }
47 }
48
49 # auto-generate most of the API
50
51 prop_gen OBJECT_PROP => "cf::object";
52 # CFAPI_OBJECT_ANIMATION?
53 prop_gen PLAYER_PROP => "cf::object::player";
54
55 prop_gen MAP_PROP => "cf::map";
56 prop_gen ARCH_PROP => "cf::arch";
57
58 # guessed hierarchies
59
60 @cf::object::player::ISA = 'cf::object';
61 @cf::object::map::ISA = 'cf::object';
62
63 my @exts;
64 my @hook;
65 my %command;
66
67 sub inject_event {
68 my ($data) = @_;
69
70 my $cb = $hook[$data->{event_code}]
71 or return;
72
73 $_->($data) for values %$cb;
74
75 ()
76 }
77
78 sub inject_command {
79 my ($name, $obj, $params) = @_;
80
81 for my $cmd (@{ $command{$name} }) {
82 $cmd->[1]->($obj, $params);
83 }
84
85 -1
86 }
87
88 sub register_command {
89 my ($name, $time, $cb) = @_;
90
91 my $caller = caller;
92
93 push @{ $command{$name} }, [$time, $cb, $caller];
94 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
95 }
96
97 sub load_extension {
98 my ($path) = @_;
99
100 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
101 my $pkg = $1;
102 $pkg =~ s/[^[:word:]]/_/g;
103 $pkg = "cf::ext::$pkg";
104
105 warn "loading '$path' into '$pkg'\n";
106
107 open my $fh, "<:utf8", $path
108 or die "$path: $!";
109
110 my $source =
111 "package $pkg; use strict; use utf8;\n"
112 . "#line 1 \"$path\"\n{\n"
113 . (do { local $/; <$fh> })
114 . "\n};\n1";
115
116 eval $source
117 or die "$path: $@";
118
119 push @exts, $pkg;
120
121 no strict 'refs';
122
123 # @{"$pkg\::ISA"} = cf::ext::;
124
125 for my $idx (0 .. $#EVENT) {
126 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
127 warn "registering $EVENT[$idx] hook\n";
128 $hook[$idx]{$pkg} = $ref;
129 }
130 }
131 }
132
133 sub unload_extension {
134 my ($pkg) = @_;
135
136 warn "removing extension $pkg\n";
137
138 # remove hooks
139 for my $idx (0 .. $#EVENT) {
140 delete $hook[$idx]{$pkg};
141 }
142
143 # remove commands
144 for my $name (keys %command) {
145 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
146
147 if (@cb) {
148 $command{$name} = \@cb;
149 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
150 } else {
151 delete $command{$name};
152 delete $COMMAND{"$name\000"};
153 }
154 }
155
156 Symbol::delete_package $pkg;
157 }
158
159 sub load_extensions {
160 my $LIBDIR = maps_directory "perl";
161
162 for my $ext (<$LIBDIR/*.ext>) {
163 load_extension $ext;
164 }
165 }
166
167 register_command "perl-reload", 0, sub {
168 my ($who, $arg) = @_;
169
170 if ($who->flag (FLAG_WIZ)) {
171 warn "reloading...\n";
172 unload_extension $_ for @exts;
173 @exts = 0;
174 load_extensions;
175 warn "reloaded\n";
176 }
177 };
178
179 load_extensions;
180
181 1
182