chiark / gitweb /
where-vessels: smash ownerships works, but need gridded ownership smashing
[ypp-sc-tools.db-test.git] / ypp-chart-memshow
1 #!/usr/bin/perl -w
2 #
3 # This is part of ypp-sc-tools, a set of third-party tools for assisting
4 # players of Yohoho Puzzle Pirates.
5 #
6 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
7 #
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
12 #
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 # GNU General Public License for more details.
17 #
18 # You should have received a copy of the GNU General Public License
19 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
20 #
21 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
22 # are used without permission.  This program is not endorsed or
23 # sponsored by Three Rings.
24
25 # This script helps make memmed or not memmed points visible.
26
27 my $usage= <<END;
28 usage:
29    ypp-chart-memshow [/home/user/path/to/Desktop]
30    ypp-chart-memshow /path/to/screenshot/to/convert.png
31    ypp-chart-memshow - < /path/to/screenshot/to/convert.png
32 if given a Desktop directory will look for
33    /home/user/path/to/Desktop/"Puzzle Pirates <Name> <number>".png
34 and delete them after display
35 END
36
37 use POSIX;
38 use strict qw(vars refs);
39 use File::Glob qw(:glob);
40
41 our $quis= $0;
42 $quis =~ s,.*/,,;
43
44
45 sub badusage ($) {
46     print STDERR "bad usage: @_\n$usage\n";
47     exit 8;
48 }
49
50 sub xglob ($) {
51     my ($pat) = @_;
52     my @glob= bsd_glob($pat, GLOB_ERR|GLOB_LIMIT|GLOB_NOSORT);
53     die "$quis: error reading directory: $!\n" if GLOB_ERROR;
54     return @glob;
55 }
56
57 sub synchronously ($) {
58     my ($file) = @_;
59     print "$quis: $file displaying...\n";
60     open STDIN, "<", $file or die "$quis: $file: $!\n";
61     synchronously_stdin();
62 }
63
64 sub synchronously_stdin () {
65     exec 'bash', '-ec', '
66         set -o pipefail
67         pngtopnm |ppmchange -closeness 10 "#806c60" blue |display -
68     ';
69     die "$quis: bash: $!\n";
70 }
71
72 sub watch_dir ($) {
73     my ($dir) = @_;
74     chdir $dir or die "chdir $dir: $!";
75
76     my %already;
77     my $pat= "Puzzle Pirates *.png";
78     $already{$_}='a' foreach xglob($pat);
79     print "$quis: watching $dir...\n";
80     if (!%already) {
81         print "$quis: warning: no existing screenshots found\n";
82     }
83     my %children;
84     for (;;) {
85         select undef,undef,undef, 0.100;
86
87         my $child;
88         while (($child= waitpid -1, WNOHANG) > 0) {
89             my $file= $children{$child};
90             if (!defined $file) {
91                 die "$quis: unknown child $child failed status $?\n" if $?;
92                 warn "$quis: unknown child $child, finished ok\n";
93             } else {
94                 die "$quis: display of $file failed status $?\n" if $?;
95                 delete $already{$file};
96                 delete $children{$child};
97                 unlink $file or $!==&ENOENT
98                     or die "$quis: delete $file: $!\n";
99                 print "$quis: $file deleted.\n";
100             }
101         }
102
103         my @extra= grep { !exists $already{$_} } xglob($pat);
104         next if !@extra;
105         die "$quis: multiple screenshots at once! (@extra)\n" if @extra>1;
106
107         my $file= $extra[0];
108         
109         print "$quis: $file found...\n";
110         my $lastsize= -1;
111         for (;;) {
112             if (!stat $file) {
113                 next if $!==&ENOENT;
114                 die "$quis: check $file: $!\n";
115             }
116             my $size= (stat _)[7];
117             die "$quis: $file: not a plain file !\n" unless -f _;
118             next unless $size;
119             last if $size==$lastsize;
120             $lastsize= $size;
121             select undef,undef,undef, 0.100;
122         }
123
124         $child= fork;  defined $child or die $!;
125         if (!$child) {
126             synchronously($file);
127             exit(0);
128         }
129         $children{$child}= $file;
130         $already{$file}= $child;
131     }
132 }
133
134
135 while (@ARGV && $ARGV[0] =~ m/^\-./) {
136     $_= shift @ARGV;
137     last if $_ eq '--';
138     badusage("unknown option \`$_'");
139 }
140
141 our $target;
142
143 if (!@ARGV) {
144     $target= $ENV{'HOME'};
145     die unless defined $target;
146     $target .= '/Desktop';
147 } elsif (@ARGV==1) {
148     $target= shift @ARGV;
149 } else {
150     badusage("at most one non-option argument please");
151 }
152
153 if ($target eq '-') {
154     synchronously_stdin();
155 }
156
157 (stat $target) or die "$quis: cannot find $target: $!\n";
158
159 if (-f _) {
160     synchronously($target);
161 } else {
162     watch_dir($target);
163 }