ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.36 by root, Thu Aug 24 14:04:29 2006 UTC vs.
Revision 1.111 by root, Mon Jan 1 12:28:47 2007 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
5use Storable; 8use Storable;
6use Opcode; 9use Opcode;
7use Safe; 10use Safe;
8use Safe::Hole; 11use Safe::Hole;
9 12
13use Coro 3.3;
14use Coro::Event;
15use Coro::Timer;
16use Coro::Signal;
17use Coro::Semaphore;
18use Coro::AIO;
19
20use Digest::MD5;
21use Fcntl;
22use IO::AIO 2.31 ();
23use YAML::Syck ();
10use Time::HiRes; 24use Time::HiRes;
11use Event; 25
12$Event::Eval = 1; # no idea why this is required, but it is 26use Event; $Event::Eval = 1; # no idea why this is required, but it is
13 27
14use strict; 28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1;
15 30
16our %COMMAND; 31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
32
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35our %COMMAND = ();
36our %COMMAND_TIME = ();
37our %EXTCMD = ();
38
17our @EVENT; 39our @EVENT;
18our %PROP_TYPE; 40our $LIBDIR = datadir . "/ext";
19our %PROP_IDX;
20our $LIBDIR = maps_directory "perl";
21 41
22our $TICK = MAX_TIME * 1e-6; 42our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 43our $TICK_WATCHER;
24our $NEXT_TICK; 44our $NEXT_TICK;
45our $NOW;
46
47our %CFG;
48
49our $UPTIME; $UPTIME ||= time;
50our $RUNTIME;
51
52our %MAP; # all maps
53our $LINK_MAP; # the special {link} map
54our $FREEZE;
55our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO;
57
58binmode STDOUT;
59binmode STDERR;
60
61# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") {
63 open my $fh, "<", cf::localdir . "/runtime"
64 or die "unable to read runtime file: $!";
65 $RUNTIME = <$fh> + 0.;
66}
67
68mkdir cf::localdir;
69mkdir cf::localdir . "/" . cf::playerdir;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73
74# a special map that is always available
75our $LINK_MAP;
76
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37];
78
79#############################################################################
80
81=head2 GLOBAL VARIABLES
82
83=over 4
84
85=item $cf::UPTIME
86
87The timestamp of the server start (so not actually an uptime).
88
89=item $cf::RUNTIME
90
91The time this server has run, starts at 0 and is increased by $cf::TICK on
92every server tick.
93
94=item $cf::LIBDIR
95
96The perl library directory, where extensions and cf-specific modules can
97be found. It will be added to C<@INC> automatically.
98
99=item $cf::NOW
100
101The time of the last (current) server tick.
102
103=item $cf::TICK
104
105The interval between server ticks, in seconds.
106
107=item %cf::CFG
108
109Configuration for the server, loaded from C</etc/crossfire/config>, or
110from wherever your confdir points to.
111
112=back
113
114=cut
25 115
26BEGIN { 116BEGIN {
27 @EVENT = map lc, @EVENT;
28
29 *CORE::GLOBAL::warn = sub { 117 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 118 my $msg = join "", @_;
119 utf8::encode $msg;
120
31 $msg .= "\n" 121 $msg .= "\n"
32 unless $msg =~ /\n$/; 122 unless $msg =~ /\n$/;
33 123
34 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 124 LOG llevError, "cfperl: $msg";
36 }; 125 };
37} 126}
38 127
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
129@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
130@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
131@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
132@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
133@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
40 134
41# generate property mutators 135# we bless all objects into (empty) derived classes to force a method lookup
42sub prop_gen { 136# within the Safe compartment.
43 my ($prefix, $class) = @_; 137for my $pkg (qw(
44 138 cf::global cf::attachable
139 cf::object cf::object::player
140 cf::client cf::player
141 cf::arch cf::living
142 cf::map cf::party cf::region
143)) {
45 no strict 'refs'; 144 no strict 'refs';
46
47 for my $prop (keys %PROP_TYPE) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
49 my $sub = lc $1;
50
51 my $type = $PROP_TYPE{$prop};
52 my $idx = $PROP_IDX {$prop};
53
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
55 $_[0]->get_property ($type, $idx)
56 };
57
58 *{"$class\::set_$sub"} = sub {
59 $_[0]->set_property ($type, $idx, $_[1]);
60 } unless $ignore_set{$prop};
61 }
62}
63
64# auto-generate most of the API
65
66prop_gen OBJECT_PROP => "cf::object";
67# CFAPI_OBJECT_ANIMATION?
68prop_gen PLAYER_PROP => "cf::object::player";
69
70prop_gen MAP_PROP => "cf::map";
71prop_gen ARCH_PROP => "cf::arch";
72
73# guessed hierarchies
74
75@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
76@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
77
78# we bless all objects into derived classes to force a method lookup
79# within the Safe compartment.
80for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
81 no strict 'refs';
82 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 145 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
83} 146}
84 147
85$Event::DIED = sub { 148$Event::DIED = sub {
86 warn "error in event callback: @_"; 149 warn "error in event callback: @_";
87}; 150};
88 151
89my %ext_pkg; 152my %ext_pkg;
90my @exts; 153my @exts;
91my @hook; 154my @hook;
92my %command;
93my %extcmd;
94 155
95sub inject_event { 156=head2 UTILITY FUNCTIONS
96 my $extension = shift; 157
158=over 4
159
160=cut
161
162use JSON::Syck (); # TODO# replace by JSON::PC once working
163
164=item $ref = cf::from_json $json
165
166Converts a JSON string into the corresponding perl data structure.
167
168=cut
169
170sub from_json($) {
171 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
172 JSON::Syck::Load $_[0]
173}
174
175=item $json = cf::to_json $ref
176
177Converts a perl data structure into its JSON representation.
178
179=cut
180
181sub to_json($) {
182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
183 JSON::Syck::Dump $_[0]
184}
185
186=item cf::sync_job { BLOCK }
187
188The design of crossfire+ requires that the main coro ($Coro::main) is
189always able to handle events or runnable, as crossfire+ is only partly
190reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
191
192If it must be done, put the blocking parts into C<sync_job>. This will run
193the given BLOCK in another coroutine while waiting for the result. The
194server will be frozen during this time, so the block should either finish
195fast or be very important.
196
197=cut
198
199sub sync_job(&) {
200 my ($job) = @_;
201
202 my $busy = 1;
203 my @res;
204
205 my $coro = Coro::async {
206 @res = eval { $job->() };
207 warn $@ if $@;
208 undef $busy;
209 };
210
211 if ($Coro::current == $Coro::main) {
212 # TODO: use suspend/resume instead
213 local $FREEZE = 1;
214 $coro->prio (Coro::PRIO_MAX);
215 while ($busy) {
216 Coro::cede_notself;
217 Event::one_event unless Coro::nready;
218 }
219 } else {
220 $coro->join;
221 }
222
223 wantarray ? @res : $res[0]
224}
225
226=item $coro = cf::coro { BLOCK }
227
228Creates and returns a new coro. This coro is automcatially being canceled
229when the extension calling this is being unloaded.
230
231=cut
232
233sub coro(&) {
97 my $event_code = shift; 234 my $cb = shift;
98 235
99 my $cb = $hook[$event_code]{$extension} 236 my $coro; $coro = async {
237 eval {
238 $cb->();
239 };
240 warn $@ if $@;
241 };
242
243 $coro->on_destroy (sub {
244 delete $EXT_CORO{$coro+0};
245 });
246 $EXT_CORO{$coro+0} = $coro;
247
248 $coro
249}
250
251sub write_runtime {
252 my $runtime = cf::localdir . "/runtime";
253
254 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
100 or return; 255 or return;
101 256
102 &$cb 257 my $value = $cf::RUNTIME;
103} 258 (aio_write $fh, 0, (length $value), $value, 0) <= 0
259 and return;
104 260
105sub inject_global_event { 261 aio_fsync $fh
262 and return;
263
264 close $fh
265 or return;
266
267 aio_rename "$runtime~", $runtime
268 and return;
269
270 1
271}
272
273=back
274
275=cut
276
277#############################################################################
278
279package cf::path;
280
281sub new {
282 my ($class, $path, $base) = @_;
283
284 $path = $path->as_string if ref $path;
285
286 my $self = bless { }, $class;
287
288 if ($path =~ s{^\?random/}{}) {
289 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
290 $self->{random} = cf::from_json $data;
291 } else {
292 if ($path =~ s{^~([^/]+)?}{}) {
293 $self->{user_rel} = 1;
294
295 if (defined $1) {
296 $self->{user} = $1;
297 } elsif ($base =~ m{^~([^/]+)/}) {
298 $self->{user} = $1;
299 } else {
300 warn "cannot resolve user-relative path without user <$path,$base>\n";
301 }
302 } elsif ($path =~ /^\//) {
303 # already absolute
304 } else {
305 $base =~ s{[^/]+/?$}{};
306 return $class->new ("$base/$path");
307 }
308
309 for ($path) {
310 redo if s{/\.?/}{/};
311 redo if s{/[^/]+/\.\./}{/};
312 }
313 }
314
315 $self->{path} = $path;
316
317 $self
318}
319
320# the name / primary key / in-game path
321sub as_string {
322 my ($self) = @_;
323
324 $self->{user_rel} ? "~$self->{user}$self->{path}"
325 : $self->{random} ? "?random/$self->{path}"
326 : $self->{path}
327}
328
329# the displayed name, this is a one way mapping
330sub visible_name {
331 my ($self) = @_;
332
333# if (my $rmp = $self->{random}) {
334# # todo: be more intelligent about this
335# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
336# } else {
337 $self->as_string
338# }
339}
340
341# escape the /'s in the path
342sub _escaped_path {
343 # ∕ is U+2215
344 (my $path = $_[0]{path}) =~ s/\//∕/g;
345 $path
346}
347
348# the original (read-only) location
349sub load_path {
350 my ($self) = @_;
351
352 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
353}
354
355# the temporary/swap location
356sub save_path {
357 my ($self) = @_;
358
359 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
360 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
361 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
362}
363
364# the unique path, might be eq to save_path
365sub uniq_path {
366 my ($self) = @_;
367
368 $self->{user_rel} || $self->{random}
369 ? undef
370 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
371}
372
373# return random map parameters, or undef
374sub random_map_params {
375 my ($self) = @_;
376
377 $self->{random}
378}
379
380# this is somewhat ugly, but style maps do need special treatment
381sub is_style_map {
382 $_[0]{path} =~ m{^/styles/}
383}
384
385package cf;
386
387#############################################################################
388
389=head2 ATTACHABLE OBJECTS
390
391Many objects in crossfire are so-called attachable objects. That means you can
392attach callbacks/event handlers (a collection of which is called an "attachment")
393to it. All such attachable objects support the following methods.
394
395In the following description, CLASS can be any of C<global>, C<object>
396C<player>, C<client> or C<map> (i.e. the attachable objects in
397crossfire+).
398
399=over 4
400
401=item $attachable->attach ($attachment, key => $value...)
402
403=item $attachable->detach ($attachment)
404
405Attach/detach a pre-registered attachment to a specific object and give it
406the specified key/value pairs as arguments.
407
408Example, attach a minesweeper attachment to the given object, making it a
40910x10 minesweeper game:
410
411 $obj->attach (minesweeper => width => 10, height => 10);
412
413=item $bool = $attachable->attached ($name)
414
415Checks wether the named attachment is currently attached to the object.
416
417=item cf::CLASS->attach ...
418
419=item cf::CLASS->detach ...
420
421Define an anonymous attachment and attach it to all objects of the given
422CLASS. See the next function for an explanation of its arguments.
423
424You can attach to global events by using the C<cf::global> class.
425
426Example, log all player logins:
427
428 cf::player->attach (
429 on_login => sub {
430 my ($pl) = @_;
431 ...
432 },
433 );
434
435Example, attach to the jeweler skill:
436
437 cf::object->attach (
438 type => cf::SKILL,
439 subtype => cf::SK_JEWELER,
440 on_use_skill => sub {
441 my ($sk, $ob, $part, $dir, $msg) = @_;
442 ...
443 },
444 );
445
446=item cf::CLASS::attachment $name, ...
447
448Register an attachment by C<$name> through which attachable objects of the
449given CLASS can refer to this attachment.
450
451Some classes such as crossfire maps and objects can specify attachments
452that are attached at load/instantiate time, thus the need for a name.
453
454These calls expect any number of the following handler/hook descriptions:
455
456=over 4
457
458=item prio => $number
459
460Set the priority for all following handlers/hooks (unless overwritten
461by another C<prio> setting). Lower priority handlers get executed
462earlier. The default priority is C<0>, and many built-in handlers are
463registered at priority C<-1000>, so lower priorities should not be used
464unless you know what you are doing.
465
466=item type => $type
467
468(Only for C<< cf::object->attach >> calls), limits the attachment to the
469given type of objects only (the additional parameter C<subtype> can be
470used to further limit to the given subtype).
471
472=item on_I<event> => \&cb
473
474Call the given code reference whenever the named event happens (event is
475something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
476handlers are recognised generally depends on the type of object these
477handlers attach to).
478
479See F<include/eventinc.h> for the full list of events supported, and their
480class.
481
482=item package => package::
483
484Look for sub functions of the name C<< on_I<event> >> in the given
485package and register them. Only handlers for eevents supported by the
486object/class are recognised.
487
488=back
489
490Example, define an attachment called "sockpuppet" that calls the given
491event handler when a monster attacks:
492
493 cf::object::attachment sockpuppet =>
494 on_skill_attack => sub {
495 my ($self, $victim) = @_;
496 ...
497 }
498 }
499
500=item $attachable->valid
501
502Just because you have a perl object does not mean that the corresponding
503C-level object still exists. If you try to access an object that has no
504valid C counterpart anymore you get an exception at runtime. This method
505can be used to test for existence of the C object part without causing an
506exception.
507
508=cut
509
510# the following variables are defined in .xs and must not be re-created
511our @CB_GLOBAL = (); # registry for all global events
512our @CB_ATTACHABLE = (); # registry for all attachables
513our @CB_OBJECT = (); # all objects (should not be used except in emergency)
514our @CB_PLAYER = ();
515our @CB_CLIENT = ();
516our @CB_TYPE = (); # registry for type (cf-object class) based events
517our @CB_MAP = ();
518
519my %attachment;
520
521sub _attach_cb($$$$) {
522 my ($registry, $event, $prio, $cb) = @_;
523
524 use sort 'stable';
525
526 $cb = [$prio, $cb];
527
528 @{$registry->[$event]} = sort
529 { $a->[0] cmp $b->[0] }
530 @{$registry->[$event] || []}, $cb;
531}
532
533# hack
534my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
535
536# attach handles attaching event callbacks
537# the only thing the caller has to do is pass the correct
538# registry (== where the callback attaches to).
539sub _attach {
540 my ($registry, $klass, @arg) = @_;
541
542 my $object_type;
543 my $prio = 0;
544 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
545
546 #TODO: get rid of this hack
547 if ($attachable_klass{$klass}) {
548 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
549 }
550
551 while (@arg) {
552 my $type = shift @arg;
553
554 if ($type eq "prio") {
555 $prio = shift @arg;
556
557 } elsif ($type eq "type") {
558 $object_type = shift @arg;
559 $registry = $CB_TYPE[$object_type] ||= [];
560
561 } elsif ($type eq "subtype") {
562 defined $object_type or Carp::croak "subtype specified without type";
563 my $object_subtype = shift @arg;
564 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
565
566 } elsif ($type eq "package") {
567 my $pkg = shift @arg;
568
569 while (my ($name, $id) = each %cb_id) {
570 if (my $cb = $pkg->can ($name)) {
571 _attach_cb $registry, $id, $prio, $cb;
572 }
573 }
574
575 } elsif (exists $cb_id{$type}) {
576 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
577
578 } elsif (ref $type) {
579 warn "attaching objects not supported, ignoring.\n";
580
581 } else {
582 shift @arg;
583 warn "attach argument '$type' not supported, ignoring.\n";
584 }
585 }
586}
587
588sub _object_attach {
589 my ($obj, $name, %arg) = @_;
590
591 return if exists $obj->{_attachment}{$name};
592
593 if (my $attach = $attachment{$name}) {
594 my $registry = $obj->registry;
595
596 for (@$attach) {
597 my ($klass, @attach) = @$_;
598 _attach $registry, $klass, @attach;
599 }
600
601 $obj->{$name} = \%arg;
602 } else {
603 warn "object uses attachment '$name' that is not available, postponing.\n";
604 }
605
606 $obj->{_attachment}{$name} = undef;
607}
608
609sub cf::attachable::attach {
610 if (ref $_[0]) {
611 _object_attach @_;
612 } else {
613 _attach shift->_attach_registry, @_;
614 }
615};
616
617# all those should be optimised
618sub cf::attachable::detach {
619 my ($obj, $name) = @_;
620
621 if (ref $obj) {
622 delete $obj->{_attachment}{$name};
623 reattach ($obj);
624 } else {
625 Carp::croak "cannot, currently, detach class attachments";
626 }
627};
628
629sub cf::attachable::attached {
630 my ($obj, $name) = @_;
631
632 exists $obj->{_attachment}{$name}
633}
634
635for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
636 eval "#line " . __LINE__ . " 'cf.pm'
637 sub cf::\L$klass\E::_attach_registry {
638 (\\\@CB_$klass, KLASS_$klass)
639 }
640
641 sub cf::\L$klass\E::attachment {
642 my \$name = shift;
643
644 \$attachment{\$name} = [[KLASS_$klass, \@_]];
645 }
646 ";
647 die if $@;
648}
649
650our $override;
651our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
652
653sub override {
654 $override = 1;
655 @invoke_results = ();
656}
657
658sub do_invoke {
106 my $event = shift; 659 my $event = shift;
660 my $callbacks = shift;
107 661
108 my $cb = $hook[$event] 662 @invoke_results = ();
663
664 local $override;
665
666 for (@$callbacks) {
667 eval { &{$_->[1]} };
668
669 if ($@) {
670 warn "$@";
671 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
672 override;
673 }
674
675 return 1 if $override;
676 }
677
678 0
679}
680
681=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
682
683=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
684
685Generate an object-specific event with the given arguments.
686
687This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
688removed in future versions), and there is no public API to access override
689results (if you must, access C<@cf::invoke_results> directly).
690
691=back
692
693=cut
694
695#############################################################################
696# object support
697
698sub reattach {
699 # basically do the same as instantiate, without calling instantiate
700 my ($obj) = @_;
701
702 my $registry = $obj->registry;
703
704 @$registry = ();
705
706 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
707
708 for my $name (keys %{ $obj->{_attachment} || {} }) {
709 if (my $attach = $attachment{$name}) {
710 for (@$attach) {
711 my ($klass, @attach) = @$_;
712 _attach $registry, $klass, @attach;
713 }
714 } else {
715 warn "object uses attachment '$name' that is not available, postponing.\n";
716 }
717 }
718}
719
720cf::attachable->attach (
721 prio => -1000000,
722 on_instantiate => sub {
723 my ($obj, $data) = @_;
724
725 $data = from_json $data;
726
727 for (@$data) {
728 my ($name, $args) = @$_;
729
730 $obj->attach ($name, %{$args || {} });
731 }
732 },
733 on_reattach => \&reattach,
734 on_clone => sub {
735 my ($src, $dst) = @_;
736
737 @{$dst->registry} = @{$src->registry};
738
739 %$dst = %$src;
740
741 %{$dst->{_attachment}} = %{$src->{_attachment}}
742 if exists $src->{_attachment};
743 },
744);
745
746sub object_freezer_save {
747 my ($filename, $rdata, $objs) = @_;
748
749 sync_job {
750 if (length $$rdata) {
751 warn sprintf "saving %s (%d,%d)\n",
752 $filename, length $$rdata, scalar @$objs;
753
754 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
755 chmod SAVE_MODE, $fh;
756 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
757 aio_fsync $fh;
758 close $fh;
759
760 if (@$objs) {
761 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
762 chmod SAVE_MODE, $fh;
763 my $data = Storable::nfreeze { version => 1, objs => $objs };
764 aio_write $fh, 0, (length $data), $data, 0;
765 aio_fsync $fh;
766 close $fh;
767 aio_rename "$filename.pst~", "$filename.pst";
768 }
769 } else {
770 aio_unlink "$filename.pst";
771 }
772
773 aio_rename "$filename~", $filename;
774 } else {
775 warn "FATAL: $filename~: $!\n";
776 }
777 } else {
778 aio_unlink $filename;
779 aio_unlink "$filename.pst";
780 }
781 }
782}
783
784sub object_freezer_as_string {
785 my ($rdata, $objs) = @_;
786
787 use Data::Dumper;
788
789 $$rdata . Dumper $objs
790}
791
792sub object_thawer_load {
793 my ($filename) = @_;
794
795 my ($data, $av);
796
797 (aio_load $filename, $data) >= 0
109 or return; 798 or return;
110 799
111 List::Util::max map &$_, values %$cb 800 unless (aio_stat "$filename.pst") {
112} 801 (aio_load "$filename.pst", $av) >= 0
113 802 or return;
114sub inject_command { 803 $av = eval { (Storable::thaw <$av>)->{objs} };
115 my ($name, $obj, $params) = @_;
116
117 for my $cmd (@{ $command{$name} }) {
118 $cmd->[1]->($obj, $params);
119 } 804 }
120 805
121 -1 806 return ($data, $av);
122} 807}
808
809#############################################################################
810# command handling &c
811
812=item cf::register_command $name => \&callback($ob,$args);
813
814Register a callback for execution when the client sends the user command
815$name.
816
817=cut
123 818
124sub register_command { 819sub register_command {
125 my ($name, $time, $cb) = @_; 820 my ($name, $cb) = @_;
126 821
127 my $caller = caller; 822 my $caller = caller;
128 #warn "registering command '$name/$time' to '$caller'"; 823 #warn "registering command '$name/$time' to '$caller'";
129 824
130 push @{ $command{$name} }, [$time, $cb, $caller]; 825 push @{ $COMMAND{$name} }, [$caller, $cb];
131 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
132} 826}
827
828=item cf::register_extcmd $name => \&callback($pl,$packet);
829
830Register a callbackf ro execution when the client sends an extcmd packet.
831
832If the callback returns something, it is sent back as if reply was being
833called.
834
835=cut
133 836
134sub register_extcmd { 837sub register_extcmd {
135 my ($name, $cb) = @_; 838 my ($name, $cb) = @_;
136 839
137 my $caller = caller; 840 my $caller = caller;
138 #warn "registering extcmd '$name' to '$caller'"; 841 #warn "registering extcmd '$name' to '$caller'";
139 842
140 $extcmd{$name} = [$cb, $caller]; 843 $EXTCMD{$name} = [$cb, $caller];
141} 844}
845
846cf::player->attach (
847 on_command => sub {
848 my ($pl, $name, $params) = @_;
849
850 my $cb = $COMMAND{$name}
851 or return;
852
853 for my $cmd (@$cb) {
854 $cmd->[1]->($pl->ob, $params);
855 }
856
857 cf::override;
858 },
859 on_extcmd => sub {
860 my ($pl, $buf) = @_;
861
862 my $msg = eval { from_json $buf };
863
864 if (ref $msg) {
865 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
866 if (my %reply = $cb->[0]->($pl, $msg)) {
867 $pl->ext_reply ($msg->{msgid}, %reply);
868 }
869 }
870 } else {
871 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
872 }
873
874 cf::override;
875 },
876);
142 877
143sub register { 878sub register {
144 my ($base, $pkg) = @_; 879 my ($base, $pkg) = @_;
145 880
146 for my $idx (0 .. $#EVENT) { 881 #TODO
147 if (my $ref = $pkg->can ("on_$EVENT[$idx]")) {
148 #warn "registering $EVENT[$idx] hook to '$pkg'\n";
149 $hook[$idx]{$base} = $ref;
150 }
151 }
152} 882}
153 883
154sub load_extension { 884sub load_extension {
155 my ($path) = @_; 885 my ($path) = @_;
156 886
157 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 887 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
158 my $base = $1; 888 my $base = $1;
159 my $pkg = $1; 889 my $pkg = $1;
160 $pkg =~ s/[^[:word:]]/_/g; 890 $pkg =~ s/[^[:word:]]/_/g;
161 $pkg = "cf::ext::$pkg"; 891 $pkg = "ext::$pkg";
162 892
163 warn "loading '$path' into '$pkg'\n"; 893 warn "loading '$path' into '$pkg'\n";
164 894
165 open my $fh, "<:utf8", $path 895 open my $fh, "<:utf8", $path
166 or die "$path: $!"; 896 or die "$path: $!";
170 . "#line 1 \"$path\"\n{\n" 900 . "#line 1 \"$path\"\n{\n"
171 . (do { local $/; <$fh> }) 901 . (do { local $/; <$fh> })
172 . "\n};\n1"; 902 . "\n};\n1";
173 903
174 eval $source 904 eval $source
175 or die "$path: $@"; 905 or die $@ ? "$path: $@\n"
906 : "extension disabled.\n";
176 907
177 push @exts, $pkg; 908 push @exts, $pkg;
178 $ext_pkg{$base} = $pkg; 909 $ext_pkg{$base} = $pkg;
179 910
180# no strict 'refs'; 911# no strict 'refs';
187 my ($pkg) = @_; 918 my ($pkg) = @_;
188 919
189 warn "removing extension $pkg\n"; 920 warn "removing extension $pkg\n";
190 921
191 # remove hooks 922 # remove hooks
923 #TODO
192 for my $idx (0 .. $#EVENT) { 924# for my $idx (0 .. $#PLUGIN_EVENT) {
193 delete $hook[$idx]{$pkg}; 925# delete $hook[$idx]{$pkg};
194 } 926# }
195 927
196 # remove commands 928 # remove commands
197 for my $name (keys %command) { 929 for my $name (keys %COMMAND) {
198 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 930 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
199 931
200 if (@cb) { 932 if (@cb) {
201 $command{$name} = \@cb; 933 $COMMAND{$name} = \@cb;
202 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
203 } else { 934 } else {
204 delete $command{$name};
205 delete $COMMAND{"$name\000"}; 935 delete $COMMAND{$name};
206 } 936 }
207 } 937 }
208 938
209 # remove extcmds 939 # remove extcmds
210 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 940 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
211 delete $extcmd{$name}; 941 delete $EXTCMD{$name};
212 } 942 }
213 943
214 if (my $cb = $pkg->can ("on_unload")) { 944 if (my $cb = $pkg->can ("unload")) {
215 eval { 945 eval {
216 $cb->($pkg); 946 $cb->($pkg);
217 1 947 1
218 } or warn "$pkg unloaded, but with errors: $@"; 948 } or warn "$pkg unloaded, but with errors: $@";
219 } 949 }
220 950
221 Symbol::delete_package $pkg; 951 Symbol::delete_package $pkg;
222} 952}
223 953
224sub load_extensions { 954sub load_extensions {
225 my $LIBDIR = maps_directory "perl";
226
227 for my $ext (<$LIBDIR/*.ext>) { 955 for my $ext (<$LIBDIR/*.ext>) {
228 next unless -r $ext; 956 next unless -r $ext;
229 eval { 957 eval {
230 load_extension $ext; 958 load_extension $ext;
231 1 959 1
232 } or warn "$ext not loaded: $@"; 960 } or warn "$ext not loaded: $@";
233 } 961 }
234} 962}
235 963
236sub _perl_reload(&) {
237 my ($msg) = @_;
238
239 $msg->("reloading...");
240
241 eval {
242 # 1. cancel all watchers
243 $_->cancel for Event::all_watchers;
244
245 # 2. unload all extensions
246 for (@exts) {
247 $msg->("unloading <$_>");
248 unload_extension $_;
249 }
250
251 # 3. unload all modules loaded from $LIBDIR
252 while (my ($k, $v) = each %INC) {
253 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
254
255 $msg->("removing <$k>");
256 delete $INC{$k};
257
258 $k =~ s/\.pm$//;
259 $k =~ s/\//::/g;
260
261 if (my $cb = $k->can ("unload_module")) {
262 $cb->();
263 }
264
265 Symbol::delete_package $k;
266 }
267
268 # 4. get rid of ext::, as good as possible
269 Symbol::delete_package "ext::$_"
270 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
271
272 # 5. remove register_script_function callbacks
273 # TODO
274
275 # 6. unload cf.pm "a bit"
276 delete $INC{"cf.pm"};
277
278 # don't, removes xs symbols, too
279 #Symbol::delete_package __PACKAGE__;
280
281 # 7. reload cf.pm
282 $msg->("reloading cf.pm");
283 require cf;
284 };
285 $msg->($@) if $@;
286
287 $msg->("reloaded");
288};
289
290sub perl_reload() {
291 _perl_reload {
292 warn $_[0];
293 print "$_[0]\n";
294 };
295}
296
297register_command "perl-reload", 0, sub {
298 my ($who, $arg) = @_;
299
300 if ($who->flag (FLAG_WIZ)) {
301 _perl_reload {
302 warn $_[0];
303 $who->message ($_[0]);
304 };
305 }
306};
307
308#############################################################################
309# utility functions
310
311use JSON::Syck (); # TODO# replace by JSON::PC once working
312
313sub from_json($) {
314 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
315 JSON::Syck::Load $_[0]
316}
317
318sub to_json($) {
319 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
320 JSON::Syck::Dump $_[0]
321}
322
323#############################################################################
324# extcmd framework, basically convert ext <msg>
325# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
326
327sub on_extcmd {
328 my ($pl, $buf) = @_;
329
330 my $msg = eval { from_json $buf };
331
332 if (ref $msg) {
333 if (my $cb = $extcmd{$msg->{msgtype}}) {
334 if (my %reply = $cb->[0]->($pl, $msg)) {
335 $pl->ext_reply ($msg->{msgid}, %reply);
336 }
337 }
338 } else {
339 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
340 }
341
342 1
343}
344
345############################################################################# 964#############################################################################
346# load/save/clean perl data associated with a map 965# load/save/clean perl data associated with a map
347 966
348*on_mapclean = sub { 967*cf::mapsupport::on_clean = sub {
349 my ($map) = @_; 968 my ($map) = @_;
350 969
351 my $path = $map->tmpname; 970 my $path = $map->tmpname;
352 defined $path or return; 971 defined $path or return;
353 972
354 unlink "$path.cfperl"; 973 unlink "$path.pst";
355}; 974};
356 975
357*on_mapin = 976cf::map->attach (prio => -10000, package => cf::mapsupport::);
358*on_mapload = sub {
359 my ($map) = @_;
360
361 my $path = $map->tmpname;
362 $path = $map->path unless defined $path;
363
364 open my $fh, "<:raw", "$path.cfperl"
365 or return; # no perl data
366
367 my $data = Storable::thaw do { local $/; <$fh> };
368
369 $data->{version} <= 1
370 or return; # too new
371
372 $map->_set_obs ($data->{obs});
373};
374
375*on_mapout = sub {
376 my ($map) = @_;
377
378 my $path = $map->tmpname;
379 $path = $map->path unless defined $path;
380
381 my $obs = $map->_get_obs;
382
383 if (defined $obs) {
384 open my $fh, ">:raw", "$path.cfperl"
385 or die "$path.cfperl: $!";
386
387 stat $path;
388
389 print $fh Storable::nfreeze {
390 size => (stat _)[7],
391 time => (stat _)[9],
392 version => 1,
393 obs => $obs,
394 };
395
396 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
397 } else {
398 unlink "$path.cfperl";
399 }
400};
401 977
402############################################################################# 978#############################################################################
403# load/save perl data associated with player->ob objects 979# load/save perl data associated with player->ob objects
404 980
405sub all_objects(@) { 981sub all_objects(@) {
406 @_, map all_objects ($_->inv), @_ 982 @_, map all_objects ($_->inv), @_
407} 983}
408 984
409*on_player_load = sub { 985# TODO: compatibility cruft, remove when no longer needed
986cf::player->attach (
987 on_load => sub {
410 my ($ob, $path) = @_; 988 my ($pl, $path) = @_;
411 989
412 for my $o (all_objects $ob) { 990 for my $o (all_objects $pl->ob) {
413 if (my $value = $o->get_ob_key_value ("_perl_data")) { 991 if (my $value = $o->get_ob_key_value ("_perl_data")) {
414 $o->set_ob_key_value ("_perl_data"); 992 $o->set_ob_key_value ("_perl_data");
415 993
416 %$o = %{ Storable::thaw pack "H*", $value }; 994 %$o = %{ Storable::thaw pack "H*", $value };
417 } 995 }
996 }
418 } 997 },
419}; 998);
420
421*on_player_save = sub {
422 my ($ob, $path) = @_;
423
424 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
425 for grep %$_, all_objects $ob;
426};
427 999
428############################################################################# 1000#############################################################################
429# core extensions - in perl 1001
1002=head2 CORE EXTENSIONS
1003
1004Functions and methods that extend core crossfire objects.
1005
1006=head3 cf::player
1007
1008=over 4
430 1009
431=item cf::player::exists $login 1010=item cf::player::exists $login
432 1011
433Returns true when the given account exists. 1012Returns true when the given account exists.
434 1013
437sub cf::player::exists($) { 1016sub cf::player::exists($) {
438 cf::player::find $_[0] 1017 cf::player::find $_[0]
439 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1018 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
440} 1019}
441 1020
1021=item $player->ext_reply ($msgid, $msgtype, %msg)
1022
1023Sends an ext reply to the player.
1024
1025=cut
1026
1027sub cf::player::ext_reply($$$%) {
1028 my ($self, $id, %msg) = @_;
1029
1030 $msg{msgid} = $id;
1031
1032 $self->send ("ext " . to_json \%msg);
1033}
1034
1035=back
1036
1037
1038=head3 cf::map
1039
1040=over 4
1041
1042=cut
1043
1044package cf::map;
1045
1046use Fcntl;
1047use Coro::AIO;
1048
1049our $MAX_RESET = 7200;
1050our $DEFAULT_RESET = 3600;
1051$MAX_RESET = 10;#d#
1052$DEFAULT_RESET = 10;#d#
1053
1054sub generate_random_map {
1055 my ($path, $rmp) = @_;
1056
1057 # mit "rum" bekleckern, nicht
1058 cf::map::_create_random_map
1059 $path,
1060 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1061 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1062 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1063 $rmp->{exit_on_final_map},
1064 $rmp->{xsize}, $rmp->{ysize},
1065 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1066 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1067 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1068 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1069 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1070 (cf::region::find $rmp->{region})
1071}
1072
1073# and all this just because we cannot iterate over
1074# all maps in C++...
1075sub change_all_map_light {
1076 my ($change) = @_;
1077
1078 $_->change_map_light ($change) for values %cf::MAP;
1079}
1080
1081sub try_load_header($) {
1082 my ($path) = @_;
1083
1084 utf8::encode $path;
1085 aio_open $path, O_RDONLY, 0
1086 or return;
1087
1088 my $map = cf::map::new
1089 or return;
1090
1091 $map->load_header ($path)
1092 or return;
1093
1094 $map->{load_path} = $path;
1095 use Data::Dumper; warn Dumper $map;#d#
1096
1097 $map
1098}
1099
1100sub find_map {
1101 my ($path, $origin) = @_;
1102
1103 #warn "find_map<$path,$origin>\n";#d#
1104
1105 $path = ref $path ? $path : new cf::path $path, $origin && $origin->path;
1106 my $key = $path->as_string;
1107
1108 $cf::MAP{$key} || do {
1109 # do it the slow way
1110 my $map = try_load_header $path->save_path;
1111
1112 if ($map) {
1113 # safety
1114 $map->{instantiate_time} = $cf::RUNTIME
1115 if $map->{instantiate_time} > $cf::RUNTIME;
1116 } else {
1117 if (my $rmp = $path->random_map_params) {
1118 $map = generate_random_map $key, $rmp;
1119 } else {
1120 $map = try_load_header $path->load_path;
1121 }
1122
1123 $map or return;
1124
1125 $map->{load_original} = 1;
1126 $map->{instantiate_time} = $cf::RUNTIME;
1127 $map->instantiate;
1128
1129 # per-player maps become, after loading, normal maps
1130 $map->per_player (0) if $path->{user_rel};
1131 }
1132
1133 $map->path ($key);
1134 $map->{path} = $path;
1135 $map->last_access ($cf::RUNTIME);
1136
1137 $map->reset if $map->should_reset;
1138
1139 $cf::MAP{$key} = $map
1140 }
1141}
1142
1143sub load {
1144 my ($self) = @_;
1145
1146 return if $self->in_memory != cf::MAP_SWAPPED;
1147
1148 $self->in_memory (cf::MAP_LOADING);
1149
1150 my $path = $self->{path};
1151
1152 $self->alloc;
1153 $self->load_objects ($self->{load_path}, 1)
1154 or return;
1155
1156 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) if delete $self->{load_original};
1157
1158 if (my $uniq = $path->uniq_path) {
1159 utf8::encode $uniq;
1160 if (aio_open $uniq, O_RDONLY, 0) {
1161 $self->clear_unique_items;
1162 $self->load_objects ($uniq, 0);
1163 }
1164 }
1165
1166 # now do the right thing for maps
1167 $self->link_multipart_objects;
1168
1169 if ($self->{path}->is_style_map) {
1170 $self->{deny_save} = 1;
1171 $self->{deny_reset} = 1;
1172 } else {
1173 $self->fix_auto_apply;
1174 $self->decay_objects;
1175 $self->update_buttons;
1176 $self->set_darkness_map;
1177 $self->difficulty ($self->estimate_difficulty)
1178 unless $self->difficulty;
1179 $self->activate;
1180 }
1181
1182 $self->in_memory (cf::MAP_IN_MEMORY);
1183}
1184
1185sub load_map_sync {
1186 my ($path, $origin) = @_;
1187
1188 #warn "load_map_sync<$path, $origin>\n";#d#
1189
1190 cf::sync_job {
1191 my $map = cf::map::find_map $path, $origin
1192 or return;
1193 $map->load;
1194 $map
1195 }
1196}
1197
1198sub save {
1199 my ($self) = @_;
1200
1201 my $save = $self->{path}->save_path; utf8::encode $save;
1202 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1203
1204 $self->{last_save} = $cf::RUNTIME;
1205
1206 return unless $self->dirty;
1207
1208 $self->{load_path} = $save;
1209
1210 return if $self->{deny_save};
1211
1212 warn "saving map ", $self->path;
1213
1214 if ($uniq) {
1215 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1216 $self->save_objects ($uniq, cf::IO_UNIQUES);
1217 } else {
1218 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1219 }
1220}
1221
1222sub swap_out {
1223 my ($self) = @_;
1224
1225 return if $self->players;
1226 return if $self->in_memory != cf::MAP_IN_MEMORY;
1227 return if $self->{deny_save};
1228
1229 $self->save;
1230 $self->clear;
1231 $self->in_memory (cf::MAP_SWAPPED);
1232}
1233
1234sub should_reset {
1235 my ($map) = @_;
1236
1237 # TODO: safety, remove and allow resettable per-player maps
1238 return if $map->{path}{user_rel};#d#
1239 return if $map->{deny_reset};
1240 #return unless $map->reset_timeout;
1241
1242 my $time = $map->fixed_resettime ? $map->{instantiate_time} : $map->last_access;
1243 my $to = $map->reset_timeout || $DEFAULT_RESET;
1244 $to = $MAX_RESET if $to > $MAX_RESET;
1245
1246 $time + $to < $cf::RUNTIME
1247}
1248
1249sub unlink_save {
1250 my ($self) = @_;
1251
1252 utf8::encode (my $save = $self->{path}->save_path);
1253 aioreq_pri 3; IO::AIO::aio_unlink $save;
1254 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1255}
1256
1257sub reset {
1258 my ($self) = @_;
1259
1260 return if $self->players;
1261 return if $self->{path}{user_rel};#d#
1262
1263 warn "resetting map ", $self->path;#d#
1264
1265 delete $cf::MAP{$self->path};
1266
1267 $_->clear_links_to ($self) for values %cf::MAP;
1268
1269 $self->unlink_save;
1270 $self->destroy;
1271}
1272
1273sub customise_for {
1274 my ($map, $ob) = @_;
1275
1276 if ($map->per_player) {
1277 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
1278 }
1279
1280 $map
1281}
1282
1283sub emergency_save {
1284 local $cf::FREEZE = 1;
1285
1286 warn "enter emergency map save\n";
1287
1288 cf::sync_job {
1289 warn "begin emergency map save\n";
1290 $_->save for values %cf::MAP;
1291 };
1292
1293 warn "end emergency map save\n";
1294}
1295
1296package cf;
1297
1298=back
1299
1300
1301=head3 cf::object::player
1302
1303=over 4
1304
442=item $player->reply ($npc, $msg[, $flags]) 1305=item $player_object->reply ($npc, $msg[, $flags])
443 1306
444Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 1307Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
445can be C<undef>. Does the right thing when the player is currently in a 1308can be C<undef>. Does the right thing when the player is currently in a
446dialogue with the given NPC character. 1309dialogue with the given NPC character.
447 1310
448=cut 1311=cut
449 1312
450# rough implementation of a future "reply" method that works 1313# rough implementation of a future "reply" method that works
451# with dialog boxes. 1314# with dialog boxes.
1315#TODO: the first argument must go, split into a $npc->reply_to ( method
452sub cf::object::player::reply($$$;$) { 1316sub cf::object::player::reply($$$;$) {
453 my ($self, $npc, $msg, $flags) = @_; 1317 my ($self, $npc, $msg, $flags) = @_;
454 1318
455 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1319 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
456 1320
460 $msg = $npc->name . " says: $msg" if $npc; 1324 $msg = $npc->name . " says: $msg" if $npc;
461 $self->message ($msg, $flags); 1325 $self->message ($msg, $flags);
462 } 1326 }
463} 1327}
464 1328
465=item $player->ext_reply ($msgid, $msgtype, %msg) 1329=item $player_object->may ("access")
466 1330
467Sends an ext reply to the player. 1331Returns wether the given player is authorized to access resource "access"
1332(e.g. "command_wizcast").
468 1333
469=cut 1334=cut
470 1335
471sub cf::player::ext_reply($$$%) { 1336sub cf::object::player::may {
1337 my ($self, $access) = @_;
1338
1339 $self->flag (cf::FLAG_WIZ) ||
1340 (ref $cf::CFG{"may_$access"}
1341 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1342 : $cf::CFG{"may_$access"})
1343}
1344
1345sub cf::object::player::enter_link {
1346 my ($self) = @_;
1347
1348 return if $self->map == $LINK_MAP;
1349
1350 $self->{_link_pos} = [$self->map->{path}, $self->x, $self->y]
1351 if $self->map;
1352
1353 $self->enter_map ($LINK_MAP, 20, 20);
1354 $self->deactivate_recursive;
1355}
1356
1357sub cf::object::player::leave_link {
1358 my ($self, $map, $x, $y) = @_;
1359
1360 my $link_pos = delete $self->{_link_pos};
1361
1362 unless ($map) {
1363 $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1364
1365 # restore original map position
1366 ($map, $x, $y) = @{ $link_pos || [] };
1367 $map = cf::map::find_map $map;
1368
1369 unless ($map) {
1370 ($map, $x, $y) = @$EMERGENCY_POSITION;
1371 $map = cf::map::find_map $map
1372 or die "FATAL: cannot load emergency map\n";
1373 }
1374 }
1375
1376 ($x, $y) = (-1, -1)
1377 unless (defined $x) && (defined $y);
1378
1379 # use -1 or undef as default coordinates, not 0, 0
1380 ($x, $y) = ($map->enter_x, $map->enter_y)
1381 if $x <=0 && $y <= 0;
1382
1383 $map->load;
1384
1385 $self->activate_recursive;
1386 $self->enter_map ($map, $x, $y);
1387}
1388
1389=item $player_object->goto_map ($map, $x, $y)
1390
1391=cut
1392
1393sub cf::object::player::goto_map {
1394 my ($self, $path, $x, $y) = @_;
1395
1396 $self->enter_link;
1397
1398 (Coro::async {
1399 $path = new cf::path $path;
1400
1401 my $map = cf::map::find_map $path->as_string;
1402 $map = $map->customise_for ($self) if $map;
1403
1404 warn "entering ", $map->path, " at ($x, $y)\n"
1405 if $map;
1406
1407 $self->leave_link ($map, $x, $y);
1408 })->prio (1);
1409}
1410
1411=item $player_object->enter_exit ($exit_object)
1412
1413=cut
1414
1415sub parse_random_map_params {
1416 my ($spec) = @_;
1417
1418 my $rmp = { # defaults
1419 xsize => 10,
1420 ysize => 10,
1421 };
1422
1423 for (split /\n/, $spec) {
1424 my ($k, $v) = split /\s+/, $_, 2;
1425
1426 $rmp->{lc $k} = $v if (length $k) && (length $v);
1427 }
1428
1429 $rmp
1430}
1431
1432sub prepare_random_map {
1433 my ($exit) = @_;
1434
1435 # all this does is basically replace the /! path by
1436 # a new random map path (?random/...) with a seed
1437 # that depends on the exit object
1438
1439 my $rmp = parse_random_map_params $exit->msg;
1440
1441 if ($exit->map) {
1442 $rmp->{region} = $exit->map->region_name;
1443 $rmp->{origin_map} = $exit->map->path;
1444 $rmp->{origin_x} = $exit->x;
1445 $rmp->{origin_y} = $exit->y;
1446 }
1447
1448 $rmp->{random_seed} ||= $exit->random_seed;
1449
1450 my $data = cf::to_json $rmp;
1451 my $md5 = Digest::MD5::md5_hex $data;
1452
1453 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
1454 aio_write $fh, 0, (length $data), $data, 0;
1455
1456 $exit->slaying ("?random/$md5");
1457 $exit->msg (undef);
1458 }
1459}
1460
1461sub cf::object::player::enter_exit {
472 my ($self, $id, %msg) = @_; 1462 my ($self, $exit) = @_;
473 1463
474 $msg{msgid} = $id; 1464 return unless $self->type == cf::PLAYER;
475 1465
476 $self->send ("ext " . to_json \%msg); 1466 $self->enter_link;
477}
478 1467
479############################################################################# 1468 (Coro::async {
480# map scripting support 1469 unless (eval {
481 1470
1471 prepare_random_map $exit
1472 if $exit->slaying eq "/!";
1473
1474 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1475 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1476
1477 1;
1478 }) {
1479 $self->message ("Something went wrong deep within the crossfire server. "
1480 . "I'll try to bring you back to the map you were before. "
1481 . "Please report this to the dungeon master",
1482 cf::NDI_UNIQUE | cf::NDI_RED);
1483
1484 warn "ERROR in enter_exit: $@";
1485 $self->leave_link;
1486 }
1487 })->prio (1);
1488}
1489
1490=head3 cf::client
1491
1492=over 4
1493
1494=item $client->send_drawinfo ($text, $flags)
1495
1496Sends a drawinfo packet to the client. Circumvents output buffering so
1497should not be used under normal circumstances.
1498
1499=cut
1500
1501sub cf::client::send_drawinfo {
1502 my ($self, $text, $flags) = @_;
1503
1504 utf8::encode $text;
1505 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
1506}
1507
1508
1509=item $success = $client->query ($flags, "text", \&cb)
1510
1511Queues a query to the client, calling the given callback with
1512the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1513C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1514
1515Queries can fail, so check the return code. Or don't, as queries will become
1516reliable at some point in the future.
1517
1518=cut
1519
1520sub cf::client::query {
1521 my ($self, $flags, $text, $cb) = @_;
1522
1523 return unless $self->state == ST_PLAYING
1524 || $self->state == ST_SETUP
1525 || $self->state == ST_CUSTOM;
1526
1527 $self->state (ST_CUSTOM);
1528
1529 utf8::encode $text;
1530 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1531
1532 $self->send_packet ($self->{query_queue}[0][0])
1533 if @{ $self->{query_queue} } == 1;
1534}
1535
1536cf::client->attach (
1537 on_reply => sub {
1538 my ($ns, $msg) = @_;
1539
1540 # this weird shuffling is so that direct followup queries
1541 # get handled first
1542 my $queue = delete $ns->{query_queue};
1543
1544 (shift @$queue)->[1]->($msg);
1545
1546 push @{ $ns->{query_queue} }, @$queue;
1547
1548 if (@{ $ns->{query_queue} } == @$queue) {
1549 if (@$queue) {
1550 $ns->send_packet ($ns->{query_queue}[0][0]);
1551 } else {
1552 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1553 }
1554 }
1555 },
1556);
1557
1558=item $client->coro (\&cb)
1559
1560Create a new coroutine, running the specified callback. The coroutine will
1561be automatically cancelled when the client gets destroyed (e.g. on logout,
1562or loss of connection).
1563
1564=cut
1565
1566sub cf::client::coro {
1567 my ($self, $cb) = @_;
1568
1569 my $coro; $coro = async {
1570 eval {
1571 $cb->();
1572 };
1573 warn $@ if $@;
1574 };
1575
1576 $coro->on_destroy (sub {
1577 delete $self->{_coro}{$coro+0};
1578 });
1579
1580 $self->{_coro}{$coro+0} = $coro;
1581
1582 $coro
1583}
1584
1585cf::client->attach (
1586 on_destroy => sub {
1587 my ($ns) = @_;
1588
1589 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
1590 },
1591);
1592
1593=back
1594
1595
1596=head2 SAFE SCRIPTING
1597
1598Functions that provide a safe environment to compile and execute
1599snippets of perl code without them endangering the safety of the server
1600itself. Looping constructs, I/O operators and other built-in functionality
1601is not available in the safe scripting environment, and the number of
1602functions and methods that can be called is greatly reduced.
1603
1604=cut
1605
482our $safe = new Safe "ext"; 1606our $safe = new Safe "safe";
483our $safe_hole = new Safe::Hole; 1607our $safe_hole = new Safe::Hole;
484 1608
485$SIG{FPE} = 'IGNORE'; 1609$SIG{FPE} = 'IGNORE';
486 1610
487$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 1611$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
488 1612
489# here we export the classes and methods available to script code 1613# here we export the classes and methods available to script code
490 1614
1615=pod
1616
1617The following fucntions and emthods are available within a safe environment:
1618
1619 cf::object contr pay_amount pay_player map
1620 cf::object::player player
1621 cf::player peaceful
1622 cf::map trigger
1623
1624=cut
1625
491for ( 1626for (
492 ["cf::object" => qw(contr pay_amount pay_player)], 1627 ["cf::object" => qw(contr pay_amount pay_player map)],
493 ["cf::object::player" => qw(player)], 1628 ["cf::object::player" => qw(player)],
494 ["cf::player" => qw(peaceful)], 1629 ["cf::player" => qw(peaceful)],
1630 ["cf::map" => qw(trigger)],
495) { 1631) {
496 no strict 'refs'; 1632 no strict 'refs';
497 my ($pkg, @funs) = @$_; 1633 my ($pkg, @funs) = @$_;
498 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 1634 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
499 for @funs; 1635 for @funs;
500} 1636}
1637
1638=over 4
1639
1640=item @retval = safe_eval $code, [var => value, ...]
1641
1642Compiled and executes the given perl code snippet. additional var/value
1643pairs result in temporary local (my) scalar variables of the given name
1644that are available in the code snippet. Example:
1645
1646 my $five = safe_eval '$first + $second', first => 1, second => 4;
1647
1648=cut
501 1649
502sub safe_eval($;@) { 1650sub safe_eval($;@) {
503 my ($code, %vars) = @_; 1651 my ($code, %vars) = @_;
504 1652
505 my $qcode = $code; 1653 my $qcode = $code;
506 $qcode =~ s/"/‟/g; # not allowed in #line filenames 1654 $qcode =~ s/"/‟/g; # not allowed in #line filenames
507 $qcode =~ s/\n/\\n/g; 1655 $qcode =~ s/\n/\\n/g;
508 1656
509 local $_; 1657 local $_;
510 local @ext::cf::_safe_eval_args = values %vars; 1658 local @safe::cf::_safe_eval_args = values %vars;
511 1659
512 $code = 1660 my $eval =
513 "do {\n" 1661 "do {\n"
514 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 1662 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
515 . "#line 0 \"{$qcode}\"\n" 1663 . "#line 0 \"{$qcode}\"\n"
516 . $code 1664 . $code
517 . "\n}" 1665 . "\n}"
518 ; 1666 ;
519 1667
520 sub_generation_inc; 1668 sub_generation_inc;
521 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 1669 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
522 sub_generation_inc; 1670 sub_generation_inc;
523 1671
1672 if ($@) {
1673 warn "$@";
1674 warn "while executing safe code '$code'\n";
1675 warn "with arguments " . (join " ", %vars) . "\n";
1676 }
1677
524 wantarray ? @res : $res[0] 1678 wantarray ? @res : $res[0]
525} 1679}
1680
1681=item cf::register_script_function $function => $cb
1682
1683Register a function that can be called from within map/npc scripts. The
1684function should be reasonably secure and should be put into a package name
1685like the extension.
1686
1687Example: register a function that gets called whenever a map script calls
1688C<rent::overview>, as used by the C<rent> extension.
1689
1690 cf::register_script_function "rent::overview" => sub {
1691 ...
1692 };
1693
1694=cut
526 1695
527sub register_script_function { 1696sub register_script_function {
528 my ($fun, $cb) = @_; 1697 my ($fun, $cb) = @_;
529 1698
530 no strict 'refs'; 1699 no strict 'refs';
531 *{"ext::$fun"} = $safe_hole->wrap ($cb); 1700 *{"safe::$fun"} = $safe_hole->wrap ($cb);
1701}
1702
1703=back
1704
1705=cut
1706
1707#############################################################################
1708
1709=head2 EXTENSION DATABASE SUPPORT
1710
1711Crossfire maintains a very simple database for extension use. It can
1712currently store anything that can be serialised using Storable, which
1713excludes objects.
1714
1715The parameter C<$family> should best start with the name of the extension
1716using it, it should be unique.
1717
1718=over 4
1719
1720=item $hashref = cf::db_get $family
1721
1722Return a hashref for use by the extension C<$family>, which can be
1723modified. After modifications, you have to call C<cf::db_dirty> or
1724C<cf::db_sync>.
1725
1726=item $value = cf::db_get $family => $key
1727
1728Returns a single value from the database
1729
1730=item cf::db_put $family => $hashref
1731
1732Stores the given family hashref into the database. Updates are delayed, if
1733you want the data to be synced to disk immediately, use C<cf::db_sync>.
1734
1735=item cf::db_put $family => $key => $value
1736
1737Stores the given C<$value> in the family hash. Updates are delayed, if you
1738want the data to be synced to disk immediately, use C<cf::db_sync>.
1739
1740=item cf::db_dirty
1741
1742Marks the database as dirty, to be updated at a later time.
1743
1744=item cf::db_sync
1745
1746Immediately write the database to disk I<if it is dirty>.
1747
1748=cut
1749
1750our $DB;
1751
1752{
1753 my $path = cf::localdir . "/database.pst";
1754
1755 sub db_load() {
1756 warn "loading database $path\n";#d# remove later
1757 $DB = stat $path ? Storable::retrieve $path : { };
1758 }
1759
1760 my $pid;
1761
1762 sub db_save() {
1763 warn "saving database $path\n";#d# remove later
1764 waitpid $pid, 0 if $pid;
1765 if (0 == ($pid = fork)) {
1766 $DB->{_meta}{version} = 1;
1767 Storable::nstore $DB, "$path~";
1768 rename "$path~", $path;
1769 cf::_exit 0 if defined $pid;
1770 }
1771 }
1772
1773 my $dirty;
1774
1775 sub db_sync() {
1776 db_save if $dirty;
1777 undef $dirty;
1778 }
1779
1780 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1781 db_sync;
1782 });
1783
1784 sub db_dirty() {
1785 $dirty = 1;
1786 $idle->start;
1787 }
1788
1789 sub db_get($;$) {
1790 @_ >= 2
1791 ? $DB->{$_[0]}{$_[1]}
1792 : ($DB->{$_[0]} ||= { })
1793 }
1794
1795 sub db_put($$;$) {
1796 if (@_ >= 3) {
1797 $DB->{$_[0]}{$_[1]} = $_[2];
1798 } else {
1799 $DB->{$_[0]} = $_[1];
1800 }
1801 db_dirty;
1802 }
1803
1804 cf::global->attach (
1805 prio => 10000,
1806 on_cleanup => sub {
1807 db_sync;
1808 },
1809 );
532} 1810}
533 1811
534############################################################################# 1812#############################################################################
535# the server's main() 1813# the server's main()
536 1814
537sub run { 1815sub cfg_load {
1816 open my $fh, "<:utf8", cf::confdir . "/config"
1817 or return;
1818
1819 local $/;
1820 *CFG = YAML::Syck::Load <$fh>;
1821}
1822
1823sub main {
1824 # we must not ever block the main coroutine
1825 local $Coro::idle = sub {
1826 Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1827 (Coro::unblock_sub {
1828 Event::one_event;
1829 })->();
1830 };
1831
1832 cfg_load;
1833 db_load;
1834 load_extensions;
538 Event::loop; 1835 Event::loop;
539} 1836}
540 1837
541############################################################################# 1838#############################################################################
542# initialisation 1839# initialisation
543 1840
1841sub reload() {
1842 # can/must only be called in main
1843 if ($Coro::current != $Coro::main) {
1844 warn "can only reload from main coroutine\n";
1845 return;
1846 }
1847
1848 warn "reloading...";
1849
1850 local $FREEZE = 1;
1851 cf::emergency_save;
1852
1853 eval {
1854 # if anything goes wrong in here, we should simply crash as we already saved
1855
1856 # cancel all watchers
1857 for (Event::all_watchers) {
1858 $_->cancel if $_->data & WF_AUTOCANCEL;
1859 }
1860
1861 # cancel all extension coros
1862 $_->cancel for values %EXT_CORO;
1863 %EXT_CORO = ();
1864
1865 # unload all extensions
1866 for (@exts) {
1867 warn "unloading <$_>";
1868 unload_extension $_;
1869 }
1870
1871 # unload all modules loaded from $LIBDIR
1872 while (my ($k, $v) = each %INC) {
1873 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1874
1875 warn "removing <$k>";
1876 delete $INC{$k};
1877
1878 $k =~ s/\.pm$//;
1879 $k =~ s/\//::/g;
1880
1881 if (my $cb = $k->can ("unload_module")) {
1882 $cb->();
1883 }
1884
1885 Symbol::delete_package $k;
1886 }
1887
1888 # sync database to disk
1889 cf::db_sync;
1890 IO::AIO::flush;
1891
1892 # get rid of safe::, as good as possible
1893 Symbol::delete_package "safe::$_"
1894 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1895
1896 # remove register_script_function callbacks
1897 # TODO
1898
1899 # unload cf.pm "a bit"
1900 delete $INC{"cf.pm"};
1901
1902 # don't, removes xs symbols, too,
1903 # and global variables created in xs
1904 #Symbol::delete_package __PACKAGE__;
1905
1906 # reload cf.pm
1907 warn "reloading cf.pm";
1908 require cf;
1909 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1910
1911 # load config and database again
1912 cf::cfg_load;
1913 cf::db_load;
1914
1915 # load extensions
1916 warn "load extensions";
1917 cf::load_extensions;
1918
1919 # reattach attachments to objects
1920 warn "reattach";
1921 _global_reattach;
1922 };
1923
1924 if ($@) {
1925 warn $@;
1926 warn "error while reloading, exiting.";
1927 exit 1;
1928 }
1929
1930 warn "reloaded successfully";
1931};
1932
1933#############################################################################
1934
1935unless ($LINK_MAP) {
1936 $LINK_MAP = cf::map::new;
1937
1938 $LINK_MAP->width (41);
1939 $LINK_MAP->height (41);
1940 $LINK_MAP->alloc;
1941 $LINK_MAP->path ("{link}");
1942 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
1943 $LINK_MAP->in_memory (MAP_IN_MEMORY);
1944
1945 # dirty hack because... archetypes are not yet loaded
1946 Event->timer (
1947 after => 2,
1948 cb => sub {
1949 $_[0]->w->cancel;
1950
1951 # provide some exits "home"
1952 my $exit = cf::object::new "exit";
1953
1954 $exit->slaying ($EMERGENCY_POSITION->[0]);
1955 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
1956 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
1957
1958 $LINK_MAP->insert ($exit->clone, 19, 19);
1959 $LINK_MAP->insert ($exit->clone, 19, 20);
1960 $LINK_MAP->insert ($exit->clone, 19, 21);
1961 $LINK_MAP->insert ($exit->clone, 20, 19);
1962 $LINK_MAP->insert ($exit->clone, 20, 21);
1963 $LINK_MAP->insert ($exit->clone, 21, 19);
1964 $LINK_MAP->insert ($exit->clone, 21, 20);
1965 $LINK_MAP->insert ($exit->clone, 21, 21);
1966
1967 $exit->destroy;
1968 });
1969
1970 $LINK_MAP->{deny_save} = 1;
1971 $LINK_MAP->{deny_reset} = 1;
1972
1973 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1974}
1975
544register "<global>", __PACKAGE__; 1976register "<global>", __PACKAGE__;
545 1977
1978register_command "reload" => sub {
1979 my ($who, $arg) = @_;
1980
1981 if ($who->flag (FLAG_WIZ)) {
1982 $who->message ("start of reload.");
1983 reload;
1984 $who->message ("end of reload.");
1985 }
1986};
1987
546unshift @INC, $LIBDIR; 1988unshift @INC, $LIBDIR;
547 1989
548load_extensions;
549
550$TICK_WATCHER = Event->timer ( 1990$TICK_WATCHER = Event->timer (
1991 reentrant => 0,
551 prio => 1, 1992 prio => 0,
552 at => $NEXT_TICK || 1, 1993 at => $NEXT_TICK || $TICK,
1994 data => WF_AUTOCANCEL,
553 cb => sub { 1995 cb => sub {
1996 unless ($FREEZE) {
554 cf::server_tick; # one server iteration 1997 cf::server_tick; # one server iteration
1998 $RUNTIME += $TICK;
1999 }
555 2000
556 my $NOW = Event::time;
557 $NEXT_TICK += $TICK; 2001 $NEXT_TICK += $TICK;
558 2002
559 # if we are delayed by > 0.25 second, skip ticks 2003 # if we are delayed by four ticks or more, skip them all
560 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + .25; 2004 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
561 2005
562 $TICK_WATCHER->at ($NEXT_TICK); 2006 $TICK_WATCHER->at ($NEXT_TICK);
563 $TICK_WATCHER->start; 2007 $TICK_WATCHER->start;
564 }, 2008 },
565); 2009);
566 2010
2011IO::AIO::max_poll_time $TICK * 0.2;
2012
2013Event->io (
2014 fd => IO::AIO::poll_fileno,
2015 poll => 'r',
2016 prio => 5,
2017 data => WF_AUTOCANCEL,
2018 cb => \&IO::AIO::poll_cb,
2019);
2020
2021Event->timer (
2022 data => WF_AUTOCANCEL,
2023 after => 0,
2024 interval => 10,
2025 cb => sub {
2026 (Coro::unblock_sub {
2027 write_runtime
2028 or warn "ERROR: unable to write runtime file: $!";
2029 })->();
2030 },
2031);
2032
5671 20331
568 2034

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines