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.9 by root, Sun Aug 27 15:23:30 2006 UTC

… …
46 1 => ['scroll', 'mailscroll'], 46 1 => ['scroll', 'mailscroll'],
47 2 => ['note', 'newspaper'], 47 2 => ['note', 'newspaper'],
48 3 => ['diploma', 'mailwarning'], 48 3 => ['diploma', 'mailwarning'],
49); 49);
50 50
51sub notify_players {
52 my (%sent_targets) = @_;
53
54 # lets message player ingame: this is a NEW feature from the perl IPO :-)
55 for (keys %sent_targets) {
56 if (my $player = cf::player::find $_) {
57 my $cnt = $sent_targets{$_};
58
59 if ($cnt == 1) {
60 $player->ob->message ("You've got new mail.");
61 } else {
62 $player->ob->message ("You've got $cnt new mails.");
63 }
64 }
65 }
66}
67
51sub create_object { 68sub create_object {
52 my ($name, $map, $x, $y, $cb, @a) = @_; 69 my ($name, $map, $x, $y, $cb, @a) = @_;
53 my $o = cf::object::new $name; 70 my $o = cf::object::new $name;
54 my $r = $cb->($o, @a); 71 my $r = $cb->($o, @a);
55 $map->insert_object ($o, $x, $y); 72 $map->insert_object ($o, $x, $y);
56 $r 73 $r
57} 74}
58 75
59# this handler handles to notice the player that he has got mail 76# this handler handles to notice the player that he has got mail
60sub on_login { 77cf::attach_to_players
78 on_login => sub {
61 my ($pl, $host) = @_; 79 my ($pl) = @_;
62 80
63 my $mails = CFMail::get_mail ($pl->ob->name); 81 my $mails = CFMail::get_mail ($pl->ob->name);
64 82
65 my $cnt = @{$mails || []}; 83 my $cnt = @{$mails || []};
66 84
67 if ($cnt == 1) { 85 if ($cnt == 1) {
68 $pl->ob->message ("You got one mail."); 86 $pl->ob->message ("You got one mail.");
69 } elsif ($cnt > 1) { 87 } elsif ($cnt > 1) {
70 $pl->ob->message ("You got $cnt mails."); 88 $pl->ob->message ("You got $cnt mails.");
71 } else { 89 } else {
72 $pl->ob->message ("You haven't got any mail."); 90 $pl->ob->message ("You haven't got any mail.");
91 }
73 } 92 },
74 93;
75 0
76}
77 94
78# this event handler handles receiving of mails 95# this event handler handles receiving of mails
79sub on_apply { 96cf::register_attachment ipo_mailbox =>
97 on_apply => sub {
80 my ($ev, $box, $pl) = @_; 98 my ($box, $pl) = @_;
81 99
82 my $cnt; 100 my $cnt;
83 my $mails = CFMail::get_mail ($pl->name) || []; 101 my $mails = CFMail::get_mail ($pl->name) || [];
84 102
85 # count the mails that are in the container 103 # count the mails that are in the container
86 # FIXME: the problem with on_apply is that it is called even when 104 # FIXME: the problem with on_apply is that it is called even when
87 # the player closes the container. so we get a 'You have X mails.' message 105 # the player closes the container. so we get a 'You have X mails.' message
88 # twice. - This bug existed also with the old python plugin 106 # twice. - This bug existed also with the old python plugin
89 107
90 my $plname = $pl->name; 108 my $plname = $pl->name;
91 for ($box->inv) { 109 for ($box->inv) {
92 $_->name =~ /\S+ F: \S+ T: \Q$plname\E/ 110 $_->name =~ /\S+ F: \S+ T: \Q$plname\E/
93 and $cnt++; 111 and $cnt++;
94 } 112 }
95 113
96 for (@$mails) { 114 for (@$mails) {
97 my ($type, $from, $msg) = @$_; 115 my ($type, $from, $msg) = @$_;
98 $type = $mailtypes{$type || 1} || ['scroll', 'mailscroll']; 116 $type = $mailtypes{$type || 1} || ['scroll', 'mailscroll'];
99 my $mail = cf::object::new $type->[0]; 117 my $mail = cf::object::new $type->[0];
100 $mail->set_name ("$type->[1] F: $from T: " .$pl->name); 118 $mail->set_name ("$type->[1] F: $from T: " .$pl->name);
101 $mail->set_name_plural ("$type->[1]s F: $from T: " .$pl->name); 119 $mail->set_name_plural ("$type->[1]s F: $from T: " .$pl->name);
102 $mail->set_message ($msg); 120 $mail->set_message ($msg);
103 $mail->set_value (0); 121 $mail->set_value (0);
104 $mail->insert_in_ob ($box); 122 $mail->insert_in_ob ($box);
105 } 123 }
106 124
107 $cnt += @$mails; 125 $cnt += @$mails;
108 126
109 if ($cnt == 1) { 127 if ($cnt == 1) {
110 $pl->message ("You got one mail."); 128 $pl->message ("You got one mail.");
111 } elsif ($cnt > 1) { 129 } elsif ($cnt > 1) {
112 $pl->message ("You got $cnt mails."); 130 $pl->message ("You got $cnt mails.");
113 } else { 131 } else {
114 $pl->message ("You haven't got any mail."); 132 $pl->message ("You haven't got any mail.");
115 } 133 }
116 134
117 CFMail::clear_mail ($pl->name); 135 CFMail::clear_mail ($pl->name);
118 136 },
119 0;
120}
121
122# this event handler handles the sending of mails 137 # this event handler handles the sending of mails
123sub on_close { 138 on_close => sub {
124 my ($ev, $box, $pl) = @_; 139 my ($box, $pl) = @_;
125 140
126 my @mails; 141 my @mails;
127 142
128 my %sent_targets; 143 my %sent_targets;
129 144
130 for ($box->inv) { 145 for ($box->inv) {
131 if ($_->name =~ m/^mail(scroll|warning) T: (\S+) F: (\S+)/) { 146 if ($_->name =~ m/^mail(scroll|warning) T: (\S+) F: (\S+)/) {
132 CFMail::send_mail ($1 eq 'scroll' ? 1 : 3, $2, $3, $_->message); 147 CFMail::send_mail ($1 eq 'scroll' ? 1 : 3, $2, $3, $_->message);
133 $pl->message ("Sent mail$1 to $2 (from $3)."); 148 $pl->message ("Sent mail$1 to $2 (from $3).");
134 $sent_targets{$2}++; 149 $sent_targets{$2}++;
135 push @mails, $_; 150 push @mails, $_;
136 151
137 } elsif ($_->name =~ m/^mail(scroll|warning) F: (\S+) T: (\S+)/) { 152 } elsif ($_->name =~ m/^mail(scroll|warning) F: (\S+) T: (\S+)/) {
138 # this is for mails that remain in the queue for the player 153 # this is for mails that remain in the queue for the player
139 CFMail::store_mail ($1 eq 'scroll' ? 1 : 3, $3, $2, $_->message); 154 CFMail::store_mail ($1 eq 'scroll' ? 1 : 3, $3, $2, $_->message);
140 push @mails, $_; 155 push @mails, $_;
141 } 156 }
142 } 157 }
143 158
144 $_->remove for @mails; 159 $_->remove for @mails;
145 160
146 # lets message player ingame: this is a NEW feature from the perl IPO :-) 161 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 } 162 },
158 163;
159 0;
160}
161 164
162# this is the main command interface for the IPO NPC 165# this is the main command interface for the IPO NPC
163cf::register_script_function "ipo::command" => sub { 166cf::register_script_function "ipo::command" => sub {
164 my ($who, $msg, $npc) = @_; 167 my ($who, $msg, $npc) = @_;
165 my ($cmd, $arguments) = split /\s+/, $msg, 2; 168 my ($cmd, $arguments) = split /\s+/, $msg, 2;
… …
224 } 227 }
225 } 228 }
226 229
227 if ($cnt) { 230 if ($cnt) {
228 $who->reply ($npc, $cnt == 1 ? "Package sent to $arguments." : "Sent $cnt packages to $arguments\n"); 231 $who->reply ($npc, $cnt == 1 ? "Package sent to $arguments." : "Sent $cnt packages to $arguments\n");
232 CFMail::send_mail (1, $arguments, $who->name, "You got $cnt packages from " . $who->name);
233 notify_players ($arguments => 1);
229 } else { 234 } else {
230 $who->reply ($npc, "Sorry, found no package to send to $arguments."); 235 $who->reply ($npc, "Sorry, found no package to send to $arguments.");
231 } 236 }
232 237
233 } else { 238 } else {
234 $who->reply ($npc, 239 $who->reply ($npc,
235 sprintf "How can I help you?\n" 240 sprintf "How can I help you?\n"
236 ."Here is a quick list of commands I understand:\n\n" 241 . "Here is a quick list of commands I understand:\n\n"
237 ."- pen (%s platinum)\n" 242 . "- pen (%s platinum)\n"
238 ."- literacy (%s platinum)\n" 243 . "- literacy (%s platinum)\n"
239 ."- mailscroll <friend> (%s platinum)\n" 244 . "- mailscroll <friend> (%s platinum)\n"
240 ."- bag <friend> (%s platinum)\n" 245 . "- bag <friend> (%s platinum)\n"
241 ."- package <friend> (%s platinum)\n" 246 . "- package <friend> (%s platinum)\n"
242 ."- carton <friend> (%s platinum)\n" 247 . "- carton <friend> (%s platinum)\n"
248 . "- send <friend> (send bags/packages/cartons)\n"
249 . "- receive (to receive packages for you)\n"
243 .($who->flag (cf::FLAG_WIZ) ? "- mailwarning <player>" : ""), 250 . ($who->flag (cf::FLAG_WIZ) ? "- mailwarning <player>" : ""),
244 40, 1000, 1, 1, 5, 10 251 40, 1000, 1, 1, 5, 10
245 ); 252 );
246 } 253 }
247 1 254 1
248}; 255};
249 256
250package CFMail; 257package CFMail;
251use YAML qw/LoadFile DumpFile Dump/; 258
252use POSIX qw/strftime/; 259use POSIX qw/strftime/;
260use CFDB;
253 261
254my $maildb_file = cf::localdir . "/crossfiremail.perl"; 262my $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 263
287sub get_mail { 264sub get_mail {
288 my ($toname) = @_; 265 my ($toname) = @_;
289 check_maildb;
290 $MAILDB->{$toname}; 266 $MAILDB->get ($toname);
291} 267}
292 268
293sub clear_mail { 269sub clear_mail {
294 my ($toname) = @_; 270 my ($toname) = @_;
295 check_maildb; 271 $MAILDB->clear ($toname);
296 $MAILDB->{$toname} = [];
297 sync_maildb;
298} 272}
299 273
300sub store_mail { 274sub store_mail {
301 my ($type, $toname, $fromname, $message) = @_; 275 my ($type, $toname, $fromname, $message) = @_;
302 check_maildb; 276 my $mails = $MAILDB->get ($toname);
303 push @{$MAILDB->{$toname}}, [$type, $fromname, $message]; 277 push @$mails, [$type, $fromname, $message];
304 sync_maildb; 278 $MAILDB->set ($toname, $mails);
305} 279}
306 280
307sub send_mail { 281sub send_mail {
308 my ($type, $toname, $fromname, $message) = @_; 282 my ($type, $toname, $fromname, $message) = @_;
309 my $time = strftime ("%a, %d %b %Y %H:%M:%S CEST", localtime (time)); 283 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"; 284 my $msg = "From: $fromname\nTo: $toname\nDate: $time\n\n$message\n";
311 check_maildb; 285 store_mail ($type, $toname, $fromname, $msg);
312 push @{$MAILDB->{$toname}}, [$type, $fromname, $msg];
313 sync_maildb;
314} 286}
315
316check_maildb ();
317 287
3181; 2881;

Diff Legend

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