[ViewVC] Annotation of: cvs/deliantra/Deliantra/bin/cf-slotutil

#!/opt/bin/perl

use utf8;
use strict qw(vars subs);

use Deliantra;
use IO::AIO;
use List::Util;

sub scan_files($$) {
   my ($path, $cb) = @_;

   aio_scandir $path, 3, sub {
      my ($dirs, $nondirs) = @_;

      scan_files("$path/$_", $cb) for @$dirs;

      for my $file (@$nondirs) {
         next unless $file =~ /\.arc$/;

         my $data;
         aio_load "$path/$file", $data, sub {
            $cb->("$path/$file", read_arch \$data);
         };
      }
   };
}

sub for_all_arc($) {
   scan_files $ENV{DELIANTRA_ARCHDIR} || ".", $_[0];

   IO::AIO::flush;
}

sub extract {
   my (undef, $filter, @slots) = @ARGV;

   $filter =~ s/%(\w+)/\$_{$1}/g;
   $filter = eval "sub { $filter }"
      or die $@;

   my @res;

   unshift @slots, "_name";

   my @sort   = grep /^\d+$/, @slots;
   my @widths = map s/\=(\d+)$// && $1, grep !/^\d+$/, @slots;
   my @align  = map s/>$// ? "" : "-", @slots;
   my @big;

   local *_;
   for (sort keys %ARCH) {
      *_ = $ARCH{$_};
      next unless &$filter;
      push @res, [@_{@slots}];
   };

   @res = sort {
             "$a->[$_]$b->[$_]" =~ /^\d+$/
                ? $a->[$_] <=> $b->[$_]
                : $a->[$_] cmp $b->[$_]
          } @res
      for @sort;

   for my $row (@res) {
      for (0 .. $#$row) {
         $big[$_] =1 if $row->[$_] =~ /\n/;
      }
   }
   for my $i (0 .. $#widths) {
      $widths[$i] ||= List::Util::max map length $_->[$i], \@slots, @res;
   }

   for (0 .. $#big) {
      $widths[$_] = length $slots[$_] if $big[$_];
   }

   my $format = join " ", map "%$align[$_]$widths[$_]s", 0..$#widths;

   printf "$format\n", map "A$_", map $_ + 1, @widths;
   printf "$format\n", @slots;
   for my $row (@res) {
      print "\n" if @big;

      printf "$format\n", map $big[$_] ? "\x{fffc}" : $row->[$_], 0 .. $#$row;

      for (grep $big[$_], 0 .. $#big) {
         print "$row->[$_]%%\n";
      }
   }
}

sub insert {
   my ($apply) = @_;

   shift @ARGV;
   my $format = <STDIN>;
   my @slots = unpack $format, <STDIN>;
   s/^\s+// for @slots;
   
   my %res;

   while (<STDIN>) {
      next unless /\S/;

      my @row = unpack $format, $_;
      s/^\s+// for @row;

      for (0 .. $#row) {
         next unless $row[$_] eq "\x{fffc}";

         local $/ = "%%\n";
         chomp ($row[$_] = <STDIN>);
      }

      $res{$row[0]} = \@row;
   }

   for_all_arc sub {
      my ($path, $arch) = @_;

      my $chg;

      for (keys %$arch) {
         my $data = $res{$_}
            or next;

         my $arch = $arch->{$_};

         for (0 .. $#$data) {
            next if $data->[$_] eq $arch->{$slots[$_]};
            $chg = 1;
            $arch->{$slots[$_]} = $data->[$_];
         }
      }

      if ($chg) {
         open my $fh, ">:raw:utf8", "$path~"
           or die "$path~: $!";
         print $fh Deliantra::archlist_to_string [
            map $arch->{$_},
               sort keys %$arch
         ];
         close $fh;

         if ($apply) {
            rename "$path~", $path;
         } else {
            system "diff", "-u", $path, "$path~";
            unlink "$path~";
         }
      }
   };
}

binmode STDIN, ":utf8";
binmode STDOUT, ":utf8";

if ($ARGV[0] eq "extract") {
   Deliantra::load_archetypes;
   extract;
} elsif ($ARGV[0] eq "diff") {
   Deliantra::load_archetypes;
   insert 0;
} elsif ($ARGV[0] eq "patch") {
   Deliantra::load_archetypes;
   insert 1;
} else {
   die <<EOF;
Usage:

    $0 extract 'filter' slot...

        extract slots from server archetypes file (NOT the .arc files!)
        Example: $0 extract '%type == 101' level

    $0 diff

        generates a diff against the .arc files found
        in \$DELIANTRA_ARCHDIR or ".".

        Example: $0 diff <file

    $0 patch

        like diff, but applies it in-place

EOF
}


