ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/maps/perl/ipo.ext
(Generate patch)

Comparing deliantra/maps/perl/ipo.ext (file contents):
Revision 1.2 by elmex, Mon Jul 24 18:10:12 2006 UTC vs.
Revision 1.7 by root, Fri Aug 25 15:07:43 2006 UTC

1#! perl 1#! perl
2#CONVERSION: PARTIAL
2 3
3my $price_fact = 50; 4my $price_fact = 50;
4 5
5sub set_package { 6sub set_package {
6 my ($pkg, $from, $to, $bagname, $weight) = @_; 7 my ($pkg, $from, $to, $bagname, $weight) = @_;
… …
46 1 => ['scroll', 'mailscroll'], 47 1 => ['scroll', 'mailscroll'],
47 2 => ['note', 'newspaper'], 48 2 => ['note', 'newspaper'],
48 3 => ['diploma', 'mailwarning'], 49 3 => ['diploma', 'mailwarning'],
49); 50);
50 51
52sub notify_players {
53 my (%sent_targets) = @_;
54
55 # lets message player ingame: this is a NEW feature from the perl IPO :-)
56 for (keys %sent_targets) {
57 if (my $player = cf::player::find $_) {
58 my $cnt = $sent_targets{$_};
59
60 if ($cnt == 1) {
61 $player->ob->message ("You've got new mail.");
62 } else {
63 $player->ob->message ("You've got $cnt new mails.");
64 }
65 }
66 }
67}
68
51sub create_object { 69sub create_object {
52 my ($name, $map, $x, $y, $cb, @a) = @_; 70 my ($name, $map, $x, $y, $cb, @a) = @_;
53 my $o = cf::object::new $name; 71 my $o = cf::object::new $name;
54 my $r = $cb->($o, @a); 72 my $r = $cb->($o, @a);
55 $map->insert_object ($o, $x, $y); 73 $map->insert_object ($o, $x, $y);
56 $r 74 $r
57} 75}
58 76
59# this handler handles to notice the player that he has got mail 77# this handler handles to notice the player that he has got mail
60sub on_login { 78cf::attach_to_players
79 on_login => sub {
61 my ($pl, $host) = @_; 80 my ($pl) = @_;
62 81
63 my $mails = CFMail::get_mail ($pl->ob->name); 82 my $mails = CFMail::get_mail ($pl->ob->name);
64 83
65 my $cnt = @{$mails || []}; 84 my $cnt = @{$mails || []};
66 85
67 if ($cnt == 1) { 86 if ($cnt == 1) {
68 $pl->ob->message ("You got one mail."); 87 $pl->ob->message ("You got one mail.");
69 } elsif ($cnt > 1) { 88 } elsif ($cnt > 1) {
70 $pl->ob->message ("You got $cnt mails."); 89 $pl->ob->message ("You got $cnt mails.");
71 } else { 90 } else {
72 $pl->ob->message ("You haven't got any mail."); 91 $pl->ob->message ("You haven't got any mail.");
92 }
73 } 93 },
74 94;
75 0
76}
77 95
78# this event handler handles receiving of mails 96# this event handler handles receiving of mails
79sub on_apply { 97sub on_apply {
80 my ($ev, $box, $pl) = @_; 98 my ($ev, $box, $pl) = @_;
81 99
… …
141 } 159 }
142 } 160 }
143 161
144 $_->remove for @mails; 162 $_->remove for @mails;
145 163
146 # lets message player ingame: this is a NEW feature from the perl IPO :-) 164 notify_players (%sent_targets);
147 for (keys %sent_targets) {
148 if (my $player = cf::player::find $_) {
149 my $cnt = $sent_targets{$_};
150
151 if ($cnt == 1) {
152 $player->ob->message ("You've got new mail.");
153 } else {
154 $player->ob->message ("You've got $cnt new mails.");
155 }
156 }
157 }
158 165
159 0; 166 0;
160} 167}
161 168
162# this is the main command interface for the IPO NPC 169# this is the main command interface for the IPO NPC
… …
224 } 231 }
225 } 232 }
226 233
227 if ($cnt) { 234 if ($cnt) {
228 $who->reply ($npc, $cnt == 1 ? "Package sent to $arguments." : "Sent $cnt packages to $arguments\n"); 235 $who->reply ($npc, $cnt == 1 ? "Package sent to $arguments." : "Sent $cnt packages to $arguments\n");
236 CFMail::send_mail (1, $arguments, $who->name, "You got $cnt packages from " . $who->name);
237 notify_players ($arguments => 1);
229 } else { 238 } else {
230 $who->reply ($npc, "Sorry, found no package to send to $arguments."); 239 $who->reply ($npc, "Sorry, found no package to send to $arguments.");
231 } 240 }
232 241
233 } else { 242 } else {
… …
238 ."- literacy (%s platinum)\n" 247 ."- literacy (%s platinum)\n"
239 ."- mailscroll <friend> (%s platinum)\n" 248 ."- mailscroll <friend> (%s platinum)\n"
240 ."- bag <friend> (%s platinum)\n" 249 ."- bag <friend> (%s platinum)\n"
241 ."- package <friend> (%s platinum)\n" 250 ."- package <friend> (%s platinum)\n"
242 ."- carton <friend> (%s platinum)\n" 251 ."- carton <friend> (%s platinum)\n"
252 ."- send <friend> (send bags/packages/cartons)\n"
253 ."- receive (to receive packages for you)\n"
243 .($who->flag (cf::FLAG_WIZ) ? "- mailwarning <player>" : ""), 254 .($who->flag (cf::FLAG_WIZ) ? "- mailwarning <player>" : ""),
244 40, 1000, 1, 1, 5, 10 255 40, 1000, 1, 1, 5, 10
245 ); 256 );
246 } 257 }
247 1 258 1
248}; 259};
249 260
250package CFMail; 261package CFMail;
251use YAML qw/LoadFile DumpFile Dump/;
252use POSIX qw/strftime/; 262use POSIX qw/strftime/;
263use CFDB;
253 264
254my $maildb_file = cf::localdir . "/crossfiremail.perl"; 265my $MAILDB = CFDB->new (db_file => cf::localdir . "/crossfiremail.perl");
255my $last_check = (-M $maildb_file) + 1;
256my $MAILDB;
257
258sub check_maildb {
259 if ($last_check > (-M $maildb_file)) {
260 $last_check = -M $maildb_file;
261
262 my $maildb = eval { my $m = LoadFile ($maildb_file); return $m };
263 if ($@) {
264 warn "ERROR when reading mail database $maildb_file: $@\n";
265 $maildb_file = cf::localdir . "/crossfiremail.perl.after_load_failure";
266 } else {
267 $MAILDB = $maildb;
268 }
269 }
270}
271
272# This is not thread or multiprocess safe!
273# XXX: A second process will (of course) terribly damage the maildatabase
274# but i assume there wont be any second process.
275sub sync_maildb {
276 eval {
277 DumpFile ("$maildb_file.tmp", $MAILDB);
278 };
279 if ($@) {
280 warn "ERROR when writing mail database $maildb_file.tmp: $@\n";
281 } else {
282 rename "$maildb_file.tmp", $maildb_file;
283 $last_check = -M $maildb_file;
284 }
285}
286 266
287sub get_mail { 267sub get_mail {
288 my ($toname) = @_; 268 my ($toname) = @_;
289 check_maildb;
290 $MAILDB->{$toname}; 269 $MAILDB->get ($toname);
291} 270}
292 271
293sub clear_mail { 272sub clear_mail {
294 my ($toname) = @_; 273 my ($toname) = @_;
295 check_maildb; 274 $MAILDB->clear ($toname);
296 $MAILDB->{$toname} = [];
297 sync_maildb;
298} 275}
299 276
300sub store_mail { 277sub store_mail {
301 my ($type, $toname, $fromname, $message) = @_; 278 my ($type, $toname, $fromname, $message) = @_;
302 check_maildb; 279 my $mails = $MAILDB->get ($toname);
303 push @{$MAILDB->{$toname}}, [$type, $fromname, $message]; 280 push @$mails, [$type, $fromname, $message];
304 sync_maildb; 281 $MAILDB->set ($toname, $mails);
305} 282}
306 283
307sub send_mail { 284sub send_mail {
308 my ($type, $toname, $fromname, $message) = @_; 285 my ($type, $toname, $fromname, $message) = @_;
309 my $time = strftime ("%a, %d %b %Y %H:%M:%S CEST", localtime (time)); 286 my $time = strftime ("%a, %d %b %Y %H:%M:%S CEST", localtime (time));
310 my $msg = "From: $fromname\nTo: $toname\nDate: $time\n\n$message\n"; 287 my $msg = "From: $fromname\nTo: $toname\nDate: $time\n\n$message\n";
311 check_maildb; 288 store_mail ($type, $toname, $fromname, $msg);
312 push @{$MAILDB->{$toname}}, [$type, $fromname, $msg];
313 sync_maildb;
314} 289}
315
316check_maildb ();
317 290
3181; 2911;

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines