File Coverage

lib/CodeGen/Protection/Role.pm
Criterion Covered Total %
statement 89 101 88.1
branch 14 20 70.0
condition 11 28 39.2
subroutine 16 17 94.1
pod 0 1 0.0
total 130 167 77.8


line stmt bran cond sub pod time code
1             package CodeGen::Protection::Role;
2              
3             # ABSTRACT: Role to help rewrite parts of documents
4              
5 5     5   48033 use v5.10.0; # for named captures in regexes
  5         18  
6 5     5   27 use Moo::Role;
  5         9  
  5         29  
7 5     5   2826 use Carp 'croak';
  5         9  
  5         295  
8 5     5   781 use CodeGen::Protection::Types qw(NonEmptyStr Bool);
  5         12  
  5         98  
9 5     5   5960 use Digest::MD5 'md5_hex';
  5         13  
  5         7279  
10              
11             requires qw(
12             _tidy
13             _start_marker_format
14             _end_marker_format
15             VERSION
16             );
17              
18             our $VERSION = '0.02';
19              
20             has existing_code => (
21             is => 'ro',
22             isa => NonEmptyStr,
23             predicate => 1,
24             );
25              
26             has protected_code => (
27             is => 'ro',
28             isa => NonEmptyStr,
29             required => 1,
30             );
31              
32             has name => (
33             is => 'ro',
34             isa => NonEmptyStr,
35             default => 'document',
36             );
37              
38             has overwrite => (
39             is => 'ro',
40             isa => Bool,
41             default => 0,
42             );
43              
44             has rewritten => (
45             is => 'rwp',
46             isa => NonEmptyStr,
47             );
48              
49             has tidy => (
50             is => 'ro',
51             isa => NonEmptyStr,
52             );
53              
54             has document_type => (
55             is => 'ro',
56             isa => NonEmptyStr,
57             builder => sub {
58 21     21   39622 my $self = shift;
59 21         43 my $class = ref $self;
60 21         85 $class =~ s/^CodeGen::Protection::Format:://;
61 21         365 return $class;
62             },
63             );
64              
65             sub BUILD {
66 21     21 0 2004 my $self = shift;
67 21 100       89 if ( $self->has_existing_code ) {
68 17         47 $self->_rewrite;
69             }
70             else {
71 4         16 my $protected_code = $self->protected_code;
72 4         13 my $regex = $self->_regex_to_match_rewritten_document;
73 4 50 33     64 if ( !$self->has_existing_code && $protected_code =~ $regex ) {
74 0         0 my $type = $self->document_type;
75 0         0 my $name = $self->name;
76 0         0 croak(
77             "We re in 'Creation' mode, but the $type code passed in already has start/end markers for $name."
78             );
79             }
80             $protected_code
81 4         15 = $self->_remove_all_leading_and_trailing_blank_lines(
82             $protected_code);
83 4         15 $self->_set_rewritten( $self->_add_checksums($protected_code) );
84             }
85             }
86              
87             sub _rewrite {
88 17     17   31 my ($self) = @_;
89              
90 17         44 my $extract_re = $self->_regex_to_match_rewritten_document;
91              
92 17         49 my $replacement = $self->protected_code;
93 17 100       102 if ( $replacement =~ $extract_re ) {
94              
95             # we have a full document with start and end rewrite tags, so let's
96             # just extract that
97 6         19 $replacement = $self->_extract_body;
98             }
99              
100 17         45 my $body = $self->_add_checksums($replacement);
101 17         44 $body = $self->_remove_all_leading_and_trailing_blank_lines($body);
102 17         51 my ( $before, $after ) = $self->_extract_before_and_after;
103 14         411 $self->_set_rewritten("$before$body$after");
104             }
105              
106             sub _extract_before_and_after {
107 17     17   41 my ( $self, $text ) = @_;
108 17   33     122 $text //= $self->existing_code;
109              
110 17         42 my $extract_re = $self->_regex_to_match_rewritten_document;
111 17         50 my $type = $self->document_type;
112 17         43 my $name = $self->name;
113 17 100       165 if ( $text !~ $extract_re ) {
114 1         14 croak(
115             "Could not find the $type start and end markers in text for $name."
116             );
117             }
118 16         140 my $digest_start = $+{digest_start};
119 16         78 my $digest_end = $+{digest_end};
120              
121 16 100       54 unless ( $digest_start eq $digest_end ) {
122 1         26 croak(
123             "Start digest ($digest_start) does not match end digest ($digest_end) for $type $name"
124             );
125             }
126              
127 15 100 100     88 if ( !$self->overwrite
128             && $digest_start ne $self->_get_checksum( $+{body} ) )
129             {
130 1         16 croak(
131             "Checksum ($digest_start) did not match text. Set 'overwrite' to true to ignore this for $type $name"
132             );
133             }
134 14   50     85 my $before = $+{before} // '';
135 14   50     73 my $after = $+{after} // '';
136 14         61 return ( $before, $after );
137             }
138              
139             sub _extract_body {
140 6     6   16 my ( $self, $text ) = @_;
141 6   33     116 $text //= $self->protected_code;
142              
143 6         20 my $extract_re = $self->_regex_to_match_rewritten_document;
144 6         17 my $name = $self->name;
145 6         17 my $type = $self->document_type;
146 6 50       49 if ( $text !~ $extract_re ) {
147 0         0 croak(
148             "Could not find the $type start and end markers in text for $name");
149             }
150 6         43 my $digest_start = $+{digest_start};
151 6         30 my $digest_end = $+{digest_end};
152              
153 6 50       22 unless ( $digest_start eq $digest_end ) {
154 0         0 croak(
155             "Start digest ($digest_start) does not match end digest ($digest_end) for $type $name"
156             );
157             }
158              
159 6         20 return $self->_remove_all_leading_and_trailing_blank_lines( $+{body} );
160             }
161              
162             #
163             # Internal method. Returns a regex that can use used to match a "rewritten"
164             # document. If the regex matches, we have a rewritten document. You can
165             # extract parts via:
166             #
167             # my $regex = $self->_regex_to_match_rewritten_document;
168             # if ( $document =~ $regex ) {
169             # my $before = $+{before};
170             # my $digest_start = $+{digest_start}; # checksum from start tag
171             # my $body = $+{body}; # between start and end tags
172             # my $digest_end = $+{digest_end}; # checksum from end tag
173             # my $after = $+{after};
174             # }
175             #
176             # This is not an attribute because we need to be able to call it as a class
177             # method
178             #
179              
180             sub _regex_to_match_rewritten_document {
181 44     44   58 my $self = shift;
182 44   33     121 my $class = ref $self || $self;
183              
184 44         138 my $digest_start_re = qr/(?<digest_start>[0-9a-f]{32})/;
185 44         98 my $digest_end_re = qr/(?<digest_end>[0-9a-f]{32})/;
186 44         122 my $start_marker_re = sprintf $class->_start_marker_format => $class,
187             $class->_version_re,
188             $digest_start_re;
189 44         136 my $end_marker_re = sprintf $class->_end_marker_format => $class,
190             $class->_version_re,
191             $digest_end_re;
192              
193             # don't use the /x modifier to make this prettier unless you call
194             # quotemeta on the start and end markers
195             return
196 44         558 qr/^(?<before>.*?)$start_marker_re(?<body>.*?)$end_marker_re(?<after>.*?)$/s;
197             }
198              
199             sub _get_checksum {
200 35     35   100 my ( $class, $text ) = @_;
201 35         104 return md5_hex(
202             $class->_remove_all_leading_and_trailing_blank_lines($text) );
203             }
204              
205             sub _add_checksums {
206 21     21   45 my ( $self, $text ) = @_;
207 21   33     79 my $class = ref $self || $self;
208 21         70 $text = $self->_remove_all_leading_and_trailing_blank_lines(
209             $self->_tidy($text) );
210 21         64 my $checksum = $self->_get_checksum($text);
211 21         62 my $start = sprintf $self->_start_marker_format => $class,
212             $self->_get_version,
213             $checksum;
214 21         68 my $end = sprintf $self->_end_marker_format => $class, $self->_get_version,
215             $checksum;
216              
217 21         202 return <<"END";
218             $start
219              
220             $text
221              
222             $end
223             END
224             }
225              
226             sub _version_re {
227 146     146   9121 return qr/[0-9]+\.[0-9]+/;
228             }
229              
230             sub _remove_all_leading_and_trailing_blank_lines {
231 83     83   162 my ( $self, $perl ) = @_;
232              
233             # note: we're not using trim() because if they pass in code that
234             # starts with indentation, we'll break it
235 83         268 my @lines = split /\n/ => $perl;
236 83         296 while ( $lines[0] =~ /^\s*$/ ) {
237 40         120 shift @lines;
238             }
239 83         200 while ( $lines[-1] =~ /^\s*$/ ) {
240 0         0 pop @lines;
241             }
242 83         482 return return join "\n" => @lines;
243             }
244              
245             sub _get_version {
246 42     42   60 my $self = shift;
247 42         81 my $version_re = $self->_version_re;
248 42         287 my $version = $self->VERSION;
249 42 50 33     366 if ( defined $version && $version =~ /$version_re/ ) {
250 42         206 return $version;
251             }
252 0   0       my $class = ref $self || $self;
253 0 0         if ( !defined $version ) {
254 0           croak("$class does not define a VERSION");
255             }
256             else {
257 0           croak("$class version '$version' does not match '$version_re'");
258             }
259             }
260              
261             sub _tidy {
262              
263             # by default, we do not tidy code unless it's overridden in the child
264 0     0     my ( $self, $code ) = @_;
265 0           return $code;
266             }
267              
268             1;
269              
270             __END__
271              
272             =pod
273              
274             =encoding UTF-8
275              
276             =head1 NAME
277              
278             CodeGen::Protection::Role - Role to help rewrite parts of documents
279              
280             =head1 VERSION
281              
282             version 0.02
283              
284             =head1 SYNOPSIS
285              
286             package CodeGen::Protection::Format::MyDocumentType;
287             use Moo;
288             with 'CodeGen::Protection::Role';
289              
290             our $VERSION = '0.01'; # required
291              
292             sub _tidy {...}
293             sub _start_marker_format {...}
294             sub _end_marker_format {...}
295              
296             1;
297              
298             =head1 DESCRIPTION
299              
300             This role allows you to easily define modules that allow you to do a safe
301             partial rewrite of documents. If you're familiar with
302             L<DBIx::Class::Schema::Loader>, you probably know the basic concept.
303              
304             In short, we wrap your "protected" (C<protected_code>) code in start and
305             end comments, with checksums for the code:
306              
307             #<<< CodeGen::Protection::Format::Perl 0.01. Do not touch any code between this and the end comment. Checksum: fa97a021bd70bf3b9fa3e52f203f2660
308            
309             # protected code goes here
310              
311             #>>> CodeGen::Protection::Format::Perl 0.01. Do not touch any code between this and the start comment. Checksum: fa97a021bd70bf3b9fa3e52f203f2660
312              
313             See L<CodeGen::Protection::Format::Perl> for full documentation of the OO
314             interface, and L<CodeGen::Protection> for full documentation of the
315             recommended interface.
316              
317             # Creating A New Protected Format
318              
319             Note that this module is I<not> suitable for protecting documents which
320             require context outside of the protected area. JSON and YAML would be good
321             examples of document types which are probably not suitable for this code.
322              
323             Javascript, however, is excellent.
324              
325             To create a new protected document package, you:
326              
327             =over 4
328              
329             =item * Create the package
330              
331             =item * Consume the L<CodeGen::Protection::Role> role
332              
333             =item * Set the C<$VERSION> (in C<\d+.\d+> format)
334              
335             =item * Define C<_start_marker_format>, and C<_end_marker_format> methods
336              
337             =item * Optionally define a C<_tidy> method.
338              
339             =back
340              
341             And that's it!
342              
343             Let's see a concrete example using Javascript.
344              
345             First, define the package:
346              
347             package CodeGen::Protection::Format::Javascript;
348             use Moo;
349              
350             Consume the role:
351              
352             with 'CodeGen::Protection::Role';
353              
354             Set the version:
355              
356             our $VERSION = '0.01'; # required
357              
358             Declare our start and end marker formats:
359              
360             sub _start_marker_format {
361             '// %s %s. Do not touch any code between this and the end comment. Checksum: %s';
362             }
363              
364             sub _end_marker_format {
365             '// %s %s. Do not touch any code between this and the start comment. Checksum: %s';
366             }
367              
368             And if you have code that can tidy Javascript, you can declare a C<_tidy> method:
369              
370             sub _tidy {
371             my ( $self, $document ) = @_;
372             my $tidied = ... return $tidied;
373             }
374              
375             Regarding the start and end formats. They're separate in case we have a
376             document type which requires separate formats. Also, for both the
377             C<_start_marker_format()> and the C<_end_marker_format()>, the first '%s' is
378             the class name and the second '%s' is version number if they're being added to
379             the document. The second '%s' is a version regex (C<_version_re()>) if it's
380             being used to match the start or end marker.
381              
382             The third '%s' is the md5 sum if it's being added to the document. It's a
383             captured md5 regex (C<[0-9a-f]{32}>) if it's being used to match the start or
384             end marker.
385              
386             And that's it! You can now read/write protected Javascript documents:
387              
388             Creating:
389              
390             my $javascript = create_protected_code(
391             type => 'Javascript',
392             protected_code => $sample,
393             );
394              
395             Or rewriting:
396              
397             my $javascript = create_protected_code(
398             type => 'Javascript',
399             existing_code => $javascript,
400             protected_code => $rewritten_code,
401             );
402              
403             =head1 AUTHOR
404              
405             Curtis "Ovid" Poe <ovid@allaroundtheworld.fr>
406              
407             =head1 COPYRIGHT AND LICENSE
408              
409             This software is copyright (c) 2021 by Curtis "Ovid" Poe.
410              
411             This is free software; you can redistribute it and/or modify it under
412             the same terms as the Perl 5 programming language system itself.
413              
414             =cut