Revision:	1.4
Committed:	Sun Sep 28 15:08:20 2008 UTC (15 years, 8 months ago) by root
Branch:	MAIN
CVS Tags:	rel-1_29, rel-1_24, rel-1_25, rel-1_23, rel-1_30
Changes since 1.3:	+7 -4 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	#!/opt/bin/perl
2
3			use utf8;
4			use strict qw(vars subs);
5
6			use Deliantra;
7			use IO::AIO;
8			use List::Util;
9
10			sub scan_files($$) {
11			my ($path, $cb) = @_;
12
13			aio_scandir $path, 3, sub {
14			my ($dirs, $nondirs) = @_;
15
16			scan_files("$path/$_", $cb) for @$dirs;
17
18			for my $file (@$nondirs) {
19			next unless $file =~ /\.arc$/;
20
21			my $data;
22			aio_load "$path/$file", $data, sub {
23			$cb->("$path/$file", read_arch \$data);
24			};
25			}
26			};
27			}
28
29			sub for_all_arc($) {
30			scan_files $ENV{DELIANTRA_ARCHDIR} \|\| ".", $_[0];
31
32			IO::AIO::flush;
33			}
34
35			sub extract {
36			my (undef, $filter, @slots) = @ARGV;
37
38			$filter =~ s/%(\w+)/\$_{$1}/g;
39			$filter = eval "sub { $filter }"
40			or die $@;
41
42			my @res;
43
44			unshift @slots, "_name";
45
46	root	1.3	my @sort = grep /^\d+$/, @slots;
47			my @widths = map s/\=(\d+)$// && $1, grep !/^\d+$/, @slots;
48			my @align = map s/>$// ? "" : "-", @slots;
49	root	1.1	my @big;
50
51			local *_;
52			for (sort keys %ARCH) {
53			*_ = $ARCH{$_};
54			next unless &$filter;
55			push @res, [@_{@slots}];
56			};
57
58	root	1.3	@res = sort {
59			"$a->[$_]$b->[$_]" =~ /^\d+$/
60			? $a->[$_] <=> $b->[$_]
61			: $a->[$_] cmp $b->[$_]
62			} @res
63			for @sort;
64
65	root	1.1	for my $row (@res) {
66			for (0 .. $#$row) {
67			$big[$_] =1 if $row->[$_] =~ /\n/;
68			}
69			}
70			for my $i (0 .. $#widths) {
71			$widths[$i] \|\|= List::Util::max map length $_->[$i], \@slots, @res;
72			}
73
74			for (0 .. $#big) {
75			$widths[$_] = length $slots[$_] if $big[$_];
76			}
77
78	root	1.3	my $format = join " ", map "%$align[$_]$widths[$_]s", 0..$#widths;
79
80	root	1.1	printf "$format\n", map "A$_", map $_ + 1, @widths;
81			printf "$format\n", @slots;
82			for my $row (@res) {
83			print "\n" if @big;
84
85			printf "$format\n", map $big[$_] ? "\x{fffc}" : $row->[$_], 0 .. $#$row;
86
87			for (grep $big[$_], 0 .. $#big) {
88			print "$row->[$_]%%\n";
89			}
90			}
91			}
92
93			sub insert {
94	root	1.2	my ($apply) = @_;
95
96	root	1.1	shift @ARGV;
97			my $format = <STDIN>;
98			my @slots = unpack $format, <STDIN>;
99	root	1.4	s/^\s+// for @slots;
100	root	1.1
101			my %res;
102
103			while (<STDIN>) {
104			next unless /\S/;
105
106			my @row = unpack $format, $_;
107	root	1.4	s/^\s+// for @row;
108	root	1.1
109			for (0 .. $#row) {
110			next unless $row[$_] eq "\x{fffc}";
111
112			local $/ = "%%\n";
113			chomp ($row[$_] = <STDIN>);
114			}
115
116			$res{$row[0]} = \@row;
117			}
118
119			for_all_arc sub {
120			my ($path, $arch) = @_;
121
122			my $chg;
123
124			for (keys %$arch) {
125			my $data = $res{$_}
126			or next;
127
128			my $arch = $arch->{$_};
129
130			for (0 .. $#$data) {
131			next if $data->[$_] eq $arch->{$slots[$_]};
132			$chg = 1;
133			$arch->{$slots[$_]} = $data->[$_];
134			}
135			}
136
137			if ($chg) {
138			open my $fh, ">:raw:utf8", "$path~"
139			or die "$path~: $!";
140			print $fh Deliantra::archlist_to_string [
141			map $arch->{$_},
142			sort keys %$arch
143			];
144			close $fh;
145	root	1.2
146			if ($apply) {
147			rename "$path~", $path;
148			} else {
149			system "diff", "-u", $path, "$path~";
150			unlink "$path~";
151			}
152	root	1.1	}
153			};
154			}
155
156			binmode STDIN, ":utf8";
157			binmode STDOUT, ":utf8";
158
159			if ($ARGV[0] eq "extract") {
160	root	1.4	Deliantra::load_archetypes;
161	root	1.1	extract;
162			} elsif ($ARGV[0] eq "diff") {
163	root	1.4	Deliantra::load_archetypes;
164	root	1.2	insert 0;
165	root	1.4	} elsif ($ARGV[0] eq "patch") {
166			Deliantra::load_archetypes;
167	root	1.2	insert 1;
168	root	1.1	} else {
169			die <<EOF;
170			Usage:
171
172			$0 extract 'filter' slot...
173
174			extract slots from server archetypes file (NOT the .arc files!)
175			Example: $0 extract '%type == 101' level
176
177	root	1.2	$0 diff
178	root	1.1
179			generates a diff against the .arc files found
180			in \$DELIANTRA_ARCHDIR or ".".
181
182			Example: $0 diff <file
183
184	root	1.4	$0 patch
185	root	1.2
186			like diff, but applies it in-place
187
188	root	1.1	EOF
189			}
190
191
192