Commit | Line | Data |
---|---|---|
5c5cd38a MG |
1 | package Gruntmaster::Daemon; |
2 | ||
3 | use 5.014000; | |
4 | use strict; | |
5 | use warnings; | |
6 | ||
7 | our $VERSION = '0.001'; | |
8 | ||
9 | use Gruntmaster::Daemon::Constants qw/ERR/; | |
10 | use Gruntmaster::Daemon::Base qw/watch/; | |
ddceb393 | 11 | use Gruntmaster::Daemon::Format qw/mkrun/; |
5c5cd38a MG |
12 | use Gruntmaster::Page qw/generate/; |
13 | ||
14 | use Fcntl qw/:flock/; | |
15 | use File::Copy qw/cp/; | |
16 | use IO::File; | |
17 | use Time::HiRes qw/time/; | |
18 | use Try::Tiny; | |
19 | use YAML::Any qw/LoadFile DumpFile/; | |
20 | use Log::Log4perl qw/get_logger/; | |
21 | ||
22 | ################################################## | |
23 | ||
24 | sub safe_can_nodie { | |
25 | my ($type, $sub, $name) = @_; | |
26 | ||
27 | return unless $name =~ /^\w+$/; | |
28 | no strict 'refs'; | |
29 | my $pkg = __PACKAGE__ . "::${type}::${name}"; | |
30 | eval "require $pkg" or get_logger->warn("Error while requiring $pkg: $@"); | |
31 | $pkg->can($sub); | |
32 | } | |
33 | ||
34 | sub safe_can { | |
35 | my ($type, $sub, $name) = @_; | |
36 | ||
37 | safe_can_nodie @_ or get_logger->logdie("No such \l$type: '$name'"); | |
38 | } | |
39 | ||
ddceb393 MG |
40 | sub prepare{ |
41 | my $name = $_[0]; | |
42 | my $basename = fileparse $name, qr/\.[^.]*/; | |
43 | get_logger->trace("Preparing file $name..."); | |
44 | ||
45 | open my $devnull, devnull; | |
46 | open my $errors, '>>compile-error'; | |
47 | my $ret = open3 $devnull, $errors, undef, 'gruntmaster-compile', CPP => $basename, $name; | |
48 | waitpid $ret, 0; | |
49 | close $devnull; | |
50 | close $errors; | |
51 | die 'Compile error' if $? | |
52 | } | |
53 | ||
5c5cd38a MG |
54 | sub prepare_files{ |
55 | my ($dir, $meta) = @_; | |
56 | ||
57 | for my $file (values $meta->{files}) { | |
58 | my ($format, $name) = @{$file}{qw/format name/}; | |
59 | ||
ddceb393 | 60 | $file->{run} = mkrun($format); |
5c5cd38a | 61 | die "No such file: '$name'" unless -e $name; |
ddceb393 | 62 | prepare $name; |
5c5cd38a MG |
63 | } |
64 | } | |
65 | ||
66 | sub process{ | |
67 | my $dir = $_[0]; | |
68 | ||
69 | chdir $dir; | |
70 | mkdir "in"; | |
71 | for (<*>) { | |
1fc8d024 | 72 | cp $_, "in" unless $_ eq 'in'; |
5c5cd38a MG |
73 | } |
74 | ||
75 | my @results; | |
76 | my @full_results = (); | |
77 | my $meta = {}; | |
78 | try { | |
79 | $meta = LoadFile "meta.yml"; | |
80 | if (exists $meta->{problem}) { | |
81 | my $problem = $meta->{problem}; | |
82 | die "No such problem: $problem" unless -d "../../pb/$problem"; | |
83 | for (<../../pb/$problem/*>) { | |
84 | cp $_, '.' unless $_ eq "../../pb/$problem/meta.yml" | |
85 | } | |
86 | ||
87 | my $pbmeta = LoadFile "../../pb/$problem/meta.yml"; | |
88 | $meta = {%$meta, %$pbmeta}; | |
89 | } | |
90 | ||
91 | my ($files, $generator, $runner, $judge, $testcnt) = map { $meta->{$_} or die "Required parameter missing: $_"} qw/files generator runner judge testcnt/; | |
92 | ||
93 | $generator = safe_can Generator => generate => $generator; | |
94 | $runner = safe_can Runner => run => $runner; | |
95 | $judge = safe_can Judge => judge => $judge; | |
96 | ||
97 | prepare_files $dir, $meta; | |
98 | for my $test (1 .. $testcnt) { | |
99 | my $start_time = time; | |
100 | my $result; | |
101 | try { | |
102 | $generator->($test, $meta); | |
103 | $result = $runner->($test, $meta); | |
104 | } catch { | |
105 | $result = $_; | |
106 | unless (ref $result) { | |
107 | chomp $result; | |
108 | $result = [ERR, $result]; | |
109 | } | |
110 | }; | |
111 | ||
112 | if (ref $result) { | |
113 | get_logger->trace("Test $test result is " . $result->[1]); | |
114 | push @full_results, {id => $test, result => $result->[0], result_text => $result->[1], time => time - $start_time} | |
115 | } else { | |
116 | get_logger->trace("Test $test result is $result"); | |
117 | push @full_results, {id => $test, result => 0, result_text => $result, time => time - $start_time} | |
118 | } | |
119 | push @results, $result; | |
120 | last if $meta->{judge} eq 'Absolute' && ref $result | |
121 | } | |
122 | ||
123 | my %results = $judge->(@results); | |
124 | $meta->{$_} = $results{$_} for keys %results; | |
125 | } catch { | |
126 | s,(.*) at .*,$1,; | |
127 | chomp; | |
128 | $meta->{result} = -1; | |
129 | $meta->{result_text} = $_; | |
130 | }; | |
131 | ||
132 | # Clean up | |
133 | get_logger->info("Job result: " . $meta->{result_text}); | |
5c5cd38a MG |
134 | $meta->{results} = \@full_results if scalar @full_results; |
135 | DumpFile "meta.yml", $meta; | |
136 | for (<*>) { | |
fe185d88 | 137 | unlink $_ unless $_ eq 'in' || $_ eq 'meta.yml' || ($_ eq 'compile-error' && -s); |
5c5cd38a MG |
138 | } |
139 | chdir '../..'; | |
fee71502 MG |
140 | my $log = exists $meta->{contest} ? "ct/$meta->{contest}/log" : 'log'; |
141 | mkdir $log unless -d $log; | |
142 | IO::File->new(">$log/meta.yml")->close unless -f "$log/meta.yml"; | |
143 | flock my $logmetafh = IO::File->new("<$log/meta.yml"), LOCK_EX; | |
144 | my $logmeta = LoadFile "$log/meta.yml"; | |
5c5cd38a | 145 | $logmeta->{last}++; |
fee71502 MG |
146 | rename $dir, "$log/$logmeta->{last}"; |
147 | generate "$log/$logmeta->{last}/index.html"; | |
148 | DumpFile "$log/meta.yml", $logmeta; | |
5c5cd38a | 149 | undef $logmetafh; |
fee71502 | 150 | generate "$log/index.html" |
5c5cd38a MG |
151 | } |
152 | ||
153 | sub run{ | |
154 | Log::Log4perl->init('log.conf'); | |
155 | watch 'jobs', \&process; | |
156 | } | |
157 | ||
158 | 1; | |
159 | __END__ | |
160 | # Below is stub documentation for your module. You'd better edit it! | |
161 | ||
162 | =head1 NAME | |
163 | ||
164 | Gruntmaster::Daemon - Perl extension for blah blah blah | |
165 | ||
166 | =head1 SYNOPSIS | |
167 | ||
168 | use Gruntmaster::Daemon; | |
169 | blah blah blah | |
170 | ||
171 | =head1 DESCRIPTION | |
172 | ||
173 | Stub documentation for Gruntmaster::Daemon, created by h2xs. It looks like the | |
174 | author of the extension was negligent enough to leave the stub | |
175 | unedited. | |
176 | ||
177 | Blah blah blah. | |
178 | ||
179 | ||
180 | =head1 SEE ALSO | |
181 | ||
182 | Mention other useful documentation such as the documentation of | |
183 | related modules or operating system documentation (such as man pages | |
184 | in UNIX), or any relevant external documentation such as RFCs or | |
185 | standards. | |
186 | ||
187 | If you have a mailing list set up for your module, mention it here. | |
188 | ||
189 | If you have a web site set up for your module, mention it here. | |
190 | ||
191 | =head1 AUTHOR | |
192 | ||
193 | Marius Gavrilescu, E<lt>marius@E<gt> | |
194 | ||
195 | =head1 COPYRIGHT AND LICENSE | |
196 | ||
197 | Copyright (C) 2013 by Marius Gavrilescu | |
198 | ||
199 | This library is free software; you can redistribute it and/or modify | |
200 | it under the same terms as Perl itself, either Perl version 5.18.1 or, | |
201 | at your option, any later version of Perl 5 you may have available. | |
202 | ||
203 | ||
204 | =cut |