]>
Commit | Line | Data |
---|---|---|
1 | #!/bin/sh\r | |
2 | exec perl -w -x $0 ${1+"$@"} # -*- mode: perl; perl-indent-level: 2; -*-\r | |
3 | #!perl -w\r | |
4 | \r | |
5 | \r | |
6 | ##############################################################\r | |
7 | ### ###\r | |
8 | ### cvs2cl.pl: produce ChangeLog(s) from `cvs log` output. ###\r | |
9 | ### ###\r | |
10 | ##############################################################\r | |
11 | \r | |
12 | ## $Revision: 1.1.2.1 $\r | |
13 | ## $Date: 2004/08/12 23:40:08 $\r | |
14 | ## $Author: gespinasse $\r | |
15 | ##\r | |
16 | \r | |
17 | use strict;\r | |
18 | \r | |
19 | use File::Basename qw( fileparse );\r | |
20 | use Getopt::Long qw( GetOptions );\r | |
21 | use Text::Wrap qw( );\r | |
22 | use User::pwent qw( getpwnam );\r | |
23 | \r | |
24 | # The Plan:\r | |
25 | #\r | |
26 | # Read in the logs for multiple files, spit out a nice ChangeLog that\r | |
27 | # mirrors the information entered during `cvs commit'.\r | |
28 | #\r | |
29 | # The problem presents some challenges. In an ideal world, we could\r | |
30 | # detect files with the same author, log message, and checkin time --\r | |
31 | # each <filelist, author, time, logmessage> would be a changelog entry.\r | |
32 | # We'd sort them; and spit them out. Unfortunately, CVS is *not atomic*\r | |
33 | # so checkins can span a range of times. Also, the directory structure\r | |
34 | # could be hierarchical.\r | |
35 | #\r | |
36 | # Another question is whether we really want to have the ChangeLog\r | |
37 | # exactly reflect commits. An author could issue two related commits,\r | |
38 | # with different log entries, reflecting a single logical change to the\r | |
39 | # source. GNU style ChangeLogs group these under a single author/date.\r | |
40 | # We try to do the same.\r | |
41 | #\r | |
42 | # So, we parse the output of `cvs log', storing log messages in a\r | |
43 | # multilevel hash that stores the mapping:\r | |
44 | # directory => author => time => message => filelist\r | |
45 | # As we go, we notice "nearby" commit times and store them together\r | |
46 | # (i.e., under the same timestamp), so they appear in the same log\r | |
47 | # entry.\r | |
48 | #\r | |
49 | # When we've read all the logs, we twist this mapping into\r | |
50 | # a time => author => message => filelist mapping for each directory.\r | |
51 | #\r | |
52 | # If we're not using the `--distributed' flag, the directory is always\r | |
53 | # considered to be `./', even as descend into subdirectories.\r | |
54 | \r | |
55 | # Call Tree\r | |
56 | \r | |
57 | # name number of lines (10.xii.03)\r | |
58 | # parse_options 192\r | |
59 | # derive_changelog 13\r | |
60 | # +-maybe_grab_accumulation_date 38\r | |
61 | # +-read_changelog 277\r | |
62 | # +-maybe_read_user_map_file 94\r | |
63 | # +-run_ext 9\r | |
64 | # +-read_file_path 29\r | |
65 | # +-read_symbolic_name 43\r | |
66 | # +-read_revision 49\r | |
67 | # +-read_date_author_and_state 25\r | |
68 | # +-parse_date_author_and_state 20\r | |
69 | # +-read_branches 36\r | |
70 | # +-output_changelog 424\r | |
71 | # +-pretty_file_list 290\r | |
72 | # +-common_path_prefix 35\r | |
73 | # +-preprocess_msg_text 30\r | |
74 | # +-min 1\r | |
75 | # +-mywrap 16\r | |
76 | # +-last_line_len 5\r | |
77 | # +-wrap_log_entry 177\r | |
78 | #\r | |
79 | # Utilities\r | |
80 | #\r | |
81 | # xml_escape 6\r | |
82 | # slurp_file 11\r | |
83 | # debug 5\r | |
84 | # version 2\r | |
85 | # usage 142\r | |
86 | \r | |
87 | # -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*-\r | |
88 | #\r | |
89 | # Note about a bug-slash-opportunity:\r | |
90 | # -----------------------------------\r | |
91 | #\r | |
92 | # There's a bug in Text::Wrap, which affects cvs2cl. This script\r | |
93 | # reveals it:\r | |
94 | #\r | |
95 | # #!/usr/bin/perl -w\r | |
96 | #\r | |
97 | # use Text::Wrap;\r | |
98 | #\r | |
99 | # my $test_text =\r | |
100 | # "This script demonstrates a bug in Text::Wrap. The very long line\r | |
101 | # following this paragraph will be relocated relative to the surrounding\r | |
102 | # text:\r | |
103 | #\r | |
104 | # ====================================================================\r | |
105 | #\r | |
106 | # See? When the bug happens, we'll get the line of equal signs below\r | |
107 | # this paragraph, even though it should be above.";\r | |
108 | #\r | |
109 | #\r | |
110 | # # Print out the test text with no wrapping:\r | |
111 | # print "$test_text";\r | |
112 | # print "\n";\r | |
113 | # print "\n";\r | |
114 | #\r | |
115 | # # Now print it out wrapped, and see the bug:\r | |
116 | # print wrap ("\t", " ", "$test_text");\r | |
117 | # print "\n";\r | |
118 | # print "\n";\r | |
119 | #\r | |
120 | # If the line of equal signs were one shorter, then the bug doesn't\r | |
121 | # happen. Interesting.\r | |
122 | #\r | |
123 | # Anyway, rather than fix this in Text::Wrap, we might as well write a\r | |
124 | # new wrap() which has the following much-needed features:\r | |
125 | #\r | |
126 | # * initial indentation, like current Text::Wrap()\r | |
127 | # * subsequent line indentation, like current Text::Wrap()\r | |
128 | # * user chooses among: force-break long words, leave them alone, or die()?\r | |
129 | # * preserve existing indentation: chopped chunks from an indented line\r | |
130 | # are indented by same (like this line, not counting the asterisk!)\r | |
131 | # * optional list of things to preserve on line starts, default ">"\r | |
132 | #\r | |
133 | # Note that the last two are essentially the same concept, so unify in\r | |
134 | # implementation and give a good interface to controlling them.\r | |
135 | #\r | |
136 | # And how about:\r | |
137 | #\r | |
138 | # Optionally, when encounter a line pre-indented by same as previous\r | |
139 | # line, then strip the newline and refill, but indent by the same.\r | |
140 | # Yeah...\r | |
141 | \r | |
142 | # Globals --------------------------------------------------------------------\r | |
143 | \r | |
144 | # In case we have to print it out:\r | |
145 | my $VERSION = '$Revision: 1.1.2.1 $';\r | |
146 | $VERSION =~ s/\S+\s+(\S+)\s+\S+/$1/;\r | |
147 | \r | |
148 | ## Vars set by options:\r | |
149 | \r | |
150 | # Print debugging messages?\r | |
151 | my $Debug = 0;\r | |
152 | \r | |
153 | # Just show version and exit?\r | |
154 | my $Print_Version = 0;\r | |
155 | \r | |
156 | # Just print usage message and exit?\r | |
157 | my $Print_Usage = 0;\r | |
158 | \r | |
159 | # What file should we generate (defaults to "ChangeLog")?\r | |
160 | my $Log_File_Name = "ChangeLog";\r | |
161 | \r | |
162 | # Grab most recent entry date from existing ChangeLog file, just add\r | |
163 | # to that ChangeLog.\r | |
164 | my $Cumulative = 0;\r | |
165 | \r | |
166 | # `cvs log -d`, this will repeat the last entry in the old log. This is OK,\r | |
167 | # as it guarantees at least one entry in the update changelog, which means\r | |
168 | # that there will always be a date to extract for the next update. The repeat\r | |
169 | # entry can be removed in postprocessing, if necessary.\r | |
170 | \r | |
171 | # MJP 2003-08-02\r | |
172 | # I don't think this actually does anything useful\r | |
173 | my $Update = 0;\r | |
174 | \r | |
175 | # Expand usernames to email addresses based on a map file?\r | |
176 | my $User_Map_File = '';\r | |
177 | my $User_Passwd_File;\r | |
178 | my $Mail_Domain;\r | |
179 | \r | |
180 | # Output log in chronological order? [default is reverse chronological order]\r | |
181 | my $Chronological_Order = 0;\r | |
182 | \r | |
183 | # Grab user details via gecos\r | |
184 | my $Gecos = 0;\r | |
185 | \r | |
186 | # User domain for gecos email addresses\r | |
187 | my $Domain;\r | |
188 | \r | |
189 | # Output to a file or to stdout?\r | |
190 | my $Output_To_Stdout = 0;\r | |
191 | \r | |
192 | # Eliminate empty log messages?\r | |
193 | my $Prune_Empty_Msgs = 0;\r | |
194 | \r | |
195 | # Tags of which not to output\r | |
196 | my %ignore_tags;\r | |
197 | \r | |
198 | # Show only revisions with Tags\r | |
199 | my %show_tags;\r | |
200 | \r | |
201 | # Don't call Text::Wrap on the body of the message\r | |
202 | my $No_Wrap = 0;\r | |
203 | \r | |
204 | # Indentation of log messages\r | |
205 | my $Indent = "\t";\r | |
206 | \r | |
207 | # Don't do any pretty print processing\r | |
208 | my $Summary = 0;\r | |
209 | \r | |
210 | # Separates header from log message. Code assumes it is either " " or\r | |
211 | # "\n\n", so if there's ever an option to set it to something else,\r | |
212 | # make sure to go through all conditionals that use this var.\r | |
213 | my $After_Header = " ";\r | |
214 | \r | |
215 | # XML Encoding\r | |
216 | my $XML_Encoding = '';\r | |
217 | \r | |
218 | # Format more for programs than for humans.\r | |
219 | my $XML_Output = 0;\r | |
220 | my $No_XML_Namespace = 0;\r | |
221 | my $No_XML_ISO_Date = 0;\r | |
222 | \r | |
223 | # Do some special tweaks for log data that was written in FSF\r | |
224 | # ChangeLog style.\r | |
225 | my $FSF_Style = 0;\r | |
226 | \r | |
227 | # Show times in UTC instead of local time\r | |
228 | my $UTC_Times = 0;\r | |
229 | \r | |
230 | # Show times in output?\r | |
231 | my $Show_Times = 1;\r | |
232 | \r | |
233 | # Show day of week in output?\r | |
234 | my $Show_Day_Of_Week = 0;\r | |
235 | \r | |
236 | # Show revision numbers in output?\r | |
237 | my $Show_Revisions = 0;\r | |
238 | \r | |
239 | # Show dead files in output?\r | |
240 | my $Show_Dead = 0;\r | |
241 | \r | |
242 | # Hide dead trunk files which were created as a result of additions on a\r | |
243 | # branch?\r | |
244 | my $Hide_Branch_Additions = 1;\r | |
245 | \r | |
246 | # Show tags (symbolic names) in output?\r | |
247 | my $Show_Tags = 0;\r | |
248 | \r | |
249 | # Show tags separately in output?\r | |
250 | my $Show_Tag_Dates = 0;\r | |
251 | \r | |
252 | # Show branches by symbolic name in output?\r | |
253 | my $Show_Branches = 0;\r | |
254 | \r | |
255 | # Show only revisions on these branches or their ancestors.\r | |
256 | my @Follow_Branches;\r | |
257 | # Show only revisions on these branches or their ancestors; ignore descendent\r | |
258 | # branches.\r | |
259 | my @Follow_Only;\r | |
260 | \r | |
261 | # Don't bother with files matching this regexp.\r | |
262 | my @Ignore_Files;\r | |
263 | \r | |
264 | # How exactly we match entries. We definitely want "o",\r | |
265 | # and user might add "i" by using --case-insensitive option.\r | |
266 | my $Case_Insensitive = 0;\r | |
267 | \r | |
268 | # Maybe only show log messages matching a certain regular expression.\r | |
269 | my $Regexp_Gate = '';\r | |
270 | \r | |
271 | # Pass this global option string along to cvs, to the left of `log':\r | |
272 | my $Global_Opts = '';\r | |
273 | \r | |
274 | # Pass this option string along to the cvs log subcommand:\r | |
275 | my $Command_Opts = '';\r | |
276 | \r | |
277 | # Read log output from stdin instead of invoking cvs log?\r | |
278 | my $Input_From_Stdin = 0;\r | |
279 | \r | |
280 | # Don't show filenames in output.\r | |
281 | my $Hide_Filenames = 0;\r | |
282 | \r | |
283 | # Don't shorten directory names from filenames.\r | |
284 | my $Common_Dir = 1;\r | |
285 | \r | |
286 | # Max checkin duration. CVS checkin is not atomic, so we may have checkin\r | |
287 | # times that span a range of time. We assume that checkins will last no\r | |
288 | # longer than $Max_Checkin_Duration seconds, and that similarly, no\r | |
289 | # checkins will happen from the same users with the same message less\r | |
290 | # than $Max_Checkin_Duration seconds apart.\r | |
291 | my $Max_Checkin_Duration = 180;\r | |
292 | \r | |
293 | # What to put at the front of [each] ChangeLog.\r | |
294 | my $ChangeLog_Header = '';\r | |
295 | \r | |
296 | # Whether to enable 'delta' mode, and for what start/end tags.\r | |
297 | my $Delta_Mode = 0;\r | |
298 | my $Delta_From = '';\r | |
299 | my $Delta_To = '';\r | |
300 | \r | |
301 | my $TestCode;\r | |
302 | \r | |
303 | # Whether to parse filenames from the RCS filename, and if so what\r | |
304 | # prefix to strip.\r | |
305 | my $RCS_Root;\r | |
306 | \r | |
307 | # Whether to output information on the # of lines added and removed\r | |
308 | # by each file modification.\r | |
309 | my $Show_Lines_Modified = 0;\r | |
310 | \r | |
311 | ## end vars set by options.\r | |
312 | \r | |
313 | # latest observed times for the start/end tags in delta mode\r | |
314 | my $Delta_StartTime = 0;\r | |
315 | my $Delta_EndTime = 0;\r | |
316 | \r | |
317 | my $No_Ancestors = 0;\r | |
318 | \r | |
319 | my $No_Extra_Indent = 0;\r | |
320 | \r | |
321 | my $GroupWithinDate = 0;\r | |
322 | \r | |
323 | # ----------------------------------------------------------------------------\r | |
324 | \r | |
325 | package CVS::Utils::ChangeLog::EntrySet;\r | |
326 | \r | |
327 | sub new {\r | |
328 | my $class = shift;\r | |
329 | my %self;\r | |
330 | bless \%self, $class;\r | |
331 | }\r | |
332 | \r | |
333 | # -------------------------------------\r | |
334 | \r | |
335 | sub output_changelog {\r | |
336 | my $output_type = $XML_Output ? 'XML' : 'Text';\r | |
337 | my $output_class = "CVS::Utils::ChangeLog::EntrySet::Output::${output_type}";\r | |
338 | my $output = $output_class->new(follow_branches => \@Follow_Branches,\r | |
339 | follow_only => \@Follow_Only,\r | |
340 | ignore_tags => \%ignore_tags,\r | |
341 | show_tags => \%show_tags,\r | |
342 | );\r | |
343 | $output->output_changelog(@_);\r | |
344 | }\r | |
345 | \r | |
346 | # -------------------------------------\r | |
347 | \r | |
348 | sub add_fileentry {\r | |
349 | my ($self, $file_full_path, $time, $revision, $state, $lines,\r | |
350 | $branch_names, $branch_roots, $branch_numbers,\r | |
351 | $symbolic_names, $author, $msg_txt) = @_;\r | |
352 | \r | |
353 | my $qunk =\r | |
354 | CVS::Utils::ChangeLog::FileEntry->new($file_full_path, $time, $revision,\r | |
355 | $state, $lines,\r | |
356 | $branch_names, $branch_roots,\r | |
357 | $branch_numbers,\r | |
358 | $symbolic_names);\r | |
359 | \r | |
360 | # We might be including revision numbers and/or tags and/or\r | |
361 | # branch names in the output. Most of the code from here to\r | |
362 | # loop-end deals with organizing these in qunk.\r | |
363 | \r | |
364 | unless ( $Hide_Branch_Additions\r | |
365 | and\r | |
366 | $msg_txt =~ /file .+ was initially added on branch \S+./ ) {\r | |
367 | # Add this file to the list\r | |
368 | # (We use many spoonfuls of autovivication magic. Hashes and arrays\r | |
369 | # will spring into existence if they aren't there already.)\r | |
370 | \r | |
371 | &main::debug ("(pushing log msg for ". $qunk->dir_key . $qunk->filename . ")\n");\r | |
372 | \r | |
373 | # Store with the files in this commit. Later we'll loop through\r | |
374 | # again, making sure that revisions with the same log message\r | |
375 | # and nearby commit times are grouped together as one commit.\r | |
376 | $self->{$qunk->dir_key}{$author}{$time}{$msg_txt} =\r | |
377 | CVS::Utils::ChangeLog::Message->new($msg_txt)\r | |
378 | unless exists $self->{$qunk->dir_key}{$author}{$time}{$msg_txt};\r | |
379 | $self->{$qunk->dir_key}{$author}{$time}{$msg_txt}->add_fileentry($qunk);\r | |
380 | }\r | |
381 | \r | |
382 | }\r | |
383 | \r | |
384 | # ----------------------------------------------------------------------------\r | |
385 | \r | |
386 | package CVS::Utils::ChangeLog::EntrySet::Output::Text;\r | |
387 | \r | |
388 | use base qw( CVS::Utils::ChangeLog::EntrySet::Output );\r | |
389 | \r | |
390 | use File::Basename qw( fileparse );\r | |
391 | \r | |
392 | sub new {\r | |
393 | my $class = shift;\r | |
394 | my $self = $class->SUPER::new(@_);\r | |
395 | }\r | |
396 | \r | |
397 | # -------------------------------------\r | |
398 | \r | |
399 | sub wday {\r | |
400 | my $self = shift; my $class = ref $self;\r | |
401 | my ($wday) = @_;\r | |
402 | \r | |
403 | return $Show_Day_Of_Week ? ' ' . $class->weekday_en($wday) : '';\r | |
404 | }\r | |
405 | \r | |
406 | # -------------------------------------\r | |
407 | \r | |
408 | sub header_line {\r | |
409 | my $self = shift;\r | |
410 | my ($time, $author, $lastdate) = @_;\r | |
411 | \r | |
412 | my $header_line = '';\r | |
413 | \r | |
414 | my (undef,$min,$hour,$mday,$mon,$year,$wday)\r | |
415 | = $UTC_Times ? gmtime($time) : localtime($time);\r | |
416 | \r | |
417 | my $date = $self->fdatetime($time);\r | |
418 | \r | |
419 | if ($Show_Times) {\r | |
420 | $header_line =\r | |
421 | sprintf "%s %s\n\n", $date, $author;\r | |
422 | } else {\r | |
423 | if ( ! defined $lastdate or $date ne $lastdate or ! $GroupWithinDate ) {\r | |
424 | if ( $GroupWithinDate ) {\r | |
425 | $header_line = "$date\n\n";\r | |
426 | } else {\r | |
427 | $header_line = "$date $author\n\n";\r | |
428 | }\r | |
429 | } else {\r | |
430 | $header_line = '';\r | |
431 | }\r | |
432 | }\r | |
433 | }\r | |
434 | \r | |
435 | # -------------------------------------\r | |
436 | \r | |
437 | sub preprocess_msg_text {\r | |
438 | my $self = shift;\r | |
439 | my ($text) = @_;\r | |
440 | \r | |
441 | $text = $self->SUPER::preprocess_msg_text($text);\r | |
442 | \r | |
443 | unless ( $No_Wrap ) {\r | |
444 | # Strip off lone newlines, but only for lines that don't begin with\r | |
445 | # whitespace or a mail-quoting character, since we want to preserve\r | |
446 | # that kind of formatting. Also don't strip newlines that follow a\r | |
447 | # period; we handle those specially next. And don't strip\r | |
448 | # newlines that precede an open paren.\r | |
449 | 1 while $text =~ s/(^|\n)([^>\s].*[^.\n])\n([^>\n])/$1$2 $3/g;\r | |
450 | \r | |
451 | # If a newline follows a period, make sure that when we bring up the\r | |
452 | # bottom sentence, it begins with two spaces.\r | |
453 | 1 while $text =~ s/(^|\n)([^>\s].*)\n([^>\n])/$1$2 $3/g;\r | |
454 | }\r | |
455 | \r | |
456 | return $text;\r | |
457 | }\r | |
458 | \r | |
459 | # -------------------------------------\r | |
460 | \r | |
461 | # Here we take a bunch of qunks and convert them into printed\r | |
462 | # summary that will include all the information the user asked for.\r | |
463 | sub pretty_file_list {\r | |
464 | my $self = shift;\r | |
465 | \r | |
466 | return ''\r | |
467 | if $Hide_Filenames;\r | |
468 | \r | |
469 | my $qunksref = shift;\r | |
470 | \r | |
471 | my @filenames;\r | |
472 | my $beauty = ''; # The accumulating header string for this entry.\r | |
473 | my %non_unanimous_tags; # Tags found in a proper subset of qunks\r | |
474 | my %unanimous_tags; # Tags found in all qunks\r | |
475 | my %all_branches; # Branches found in any qunk\r | |
476 | my $fbegun = 0; # Did we begin printing filenames yet?\r | |
477 | \r | |
478 | my ($common_dir, $qunkrefs) =\r | |
479 | $self->_pretty_file_list(\(%unanimous_tags, %non_unanimous_tags, %all_branches), $qunksref);\r | |
480 | \r | |
481 | my @qunkrefs = @$qunkrefs;\r | |
482 | \r | |
483 | # Not XML output, so complexly compactify for chordate consumption. At this\r | |
484 | # point we have enough global information about all the qunks to organize\r | |
485 | # them non-redundantly for output.\r | |
486 | \r | |
487 | if ($common_dir) {\r | |
488 | # Note that $common_dir still has its trailing slash\r | |
489 | $beauty .= "$common_dir: ";\r | |
490 | }\r | |
491 | \r | |
492 | if ($Show_Branches)\r | |
493 | {\r | |
494 | # For trailing revision numbers.\r | |
495 | my @brevisions;\r | |
496 | \r | |
497 | foreach my $branch (keys (%all_branches))\r | |
498 | {\r | |
499 | foreach my $qunkref (@qunkrefs)\r | |
500 | {\r | |
501 | if ((defined ($qunkref->branch))\r | |
502 | and ($qunkref->branch eq $branch))\r | |
503 | {\r | |
504 | if ($fbegun) {\r | |
505 | # kff todo: comma-delimited in XML too? Sure.\r | |
506 | $beauty .= ", ";\r | |
507 | }\r | |
508 | else {\r | |
509 | $fbegun = 1;\r | |
510 | }\r | |
511 | my $fname = substr ($qunkref->filename, length ($common_dir));\r | |
512 | $beauty .= $fname;\r | |
513 | $qunkref->{'printed'} = 1; # Just setting a mark bit, basically\r | |
514 | \r | |
515 | if ( $Show_Tags and defined $qunkref->tags ) {\r | |
516 | my @tags = grep ($non_unanimous_tags{$_}, @{$qunkref->tags});\r | |
517 | \r | |
518 | if (@tags) {\r | |
519 | $beauty .= " (tags: ";\r | |
520 | $beauty .= join (', ', @tags);\r | |
521 | $beauty .= ")";\r | |
522 | }\r | |
523 | }\r | |
524 | \r | |
525 | if ($Show_Revisions) {\r | |
526 | # Collect the revision numbers' last components, but don't\r | |
527 | # print them -- they'll get printed with the branch name\r | |
528 | # later.\r | |
529 | $qunkref->revision =~ /.+\.([\d]+)$/;\r | |
530 | push (@brevisions, $1);\r | |
531 | \r | |
532 | # todo: we're still collecting branch roots, but we're not\r | |
533 | # showing them anywhere. If we do show them, it would be\r | |
534 | # nifty to just call them revision "0" on a the branch.\r | |
535 | # Yeah, that's the ticket.\r | |
536 | }\r | |
537 | }\r | |
538 | }\r | |
539 | $beauty .= " ($branch";\r | |
540 | if (@brevisions) {\r | |
541 | if ((scalar (@brevisions)) > 1) {\r | |
542 | $beauty .= ".[";\r | |
543 | $beauty .= (join (',', @brevisions));\r | |
544 | $beauty .= "]";\r | |
545 | }\r | |
546 | else {\r | |
547 | # Square brackets are spurious here, since there's no range to\r | |
548 | # encapsulate\r | |
549 | $beauty .= ".$brevisions[0]";\r | |
550 | }\r | |
551 | }\r | |
552 | $beauty .= ")";\r | |
553 | }\r | |
554 | }\r | |
555 | \r | |
556 | # Okay; any qunks that were done according to branch are taken care\r | |
557 | # of, and marked as printed. Now print everyone else.\r | |
558 | \r | |
559 | my %fileinfo_printed;\r | |
560 | foreach my $qunkref (@qunkrefs)\r | |
561 | {\r | |
562 | next if (defined ($qunkref->{'printed'})); # skip if already printed\r | |
563 | \r | |
564 | my $b = substr ($qunkref->filename, length ($common_dir));\r | |
565 | # todo: Shlomo's change was this:\r | |
566 | # $beauty .= substr ($qunkref->filename,\r | |
567 | # (($common_dir eq "./") ? '' : length ($common_dir)));\r | |
568 | $qunkref->{'printed'} = 1; # Set a mark bit.\r | |
569 | \r | |
570 | if ($Show_Revisions || $Show_Tags || $Show_Dead)\r | |
571 | {\r | |
572 | my $started_addendum = 0;\r | |
573 | \r | |
574 | if ($Show_Revisions) {\r | |
575 | $started_addendum = 1;\r | |
576 | $b .= " (";\r | |
577 | $b .= $qunkref->revision;\r | |
578 | }\r | |
579 | if ($Show_Dead && $qunkref->state =~ /dead/)\r | |
580 | {\r | |
581 | # Deliberately not using $started_addendum. Keeping it simple.\r | |
582 | $b .= "[DEAD]";\r | |
583 | }\r | |
584 | if ($Show_Tags && (defined $qunkref->tags)) {\r | |
585 | my @tags = grep ($non_unanimous_tags{$_}, @{$qunkref->tags});\r | |
586 | if ((scalar (@tags)) > 0) {\r | |
587 | if ($started_addendum) {\r | |
588 | $b .= ", ";\r | |
589 | }\r | |
590 | else {\r | |
591 | $b .= " (tags: ";\r | |
592 | }\r | |
593 | $b .= join (', ', @tags);\r | |
594 | $started_addendum = 1;\r | |
595 | }\r | |
596 | }\r | |
597 | if ($started_addendum) {\r | |
598 | $b .= ")";\r | |
599 | }\r | |
600 | }\r | |
601 | \r | |
602 | unless ( exists $fileinfo_printed{$b} ) {\r | |
603 | if ($fbegun) {\r | |
604 | $beauty .= ", ";\r | |
605 | } else {\r | |
606 | $fbegun = 1;\r | |
607 | }\r | |
608 | $beauty .= $b, $fileinfo_printed{$b} = 1;\r | |
609 | }\r | |
610 | }\r | |
611 | \r | |
612 | # Unanimous tags always come last.\r | |
613 | if ($Show_Tags && %unanimous_tags)\r | |
614 | {\r | |
615 | $beauty .= " (utags: ";\r | |
616 | $beauty .= join (', ', sort keys (%unanimous_tags));\r | |
617 | $beauty .= ")";\r | |
618 | }\r | |
619 | \r | |
620 | # todo: still have to take care of branch_roots?\r | |
621 | \r | |
622 | $beauty = "$beauty:";\r | |
623 | \r | |
624 | return $beauty;\r | |
625 | }\r | |
626 | \r | |
627 | # -------------------------------------\r | |
628 | \r | |
629 | sub output_tagdate {\r | |
630 | my $self = shift;\r | |
631 | my ($fh, $time, $tag) = @_;\r | |
632 | \r | |
633 | my $fdatetime = $self->fdatetime($time);\r | |
634 | print $fh "$fdatetime tag $tag\n\n";\r | |
635 | return;\r | |
636 | }\r | |
637 | \r | |
638 | # -------------------------------------\r | |
639 | \r | |
640 | sub format_body {\r | |
641 | my $self = shift;\r | |
642 | my ($msg, $files, $qunklist) = @_;\r | |
643 | \r | |
644 | my $body;\r | |
645 | \r | |
646 | if ( $No_Wrap and ! $Summary ) {\r | |
647 | $msg = $self->preprocess_msg_text($msg);\r | |
648 | $files = $self->mywrap("\t", "\t ", "* $files");\r | |
649 | $msg =~ s/\n(.+)/\n$Indent$1/g;\r | |
650 | unless ($After_Header eq " ") {\r | |
651 | $msg =~ s/^(.+)/$Indent$1/g;\r | |
652 | }\r | |
653 | if ( $Hide_Filenames ) {\r | |
654 | $body = $After_Header . $msg;\r | |
655 | } else {\r | |
656 | $body = $files . $After_Header . $msg;\r | |
657 | }\r | |
658 | } elsif ( $Summary ) {\r | |
659 | my ($filelist, $qunk);\r | |
660 | my (@DeletedQunks, @AddedQunks, @ChangedQunks);\r | |
661 | \r | |
662 | $msg = $self->preprocess_msg_text($msg);\r | |
663 | #\r | |
664 | # Sort the files (qunks) according to the operation that was\r | |
665 | # performed. Files which were added have no line change\r | |
666 | # indicator, whereas deleted files have state dead.\r | |
667 | #\r | |
668 | foreach $qunk ( @$qunklist ) {\r | |
669 | if ( "dead" eq $qunk->state) {\r | |
670 | push @DeletedQunks, $qunk;\r | |
671 | } elsif ( ! defined $qunk->lines ) {\r | |
672 | push @AddedQunks, $qunk;\r | |
673 | } else {\r | |
674 | push @ChangedQunks, $qunk;\r | |
675 | }\r | |
676 | }\r | |
677 | #\r | |
678 | # The qunks list was originally in tree search order. Let's\r | |
679 | # get that back. The lists, if they exist, will be reversed upon\r | |
680 | # processing.\r | |
681 | #\r | |
682 | \r | |
683 | #\r | |
684 | # Now write the three sections onto $filelist\r | |
685 | #\r | |
686 | if ( @DeletedQunks ) {\r | |
687 | $filelist .= "\tDeleted:\n";\r | |
688 | foreach $qunk ( @DeletedQunks ) {\r | |
689 | $filelist .= "\t\t" . $qunk->filename;\r | |
690 | $filelist .= " (" . $qunk->revision . ")";\r | |
691 | $filelist .= "\n";\r | |
692 | }\r | |
693 | undef @DeletedQunks;\r | |
694 | }\r | |
695 | \r | |
696 | if ( @AddedQunks ) {\r | |
697 | $filelist .= "\tAdded:\n";\r | |
698 | foreach $qunk (@AddedQunks) {\r | |
699 | $filelist .= "\t\t" . $qunk->filename;\r | |
700 | $filelist .= " (" . $qunk->revision . ")";\r | |
701 | $filelist .= "\n";\r | |
702 | }\r | |
703 | undef @AddedQunks ;\r | |
704 | }\r | |
705 | \r | |
706 | if ( @ChangedQunks ) {\r | |
707 | $filelist .= "\tChanged:\n";\r | |
708 | foreach $qunk (@ChangedQunks) {\r | |
709 | $filelist .= "\t\t" . $qunk->filename;\r | |
710 | $filelist .= " (" . $qunk->revision . ")";\r | |
711 | $filelist .= ", \"" . $qunk->state . "\"";\r | |
712 | $filelist .= ", lines: " . $qunk->lines;\r | |
713 | $filelist .= "\n";\r | |
714 | }\r | |
715 | undef @ChangedQunks;\r | |
716 | }\r | |
717 | \r | |
718 | chomp $filelist;\r | |
719 | \r | |
720 | if ( $Hide_Filenames ) {\r | |
721 | $filelist = '';\r | |
722 | }\r | |
723 | \r | |
724 | $msg =~ s/\n(.*)/\n$Indent$1/g;\r | |
725 | unless ( $After_Header eq " " or $FSF_Style ) {\r | |
726 | $msg =~ s/^(.*)/$Indent$1/g;\r | |
727 | }\r | |
728 | \r | |
729 | unless ( $No_Wrap ) {\r | |
730 | if ( $FSF_Style ) {\r | |
731 | $msg = $self->wrap_log_entry($msg, '', 69, 69);\r | |
732 | chomp($msg);\r | |
733 | chomp($msg);\r | |
734 | } else {\r | |
735 | $msg = $self->mywrap('', $Indent, "$msg");\r | |
736 | $msg =~ s/[ \t]+\n/\n/g;\r | |
737 | }\r | |
738 | }\r | |
739 | \r | |
740 | $body = $filelist . $After_Header . $msg;\r | |
741 | } else { # do wrapping, either FSF-style or regular\r | |
742 | my $latter_wrap = $No_Extra_Indent ? $Indent : "$Indent ";\r | |
743 | \r | |
744 | if ( $FSF_Style ) {\r | |
745 | $files = $self->mywrap($Indent, $latter_wrap, "* $files");\r | |
746 | \r | |
747 | my $files_last_line_len = 0;\r | |
748 | if ( $After_Header eq " " ) {\r | |
749 | $files_last_line_len = $self->last_line_len($files);\r | |
750 | $files_last_line_len += 1; # for $After_Header\r | |
751 | }\r | |
752 | \r | |
753 | $msg = $self->wrap_log_entry($msg, $latter_wrap, 69-$files_last_line_len, 69);\r | |
754 | $body = $files . $After_Header . $msg;\r | |
755 | } else { # not FSF-style\r | |
756 | $msg = $self->preprocess_msg_text($msg);\r | |
757 | $body = $files . $After_Header . $msg;\r | |
758 | $body = $self->mywrap($Indent, $latter_wrap, "* $body");\r | |
759 | $body =~ s/[ \t]+\n/\n/g;\r | |
760 | }\r | |
761 | }\r | |
762 | \r | |
763 | return $body;\r | |
764 | }\r | |
765 | \r | |
766 | # ----------------------------------------------------------------------------\r | |
767 | \r | |
768 | package CVS::Utils::ChangeLog::EntrySet::Output::XML;\r | |
769 | \r | |
770 | use base qw( CVS::Utils::ChangeLog::EntrySet::Output );\r | |
771 | \r | |
772 | use File::Basename qw( fileparse );\r | |
773 | \r | |
774 | sub new {\r | |
775 | my $class = shift;\r | |
776 | my $self = $class->SUPER::new(@_);\r | |
777 | }\r | |
778 | \r | |
779 | # -------------------------------------\r | |
780 | \r | |
781 | sub header_line {\r | |
782 | my $self = shift;\r | |
783 | my ($time, $author, $lastdate) = @_;\r | |
784 | \r | |
785 | my $header_line = '';\r | |
786 | \r | |
787 | my $isoDate;\r | |
788 | \r | |
789 | my ($y, $m, $d, $H, $M, $S) = (gmtime($time))[5,4,3,2,1,0];\r | |
790 | \r | |
791 | # Ideally, this would honor $UTC_Times and use +HH:MM syntax\r | |
792 | $isoDate = sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",\r | |
793 | $y + 1900, $m + 1, $d, $H, $M, $S);\r | |
794 | \r | |
795 | my (undef,$min,$hour,$mday,$mon,$year,$wday)\r | |
796 | = $UTC_Times ? gmtime($time) : localtime($time);\r | |
797 | \r | |
798 | my $date = $self->fdatetime($time);\r | |
799 | $wday = $self->wday($wday);\r | |
800 | \r | |
801 | $header_line =\r | |
802 | sprintf ("<date>%4u-%02u-%02u</date>\n${wday}<time>%02u:%02u</time>\n",\r | |
803 | $year+1900, $mon+1, $mday, $hour, $min);\r | |
804 | $header_line .= "<isoDate>$isoDate</isoDate>\n"\r | |
805 | unless $No_XML_ISO_Date;\r | |
806 | $header_line .= sprintf("<author>%s</author>\n" , $author);\r | |
807 | }\r | |
808 | \r | |
809 | # -------------------------------------\r | |
810 | \r | |
811 | sub wday {\r | |
812 | my $self = shift; my $class = ref $self;\r | |
813 | my ($wday) = @_;\r | |
814 | \r | |
815 | return '<weekday>' . $class->weekday_en($wday) . "</weekday>\n";\r | |
816 | }\r | |
817 | \r | |
818 | # -------------------------------------\r | |
819 | \r | |
820 | sub escape {\r | |
821 | my $self = shift;\r | |
822 | \r | |
823 | my $txt = shift;\r | |
824 | $txt =~ s/&/&/g;\r | |
825 | $txt =~ s/</</g;\r | |
826 | $txt =~ s/>/>/g;\r | |
827 | return $txt;\r | |
828 | }\r | |
829 | \r | |
830 | # -------------------------------------\r | |
831 | \r | |
832 | sub output_header {\r | |
833 | my $self = shift;\r | |
834 | my ($fh) = @_;\r | |
835 | \r | |
836 | my $encoding =\r | |
837 | length $XML_Encoding ? qq'encoding="$XML_Encoding"' : '';\r | |
838 | my $version = 'version="1.0"';\r | |
839 | my $declaration =\r | |
840 | sprintf '<?xml %s?>', join ' ', grep length, $version, $encoding;\r | |
841 | my $root =\r | |
842 | $No_XML_Namespace ?\r | |
843 | '<changelog>' :\r | |
844 | '<changelog xmlns="http://www.red-bean.com/xmlns/cvs2cl/">';\r | |
845 | print $fh "$declaration\n\n$root\n\n";\r | |
846 | }\r | |
847 | \r | |
848 | # -------------------------------------\r | |
849 | \r | |
850 | sub output_footer {\r | |
851 | my $self = shift;\r | |
852 | my ($fh) = @_;\r | |
853 | \r | |
854 | print $fh "</changelog>\n";\r | |
855 | }\r | |
856 | \r | |
857 | # -------------------------------------\r | |
858 | \r | |
859 | sub preprocess_msg_text {\r | |
860 | my $self = shift;\r | |
861 | my ($text) = @_;\r | |
862 | \r | |
863 | $text = $self->SUPER::preprocess_msg_text($text);\r | |
864 | \r | |
865 | $text = $self->escape($text);\r | |
866 | chomp $text;\r | |
867 | $text = "<msg>${text}</msg>\n";\r | |
868 | \r | |
869 | return $text;\r | |
870 | }\r | |
871 | \r | |
872 | # -------------------------------------\r | |
873 | \r | |
874 | # Here we take a bunch of qunks and convert them into a printed\r | |
875 | # summary that will include all the information the user asked for.\r | |
876 | sub pretty_file_list {\r | |
877 | my $self = shift;\r | |
878 | my ($qunksref) = @_;\r | |
879 | \r | |
880 | my $beauty = ''; # The accumulating header string for this entry.\r | |
881 | my %non_unanimous_tags; # Tags found in a proper subset of qunks\r | |
882 | my %unanimous_tags; # Tags found in all qunks\r | |
883 | my %all_branches; # Branches found in any qunk\r | |
884 | my $fbegun = 0; # Did we begin printing filenames yet?\r | |
885 | \r | |
886 | my ($common_dir, $qunkrefs) =\r | |
887 | $self->_pretty_file_list(\(%unanimous_tags, %non_unanimous_tags, %all_branches),\r | |
888 | $qunksref);\r | |
889 | \r | |
890 | my @qunkrefs = @$qunkrefs;\r | |
891 | \r | |
892 | # If outputting XML, then our task is pretty simple, because we\r | |
893 | # don't have to detect common dir, common tags, branch prefixing,\r | |
894 | # etc. We just output exactly what we have, and don't worry about\r | |
895 | # redundancy or readability.\r | |
896 | \r | |
897 | foreach my $qunkref (@qunkrefs)\r | |
898 | {\r | |
899 | my $filename = $qunkref->filename;\r | |
900 | my $state = $qunkref->state;\r | |
901 | my $revision = $qunkref->revision;\r | |
902 | my $tags = $qunkref->tags;\r | |
903 | my $branch = $qunkref->branch;\r | |
904 | my $branchroots = $qunkref->roots;\r | |
905 | my $lines = $qunkref->lines;\r | |
906 | \r | |
907 | $filename = $self->escape($filename); # probably paranoia\r | |
908 | $revision = $self->escape($revision); # definitely paranoia\r | |
909 | \r | |
910 | $beauty .= "<file>\n";\r | |
911 | $beauty .= "<name>${filename}</name>\n";\r | |
912 | $beauty .= "<cvsstate>${state}</cvsstate>\n";\r | |
913 | $beauty .= "<revision>${revision}</revision>\n";\r | |
914 | \r | |
915 | if ($Show_Lines_Modified\r | |
916 | && $lines && $lines =~ m/\+(\d+)\s+-(\d+)/) {\r | |
917 | $beauty .= "<linesadded>$1</linesadded>\n";\r | |
918 | $beauty .= "<linesremoved>$2</linesremoved>\n";\r | |
919 | }\r | |
920 | \r | |
921 | if ($branch) {\r | |
922 | $branch = $self->escape($branch); # more paranoia\r | |
923 | $beauty .= "<branch>${branch}</branch>\n";\r | |
924 | }\r | |
925 | foreach my $tag (@$tags) {\r | |
926 | $tag = $self->escape($tag); # by now you're used to the paranoia\r | |
927 | $beauty .= "<tag>${tag}</tag>\n";\r | |
928 | }\r | |
929 | foreach my $root (@$branchroots) {\r | |
930 | $root = $self->escape($root); # which is good, because it will continue\r | |
931 | $beauty .= "<branchroot>${root}</branchroot>\n";\r | |
932 | }\r | |
933 | $beauty .= "</file>\n";\r | |
934 | }\r | |
935 | \r | |
936 | # Theoretically, we could go home now. But as long as we're here,\r | |
937 | # let's print out the common_dir and utags, as a convenience to\r | |
938 | # the receiver (after all, earlier code calculated that stuff\r | |
939 | # anyway, so we might as well take advantage of it).\r | |
940 | \r | |
941 | if ((scalar (keys (%unanimous_tags))) > 1) {\r | |
942 | foreach my $utag ((keys (%unanimous_tags))) {\r | |
943 | $utag = $self->escape($utag); # the usual paranoia\r | |
944 | $beauty .= "<utag>${utag}</utag>\n";\r | |
945 | }\r | |
946 | }\r | |
947 | if ($common_dir) {\r | |
948 | $common_dir = $self->escape($common_dir);\r | |
949 | $beauty .= "<commondir>${common_dir}</commondir>\n";\r | |
950 | }\r | |
951 | \r | |
952 | # That's enough for XML, time to go home:\r | |
953 | return $beauty;\r | |
954 | }\r | |
955 | \r | |
956 | # -------------------------------------\r | |
957 | \r | |
958 | sub output_tagdate {\r | |
959 | # NOT YET DONE\r | |
960 | }\r | |
961 | \r | |
962 | # -------------------------------------\r | |
963 | \r | |
964 | sub output_entry {\r | |
965 | my $self = shift;\r | |
966 | my ($fh, $entry) = @_;\r | |
967 | print $fh "<entry>\n$entry</entry>\n\n";\r | |
968 | }\r | |
969 | \r | |
970 | # -------------------------------------\r | |
971 | \r | |
972 | sub format_body {\r | |
973 | my $self = shift;\r | |
974 | my ($msg, $files, $qunklist) = @_;\r | |
975 | \r | |
976 | $msg = $self->preprocess_msg_text($msg);\r | |
977 | return $files . $msg;\r | |
978 | }\r | |
979 | \r | |
980 | # ----------------------------------------------------------------------------\r | |
981 | \r | |
982 | package CVS::Utils::ChangeLog::EntrySet::Output;\r | |
983 | \r | |
984 | use Carp qw( croak );\r | |
985 | use File::Basename qw( fileparse );\r | |
986 | \r | |
987 | # Class Utility Functions -------------\r | |
988 | \r | |
989 | { # form closure\r | |
990 | \r | |
991 | my @weekdays = (qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday));\r | |
992 | sub weekday_en {\r | |
993 | my $class = shift;\r | |
994 | return $weekdays[$_[0]];\r | |
995 | }\r | |
996 | \r | |
997 | }\r | |
998 | \r | |
999 | # -------------------------------------\r | |
1000 | \r | |
1001 | sub new {\r | |
1002 | my ($proto, %args) = @_;\r | |
1003 | my $class = ref $proto || $proto;\r | |
1004 | \r | |
1005 | my $follow_branches = delete $args{follow_branches};\r | |
1006 | my $follow_only = delete $args{follow_only};\r | |
1007 | my $ignore_tags = delete $args{ignore_tags};\r | |
1008 | my $show_tags = delete $args{show_tags};\r | |
1009 | die "Unrecognized arg to EntrySet::Output::new: '$_'\n"\r | |
1010 | for keys %args;\r | |
1011 | \r | |
1012 | bless +{follow_branches => $follow_branches,\r | |
1013 | follow_only => $follow_only,\r | |
1014 | show_tags => $show_tags,\r | |
1015 | ignore_tags => $ignore_tags,\r | |
1016 | }, $class;\r | |
1017 | }\r | |
1018 | \r | |
1019 | # Abstract Subrs ----------------------\r | |
1020 | \r | |
1021 | sub wday { croak "Whoops. Abtract method call (wday).\n" }\r | |
1022 | sub pretty_file_list { croak "Whoops. Abtract method call (pretty_file_list).\n" }\r | |
1023 | sub output_tagdate { croak "Whoops. Abtract method call (output_tagdate).\n" }\r | |
1024 | sub header_line { croak "Whoops. Abtract method call (header_line).\n" }\r | |
1025 | \r | |
1026 | # Instance Subrs ----------------------\r | |
1027 | \r | |
1028 | sub output_header { }\r | |
1029 | \r | |
1030 | # -------------------------------------\r | |
1031 | \r | |
1032 | sub output_entry {\r | |
1033 | my $self = shift;\r | |
1034 | my ($fh, $entry) = @_;\r | |
1035 | print $fh "$entry\n";\r | |
1036 | }\r | |
1037 | \r | |
1038 | # -------------------------------------\r | |
1039 | \r | |
1040 | sub output_footer { }\r | |
1041 | \r | |
1042 | # -------------------------------------\r | |
1043 | \r | |
1044 | sub escape { return $_[1] }\r | |
1045 | \r | |
1046 | # -------------------------------------\r | |
1047 | \r | |
1048 | sub _revision_is_wanted {\r | |
1049 | my ($self, $qunk) = @_;\r | |
1050 | \r | |
1051 | my ($revision, $branch_numbers) = @{$qunk}{qw( revision branch_numbers )};\r | |
1052 | my $follow_branches = $self->{follow_branches};\r | |
1053 | my $follow_only = $self->{follow_only};\r | |
1054 | \r | |
1055 | #print STDERR "IG: ", join(',', keys %{$self->{ignore_tags}}), "\n";\r | |
1056 | #print STDERR "IX: ", join(',', @{$qunk->{tags}}), "\n" if defined $qunk->{tags};\r | |
1057 | #print STDERR "IQ: ", join(',', keys %{$qunk->{branch_numbers}}), "\n" if defined $qunk->{branch_numbers};\r | |
1058 | #use Data::Dumper; print STDERR Dumper $qunk;\r | |
1059 | \r | |
1060 | for my $ignore_tag (keys %{$self->{ignore_tags}}) {\r | |
1061 | return\r | |
1062 | if defined $qunk->{tags} and grep $_ eq $ignore_tag, @{$qunk->{tags}};\r | |
1063 | }\r | |
1064 | \r | |
1065 | if ( keys %{$self->{show_tags}} ) {\r | |
1066 | for my $show_tag (keys %{$self->{show_tags}}) {\r | |
1067 | return\r | |
1068 | if ! defined $qunk->{tags} or ! grep $_ eq $show_tag, @{$qunk->{tags}};\r | |
1069 | }\r | |
1070 | }\r | |
1071 | \r | |
1072 | return 1\r | |
1073 | unless @$follow_branches + @$follow_only; # no follow is follow all\r | |
1074 | \r | |
1075 | for my $x (map([$_, 1], @$follow_branches),\r | |
1076 | map([$_, 0], @$follow_only )) {\r | |
1077 | my ($branch, $followsub) = @$x;\r | |
1078 | \r | |
1079 | # Special case for following trunk revisions\r | |
1080 | return 1\r | |
1081 | if $branch =~ /^trunk$/i and $revision =~ /^[0-9]+\.[0-9]+$/;\r | |
1082 | \r | |
1083 | if ( my $branch_number = $branch_numbers->{$branch} ) {\r | |
1084 | # Are we on one of the follow branches or an ancestor of same?\r | |
1085 | \r | |
1086 | # If this revision is a prefix of the branch number, or possibly is less\r | |
1087 | # in the minormost number, OR if this branch number is a prefix of the\r | |
1088 | # revision, then yes. Otherwise, no.\r | |
1089 | \r | |
1090 | # So below, we determine if any of those conditions are met.\r | |
1091 | \r | |
1092 | # Trivial case: is this revision on the branch? (Compare this way to\r | |
1093 | # avoid regexps that screw up Emacs indentation, argh.)\r | |
1094 | if ( substr($revision, 0, (length($branch_number) + 1))\r | |
1095 | eq\r | |
1096 | ($branch_number . ".") ) {\r | |
1097 | if ( $followsub ) {\r | |
1098 | return 1;\r | |
1099 | } elsif (length($revision) == length($branch_number)+2 ) {\r | |
1100 | return 1;\r | |
1101 | }\r | |
1102 | } elsif ( length($branch_number) > length($revision)\r | |
1103 | and\r | |
1104 | $No_Ancestors ) {\r | |
1105 | # Non-trivial case: check if rev is ancestral to branch\r | |
1106 | \r | |
1107 | # r_left still has the trailing "."\r | |
1108 | my ($r_left, $r_end) = ($revision =~ /^((?:\d+\.)+)(\d+)$/);\r | |
1109 | \r | |
1110 | # b_left still has trailing "."\r | |
1111 | # b_mid has no trailing "."\r | |
1112 | my ($b_left, $b_mid) = ($branch_number =~ /^((?:\d+\.)+)(\d+)\.\d+$/);\r | |
1113 | return 1\r | |
1114 | if $r_left eq $b_left and $r_end <= $b_mid;\r | |
1115 | }\r | |
1116 | }\r | |
1117 | }\r | |
1118 | \r | |
1119 | return;\r | |
1120 | }\r | |
1121 | \r | |
1122 | # -------------------------------------\r | |
1123 | \r | |
1124 | sub output_changelog {\r | |
1125 | my $self = shift; my $class = ref $self;\r | |
1126 | my ($grand_poobah) = @_;\r | |
1127 | ### Process each ChangeLog\r | |
1128 | \r | |
1129 | while (my ($dir,$authorhash) = each %$grand_poobah)\r | |
1130 | {\r | |
1131 | &main::debug ("DOING DIR: $dir\n");\r | |
1132 | \r | |
1133 | # Here we twist our hash around, from being\r | |
1134 | # author => time => message => filelist\r | |
1135 | # in %$authorhash to\r | |
1136 | # time => author => message => filelist\r | |
1137 | # in %changelog.\r | |
1138 | #\r | |
1139 | # This is also where we merge entries. The algorithm proceeds\r | |
1140 | # through the timeline of the changelog with a sliding window of\r | |
1141 | # $Max_Checkin_Duration seconds; within that window, entries that\r | |
1142 | # have the same log message are merged.\r | |
1143 | #\r | |
1144 | # (To save space, we zap %$authorhash after we've copied\r | |
1145 | # everything out of it.)\r | |
1146 | \r | |
1147 | my %changelog;\r | |
1148 | while (my ($author,$timehash) = each %$authorhash)\r | |
1149 | {\r | |
1150 | my %stamptime;\r | |
1151 | foreach my $time (sort {$a <=> $b} (keys %$timehash))\r | |
1152 | {\r | |
1153 | my $msghash = $timehash->{$time};\r | |
1154 | while (my ($msg,$qunklist) = each %$msghash)\r | |
1155 | {\r | |
1156 | my $stamptime = $stamptime{$msg};\r | |
1157 | if ((defined $stamptime)\r | |
1158 | and (($time - $stamptime) < $Max_Checkin_Duration)\r | |
1159 | and (defined $changelog{$stamptime}{$author}{$msg}))\r | |
1160 | {\r | |
1161 | push(@{$changelog{$stamptime}{$author}{$msg}}, $qunklist->files);\r | |
1162 | }\r | |
1163 | else {\r | |
1164 | $changelog{$time}{$author}{$msg} = $qunklist->files;\r | |
1165 | $stamptime{$msg} = $time;\r | |
1166 | }\r | |
1167 | }\r | |
1168 | }\r | |
1169 | }\r | |
1170 | undef (%$authorhash);\r | |
1171 | \r | |
1172 | ### Now we can write out the ChangeLog!\r | |
1173 | \r | |
1174 | my ($logfile_here, $logfile_bak, $tmpfile);\r | |
1175 | my $lastdate;\r | |
1176 | \r | |
1177 | if (! $Output_To_Stdout) {\r | |
1178 | $logfile_here = $dir . $Log_File_Name;\r | |
1179 | $logfile_here =~ s/^\.\/\//\//; # fix any leading ".//" problem\r | |
1180 | $tmpfile = "${logfile_here}.cvs2cl$$.tmp";\r | |
1181 | $logfile_bak = "${logfile_here}.bak";\r | |
1182 | \r | |
1183 | open (LOG_OUT, ">$tmpfile") or die "Unable to open \"$tmpfile\"";\r | |
1184 | }\r | |
1185 | else {\r | |
1186 | open (LOG_OUT, ">-") or die "Unable to open stdout for writing";\r | |
1187 | }\r | |
1188 | \r | |
1189 | print LOG_OUT $ChangeLog_Header;\r | |
1190 | \r | |
1191 | my %tag_date_printed;\r | |
1192 | \r | |
1193 | $self->output_header(\*LOG_OUT);\r | |
1194 | \r | |
1195 | my @key_list = ();\r | |
1196 | if($Chronological_Order) {\r | |
1197 | @key_list = sort {$a <=> $b} (keys %changelog);\r | |
1198 | } else {\r | |
1199 | @key_list = sort {$b <=> $a} (keys %changelog);\r | |
1200 | }\r | |
1201 | foreach my $time (@key_list)\r | |
1202 | {\r | |
1203 | next if ($Delta_Mode &&\r | |
1204 | (($time <= $Delta_StartTime) ||\r | |
1205 | ($time > $Delta_EndTime && $Delta_EndTime)));\r | |
1206 | \r | |
1207 | # Set up the date/author line.\r | |
1208 | # kff todo: do some more XML munging here, on the header\r | |
1209 | # part of the entry:\r | |
1210 | my (undef,$min,$hour,$mday,$mon,$year,$wday)\r | |
1211 | = $UTC_Times ? gmtime($time) : localtime($time);\r | |
1212 | \r | |
1213 | $wday = $self->wday($wday);\r | |
1214 | # XML output includes everything else, we might as well make\r | |
1215 | # it always include Day Of Week too, for consistency.\r | |
1216 | my $authorhash = $changelog{$time};\r | |
1217 | if ($Show_Tag_Dates) {\r | |
1218 | my %tags;\r | |
1219 | while (my ($author,$mesghash) = each %$authorhash) {\r | |
1220 | while (my ($msg,$qunk) = each %$mesghash) {\r | |
1221 | foreach my $qunkref2 (@$qunk) {\r | |
1222 | if (defined ($qunkref2->tags)) {\r | |
1223 | foreach my $tag (@{$qunkref2->tags}) {\r | |
1224 | $tags{$tag} = 1;\r | |
1225 | }\r | |
1226 | }\r | |
1227 | }\r | |
1228 | }\r | |
1229 | }\r | |
1230 | # Sort here for determinism to ease testing\r | |
1231 | foreach my $tag (sort keys %tags) {\r | |
1232 | if ( ! defined $tag_date_printed{$tag} ) {\r | |
1233 | $tag_date_printed{$tag} = $time;\r | |
1234 | $self->output_tagdate(\*LOG_OUT, $time, $tag);\r | |
1235 | }\r | |
1236 | }\r | |
1237 | }\r | |
1238 | while (my ($author,$mesghash) = each %$authorhash)\r | |
1239 | {\r | |
1240 | # If XML, escape in outer loop to avoid compound quoting:\r | |
1241 | $author = $self->escape($author);\r | |
1242 | \r | |
1243 | FOOBIE:\r | |
1244 | # We sort here to enable predictable ordering for the testing porpoises\r | |
1245 | for my $msg (sort keys %$mesghash)\r | |
1246 | {\r | |
1247 | my $qunklist = $mesghash->{$msg};\r | |
1248 | \r | |
1249 | my @qunklist =\r | |
1250 | grep $self->_revision_is_wanted($_), @$qunklist;\r | |
1251 | \r | |
1252 | next FOOBIE unless @qunklist;\r | |
1253 | \r | |
1254 | my $files = $self->pretty_file_list(\@qunklist);\r | |
1255 | my $header_line; # date and author\r | |
1256 | my $wholething; # $header_line + $body\r | |
1257 | \r | |
1258 | my $date = $self->fdatetime($time);\r | |
1259 | $header_line = $self->header_line($time, $author, $lastdate);\r | |
1260 | $lastdate = $date;\r | |
1261 | \r | |
1262 | $Text::Wrap::huge = 'overflow'\r | |
1263 | if $Text::Wrap::VERSION >= 2001.0130;\r | |
1264 | # Reshape the body according to user preferences.\r | |
1265 | my $body = $self->format_body($msg, $files, \@qunklist);\r | |
1266 | \r | |
1267 | $body =~ s/[ \t]+\n/\n/g;\r | |
1268 | $wholething = $header_line . $body;\r | |
1269 | \r | |
1270 | # One last check: make sure it passes the regexp test, if the\r | |
1271 | # user asked for that. We have to do it here, so that the\r | |
1272 | # test can match against information in the header as well\r | |
1273 | # as in the text of the log message.\r | |
1274 | \r | |
1275 | # How annoying to duplicate so much code just because I\r | |
1276 | # can't figure out a way to evaluate scalars on the trailing\r | |
1277 | # operator portion of a regular expression. Grrr.\r | |
1278 | if ($Case_Insensitive) {\r | |
1279 | unless ( $Regexp_Gate and ( $wholething !~ /$Regexp_Gate/oi ) ) {\r | |
1280 | $self->output_entry(\*LOG_OUT, $wholething);\r | |
1281 | }\r | |
1282 | }\r | |
1283 | else {\r | |
1284 | unless ( $Regexp_Gate and ( $wholething !~ /$Regexp_Gate/o ) ) {\r | |
1285 | $self->output_entry(\*LOG_OUT, $wholething);\r | |
1286 | }\r | |
1287 | }\r | |
1288 | }\r | |
1289 | }\r | |
1290 | }\r | |
1291 | \r | |
1292 | $self->output_footer(\*LOG_OUT);\r | |
1293 | \r | |
1294 | close (LOG_OUT);\r | |
1295 | \r | |
1296 | if ( ! $Output_To_Stdout ) {\r | |
1297 | # If accumulating, append old data to new before renaming. But\r | |
1298 | # don't append the most recent entry, since it's already in the\r | |
1299 | # new log due to CVS's idiosyncratic interpretation of "log -d".\r | |
1300 | if ($Cumulative && -f $logfile_here) {\r | |
1301 | open NEW_LOG, ">>$tmpfile"\r | |
1302 | or die "trouble appending to $tmpfile ($!)";\r | |
1303 | \r | |
1304 | open OLD_LOG, "<$logfile_here"\r | |
1305 | or die "trouble reading from $logfile_here ($!)";\r | |
1306 | \r | |
1307 | my $started_first_entry = 0;\r | |
1308 | my $passed_first_entry = 0;\r | |
1309 | while (<OLD_LOG>) {\r | |
1310 | if ( ! $passed_first_entry ) {\r | |
1311 | if ( ( ! $started_first_entry )\r | |
1312 | and /^(\d\d\d\d-\d\d-\d\d\s+\d\d:\d\d)/ ) {\r | |
1313 | $started_first_entry = 1;\r | |
1314 | } elsif ( /^(\d\d\d\d-\d\d-\d\d\s+\d\d:\d\d)/ ) {\r | |
1315 | $passed_first_entry = 1;\r | |
1316 | print NEW_LOG $_;\r | |
1317 | }\r | |
1318 | } else {\r | |
1319 | print NEW_LOG $_;\r | |
1320 | }\r | |
1321 | }\r | |
1322 | \r | |
1323 | close NEW_LOG;\r | |
1324 | close OLD_LOG;\r | |
1325 | }\r | |
1326 | \r | |
1327 | if ( -f $logfile_here ) {\r | |
1328 | rename $logfile_here, $logfile_bak;\r | |
1329 | }\r | |
1330 | rename $tmpfile, $logfile_here;\r | |
1331 | }\r | |
1332 | }\r | |
1333 | }\r | |
1334 | \r | |
1335 | # -------------------------------------\r | |
1336 | \r | |
1337 | # Don't call this wrap, because with 5.5.3, that clashes with the\r | |
1338 | # (unconditional :-( ) export of wrap() from Text::Wrap\r | |
1339 | sub mywrap {\r | |
1340 | my $self = shift;\r | |
1341 | my ($indent1, $indent2, @text) = @_;\r | |
1342 | # If incoming text looks preformatted, don't get clever\r | |
1343 | my $text = Text::Wrap::wrap($indent1, $indent2, @text);\r | |
1344 | if ( grep /^\s+/m, @text ) {\r | |
1345 | return $text;\r | |
1346 | }\r | |
1347 | my @lines = split /\n/, $text;\r | |
1348 | $indent2 =~ s!^((?: {8})+)!"\t" x (length($1)/8)!e;\r | |
1349 | $lines[0] =~ s/^$indent1\s+/$indent1/;\r | |
1350 | s/^$indent2\s+/$indent2/\r | |
1351 | for @lines[1..$#lines];\r | |
1352 | my $newtext = join "\n", @lines;\r | |
1353 | $newtext .= "\n"\r | |
1354 | if substr($text, -1) eq "\n";\r | |
1355 | return $newtext;\r | |
1356 | }\r | |
1357 | \r | |
1358 | # -------------------------------------\r | |
1359 | \r | |
1360 | sub preprocess_msg_text {\r | |
1361 | my $self = shift;\r | |
1362 | my ($text) = @_;\r | |
1363 | \r | |
1364 | # Strip out carriage returns (as they probably result from DOSsy editors).\r | |
1365 | $text =~ s/\r\n/\n/g;\r | |
1366 | # If it *looks* like two newlines, make it *be* two newlines:\r | |
1367 | $text =~ s/\n\s*\n/\n\n/g;\r | |
1368 | \r | |
1369 | return $text;\r | |
1370 | }\r | |
1371 | \r | |
1372 | # -------------------------------------\r | |
1373 | \r | |
1374 | sub last_line_len {\r | |
1375 | my $self = shift;\r | |
1376 | \r | |
1377 | my $files_list = shift;\r | |
1378 | my @lines = split (/\n/, $files_list);\r | |
1379 | my $last_line = pop (@lines);\r | |
1380 | return length ($last_line);\r | |
1381 | }\r | |
1382 | \r | |
1383 | # -------------------------------------\r | |
1384 | \r | |
1385 | # A custom wrap function, sensitive to some common constructs used in\r | |
1386 | # log entries.\r | |
1387 | sub wrap_log_entry {\r | |
1388 | my $self = shift;\r | |
1389 | \r | |
1390 | my $text = shift; # The text to wrap.\r | |
1391 | my $left_pad_str = shift; # String to pad with on the left.\r | |
1392 | \r | |
1393 | # These do NOT take left_pad_str into account:\r | |
1394 | my $length_remaining = shift; # Amount left on current line.\r | |
1395 | my $max_line_length = shift; # Amount left for a blank line.\r | |
1396 | \r | |
1397 | my $wrapped_text = ''; # The accumulating wrapped entry.\r | |
1398 | my $user_indent = ''; # Inherited user_indent from prev line.\r | |
1399 | \r | |
1400 | my $first_time = 1; # First iteration of the loop?\r | |
1401 | my $suppress_line_start_match = 0; # Set to disable line start checks.\r | |
1402 | \r | |
1403 | my @lines = split (/\n/, $text);\r | |
1404 | while (@lines) # Don't use `foreach' here, it won't work.\r | |
1405 | {\r | |
1406 | my $this_line = shift (@lines);\r | |
1407 | chomp $this_line;\r | |
1408 | \r | |
1409 | if ($this_line =~ /^(\s+)/) {\r | |
1410 | $user_indent = $1;\r | |
1411 | }\r | |
1412 | else {\r | |
1413 | $user_indent = '';\r | |
1414 | }\r | |
1415 | \r | |
1416 | # If it matches any of the line-start regexps, print a newline now...\r | |
1417 | if ($suppress_line_start_match)\r | |
1418 | {\r | |
1419 | $suppress_line_start_match = 0;\r | |
1420 | }\r | |
1421 | elsif (($this_line =~ /^(\s*)\*\s+[a-zA-Z0-9]/)\r | |
1422 | || ($this_line =~ /^(\s*)\* [a-zA-Z0-9_\.\/\+-]+/)\r | |
1423 | || ($this_line =~ /^(\s*)\([a-zA-Z0-9_\.\/\+-]+(\)|,\s*)/)\r | |
1424 | || ($this_line =~ /^(\s+)(\S+)/)\r | |
1425 | || ($this_line =~ /^(\s*)- +/)\r | |
1426 | || ($this_line =~ /^()\s*$/)\r | |
1427 | || ($this_line =~ /^(\s*)\*\) +/)\r | |
1428 | || ($this_line =~ /^(\s*)[a-zA-Z0-9](\)|\.|\:) +/))\r | |
1429 | {\r | |
1430 | # Make a line break immediately, unless header separator is set\r | |
1431 | # and this line is the first line in the entry, in which case\r | |
1432 | # we're getting the blank line for free already and shouldn't\r | |
1433 | # add an extra one.\r | |
1434 | unless (($After_Header ne " ") and ($first_time))\r | |
1435 | {\r | |
1436 | if ($this_line =~ /^()\s*$/) {\r | |
1437 | $suppress_line_start_match = 1;\r | |
1438 | $wrapped_text .= "\n${left_pad_str}";\r | |
1439 | }\r | |
1440 | \r | |
1441 | $wrapped_text .= "\n${left_pad_str}";\r | |
1442 | }\r | |
1443 | \r | |
1444 | $length_remaining = $max_line_length - (length ($user_indent));\r | |
1445 | }\r | |
1446 | \r | |
1447 | # Now that any user_indent has been preserved, strip off leading\r | |
1448 | # whitespace, so up-folding has no ugly side-effects.\r | |
1449 | $this_line =~ s/^\s*//;\r | |
1450 | \r | |
1451 | # Accumulate the line, and adjust parameters for next line.\r | |
1452 | my $this_len = length ($this_line);\r | |
1453 | if ($this_len == 0)\r | |
1454 | {\r | |
1455 | # Blank lines should cancel any user_indent level.\r | |
1456 | $user_indent = '';\r | |
1457 | $length_remaining = $max_line_length;\r | |
1458 | }\r | |
1459 | elsif ($this_len >= $length_remaining) # Line too long, try breaking it.\r | |
1460 | {\r | |
1461 | # Walk backwards from the end. At first acceptable spot, break\r | |
1462 | # a new line.\r | |
1463 | my $idx = $length_remaining - 1;\r | |
1464 | if ($idx < 0) { $idx = 0 };\r | |
1465 | while ($idx > 0)\r | |
1466 | {\r | |
1467 | if (substr ($this_line, $idx, 1) =~ /\s/)\r | |
1468 | {\r | |
1469 | my $line_now = substr ($this_line, 0, $idx);\r | |
1470 | my $next_line = substr ($this_line, $idx);\r | |
1471 | $this_line = $line_now;\r | |
1472 | \r | |
1473 | # Clean whitespace off the end.\r | |
1474 | chomp $this_line;\r | |
1475 | \r | |
1476 | # The current line is ready to be printed.\r | |
1477 | $this_line .= "\n${left_pad_str}";\r | |
1478 | \r | |
1479 | # Make sure the next line is allowed full room.\r | |
1480 | $length_remaining = $max_line_length - (length ($user_indent));\r | |
1481 | \r | |
1482 | # Strip next_line, but then preserve any user_indent.\r | |
1483 | $next_line =~ s/^\s*//;\r | |
1484 | \r | |
1485 | # Sneak a peek at the user_indent of the upcoming line, so\r | |
1486 | # $next_line (which will now precede it) can inherit that\r | |
1487 | # indent level. Otherwise, use whatever user_indent level\r | |
1488 | # we currently have, which might be none.\r | |
1489 | my $next_next_line = shift (@lines);\r | |
1490 | if ((defined ($next_next_line)) && ($next_next_line =~ /^(\s+)/)) {\r | |
1491 | $next_line = $1 . $next_line if (defined ($1));\r | |
1492 | # $length_remaining = $max_line_length - (length ($1));\r | |
1493 | $next_next_line =~ s/^\s*//;\r | |
1494 | }\r | |
1495 | else {\r | |
1496 | $next_line = $user_indent . $next_line;\r | |
1497 | }\r | |
1498 | if (defined ($next_next_line)) {\r | |
1499 | unshift (@lines, $next_next_line);\r | |
1500 | }\r | |
1501 | unshift (@lines, $next_line);\r | |
1502 | \r | |
1503 | # Our new next line might, coincidentally, begin with one of\r | |
1504 | # the line-start regexps, so we temporarily turn off\r | |
1505 | # sensitivity to that until we're past the line.\r | |
1506 | $suppress_line_start_match = 1;\r | |
1507 | \r | |
1508 | last;\r | |
1509 | }\r | |
1510 | else\r | |
1511 | {\r | |
1512 | $idx--;\r | |
1513 | }\r | |
1514 | }\r | |
1515 | \r | |
1516 | if ($idx == 0)\r | |
1517 | {\r | |
1518 | # We bottomed out because the line is longer than the\r | |
1519 | # available space. But that could be because the space is\r | |
1520 | # small, or because the line is longer than even the maximum\r | |
1521 | # possible space. Handle both cases below.\r | |
1522 | \r | |
1523 | if ($length_remaining == ($max_line_length - (length ($user_indent))))\r | |
1524 | {\r | |
1525 | # The line is simply too long -- there is no hope of ever\r | |
1526 | # breaking it nicely, so just insert it verbatim, with\r | |
1527 | # appropriate padding.\r | |
1528 | $this_line = "\n${left_pad_str}${this_line}";\r | |
1529 | }\r | |
1530 | else\r | |
1531 | {\r | |
1532 | # Can't break it here, but may be able to on the next round...\r | |
1533 | unshift (@lines, $this_line);\r | |
1534 | $length_remaining = $max_line_length - (length ($user_indent));\r | |
1535 | $this_line = "\n${left_pad_str}";\r | |
1536 | }\r | |
1537 | }\r | |
1538 | }\r | |
1539 | else # $this_len < $length_remaining, so tack on what we can.\r | |
1540 | {\r | |
1541 | # Leave a note for the next iteration.\r | |
1542 | $length_remaining = $length_remaining - $this_len;\r | |
1543 | \r | |
1544 | if ($this_line =~ /\.$/)\r | |
1545 | {\r | |
1546 | $this_line .= " ";\r | |
1547 | $length_remaining -= 2;\r | |
1548 | }\r | |
1549 | else # not a sentence end\r | |
1550 | {\r | |
1551 | $this_line .= " ";\r | |
1552 | $length_remaining -= 1;\r | |
1553 | }\r | |
1554 | }\r | |
1555 | \r | |
1556 | # Unconditionally indicate that loop has run at least once.\r | |
1557 | $first_time = 0;\r | |
1558 | \r | |
1559 | $wrapped_text .= "${user_indent}${this_line}";\r | |
1560 | }\r | |
1561 | \r | |
1562 | # One last bit of padding.\r | |
1563 | $wrapped_text .= "\n";\r | |
1564 | \r | |
1565 | return $wrapped_text;\r | |
1566 | }\r | |
1567 | \r | |
1568 | # -------------------------------------\r | |
1569 | \r | |
1570 | sub _pretty_file_list {\r | |
1571 | my $self = shift;\r | |
1572 | \r | |
1573 | my ($unanimous_tags, $non_unanimous_tags, $all_branches, $qunksref) = @_;\r | |
1574 | \r | |
1575 | my @qunkrefs =\r | |
1576 | grep +( ( ! $_->tags_exists\r | |
1577 | or\r | |
1578 | ! grep exists $ignore_tags{$_}, @{$_->tags})\r | |
1579 | and\r | |
1580 | ( ! keys %show_tags\r | |
1581 | or\r | |
1582 | ( $_->tags_exists\r | |
1583 | and\r | |
1584 | grep exists $show_tags{$_}, @{$_->tags} )\r | |
1585 | )\r | |
1586 | ),\r | |
1587 | @$qunksref;\r | |
1588 | \r | |
1589 | my $common_dir; # Dir prefix common to all files ('' if none)\r | |
1590 | \r | |
1591 | # First, loop over the qunks gathering all the tag/branch names.\r | |
1592 | # We'll put them all in non_unanimous_tags, and take out the\r | |
1593 | # unanimous ones later.\r | |
1594 | QUNKREF:\r | |
1595 | foreach my $qunkref (@qunkrefs)\r | |
1596 | {\r | |
1597 | # Keep track of whether all the files in this commit were in the\r | |
1598 | # same directory, and memorize it if so. We can make the output a\r | |
1599 | # little more compact by mentioning the directory only once.\r | |
1600 | if ($Common_Dir && (scalar (@qunkrefs)) > 1)\r | |
1601 | {\r | |
1602 | if (! (defined ($common_dir)))\r | |
1603 | {\r | |
1604 | my ($base, $dir);\r | |
1605 | ($base, $dir, undef) = fileparse ($qunkref->filename);\r | |
1606 | \r | |
1607 | if ((! (defined ($dir))) # this first case is sheer paranoia\r | |
1608 | or ($dir eq '')\r | |
1609 | or ($dir eq "./")\r | |
1610 | or ($dir eq ".\\"))\r | |
1611 | {\r | |
1612 | $common_dir = '';\r | |
1613 | }\r | |
1614 | else\r | |
1615 | {\r | |
1616 | $common_dir = $dir;\r | |
1617 | }\r | |
1618 | }\r | |
1619 | elsif ($common_dir ne '')\r | |
1620 | {\r | |
1621 | # Already have a common dir prefix, so how much of it can we preserve?\r | |
1622 | $common_dir = &main::common_path_prefix ($qunkref->filename, $common_dir);\r | |
1623 | }\r | |
1624 | }\r | |
1625 | else # only one file in this entry anyway, so common dir not an issue\r | |
1626 | {\r | |
1627 | $common_dir = '';\r | |
1628 | }\r | |
1629 | \r | |
1630 | if (defined ($qunkref->branch)) {\r | |
1631 | $all_branches->{$qunkref->branch} = 1;\r | |
1632 | }\r | |
1633 | if (defined ($qunkref->tags)) {\r | |
1634 | foreach my $tag (@{$qunkref->tags}) {\r | |
1635 | $non_unanimous_tags->{$tag} = 1;\r | |
1636 | }\r | |
1637 | }\r | |
1638 | }\r | |
1639 | \r | |
1640 | # Any tag held by all qunks will be printed specially... but only if\r | |
1641 | # there are multiple qunks in the first place!\r | |
1642 | if ((scalar (@qunkrefs)) > 1) {\r | |
1643 | foreach my $tag (keys (%$non_unanimous_tags)) {\r | |
1644 | my $everyone_has_this_tag = 1;\r | |
1645 | foreach my $qunkref (@qunkrefs) {\r | |
1646 | if ((! (defined ($qunkref->tags)))\r | |
1647 | or (! (grep ($_ eq $tag, @{$qunkref->tags})))) {\r | |
1648 | $everyone_has_this_tag = 0;\r | |
1649 | }\r | |
1650 | }\r | |
1651 | if ($everyone_has_this_tag) {\r | |
1652 | $unanimous_tags->{$tag} = 1;\r | |
1653 | delete $non_unanimous_tags->{$tag};\r | |
1654 | }\r | |
1655 | }\r | |
1656 | }\r | |
1657 | \r | |
1658 | return $common_dir, \@qunkrefs;\r | |
1659 | }\r | |
1660 | \r | |
1661 | # -------------------------------------\r | |
1662 | \r | |
1663 | sub fdatetime {\r | |
1664 | my $self = shift;\r | |
1665 | \r | |
1666 | my ($year, $mday, $mon, $wday, $hour, $min);\r | |
1667 | \r | |
1668 | if ( @_ > 1 ) {\r | |
1669 | ($year, $mday, $mon, $wday, $hour, $min) = @_;\r | |
1670 | } else {\r | |
1671 | my ($time) = @_;\r | |
1672 | (undef, $min, $hour, $mday, $mon, $year, $wday) =\r | |
1673 | $UTC_Times ? gmtime($time) : localtime($time);\r | |
1674 | \r | |
1675 | $year += 1900;\r | |
1676 | $mon += 1;\r | |
1677 | $wday = $self->wday($wday);\r | |
1678 | }\r | |
1679 | \r | |
1680 | my $fdate = $self->fdate($year, $mon, $mday, $wday);\r | |
1681 | \r | |
1682 | if ($Show_Times) {\r | |
1683 | my $ftime = $self->ftime($hour, $min);\r | |
1684 | return "$fdate $ftime";\r | |
1685 | } else {\r | |
1686 | return $fdate;\r | |
1687 | }\r | |
1688 | }\r | |
1689 | \r | |
1690 | # -------------------------------------\r | |
1691 | \r | |
1692 | sub fdate {\r | |
1693 | my $self = shift;\r | |
1694 | \r | |
1695 | my ($year, $mday, $mon, $wday);\r | |
1696 | \r | |
1697 | if ( @_ > 1 ) {\r | |
1698 | ($year, $mon, $mday, $wday) = @_;\r | |
1699 | } else {\r | |
1700 | my ($time) = @_;\r | |
1701 | (undef, undef, undef, $mday, $mon, $year, $wday) =\r | |
1702 | $UTC_Times ? gmtime($time) : localtime($time);\r | |
1703 | \r | |
1704 | $year += 1900;\r | |
1705 | $mon += 1;\r | |
1706 | $wday = $self->wday($wday);\r | |
1707 | }\r | |
1708 | \r | |
1709 | return sprintf '%4u-%02u-%02u%s', $year, $mon, $mday, $wday;\r | |
1710 | }\r | |
1711 | \r | |
1712 | # -------------------------------------\r | |
1713 | \r | |
1714 | sub ftime {\r | |
1715 | my $self = shift;\r | |
1716 | \r | |
1717 | my ($hour, $min);\r | |
1718 | \r | |
1719 | if ( @_ > 1 ) {\r | |
1720 | ($hour, $min) = @_;\r | |
1721 | } else {\r | |
1722 | my ($time) = @_;\r | |
1723 | (undef, $min, $hour) = $UTC_Times ? gmtime($time) : localtime($time);\r | |
1724 | }\r | |
1725 | \r | |
1726 | return sprintf '%02u:%02u', $hour, $min;\r | |
1727 | }\r | |
1728 | \r | |
1729 | # ----------------------------------------------------------------------------\r | |
1730 | \r | |
1731 | package CVS::Utils::ChangeLog::Message;\r | |
1732 | \r | |
1733 | sub new {\r | |
1734 | my $class = shift;\r | |
1735 | my ($msg) = @_;\r | |
1736 | \r | |
1737 | my %self = (msg => $msg, files => []);\r | |
1738 | \r | |
1739 | bless \%self, $class;\r | |
1740 | }\r | |
1741 | \r | |
1742 | sub add_fileentry {\r | |
1743 | my $self = shift;\r | |
1744 | my ($fileentry) = @_;\r | |
1745 | \r | |
1746 | die "Not a fileentry: $fileentry"\r | |
1747 | unless $fileentry->isa('CVS::Utils::ChangeLog::FileEntry');\r | |
1748 | \r | |
1749 | push @{$self->{files}}, $fileentry;\r | |
1750 | }\r | |
1751 | \r | |
1752 | sub files { wantarray ? @{$_[0]->{files}} : $_[0]->{files} }\r | |
1753 | \r | |
1754 | # ----------------------------------------------------------------------------\r | |
1755 | \r | |
1756 | package CVS::Utils::ChangeLog::FileEntry;\r | |
1757 | \r | |
1758 | use File::Basename qw( fileparse );\r | |
1759 | \r | |
1760 | # Each revision of a file has a little data structure (a `qunk')\r | |
1761 | # associated with it. That data structure holds not only the\r | |
1762 | # file's name, but any additional information about the file\r | |
1763 | # that might be needed in the output, such as the revision\r | |
1764 | # number, tags, branches, etc. The reason to have these things\r | |
1765 | # arranged in a data structure, instead of just appending them\r | |
1766 | # textually to the file's name, is that we may want to do a\r | |
1767 | # little rearranging later as we write the output. For example,\r | |
1768 | # all the files on a given tag/branch will go together, followed\r | |
1769 | # by the tag in parentheses (so trunk or otherwise non-tagged\r | |
1770 | # files would go at the end of the file list for a given log\r | |
1771 | # message). This rearrangement is a lot easier to do if we\r | |
1772 | # don't have to reparse the text.\r | |
1773 | #\r | |
1774 | # A qunk looks like this:\r | |
1775 | #\r | |
1776 | # {\r | |
1777 | # filename => "hello.c",\r | |
1778 | # revision => "1.4.3.2",\r | |
1779 | # time => a timegm() return value (moment of commit)\r | |
1780 | # tags => [ "tag1", "tag2", ... ],\r | |
1781 | # branch => "branchname" # There should be only one, right?\r | |
1782 | # roots => [ "branchtag1", "branchtag2", ... ]\r | |
1783 | # lines => "+x -y" # or undefined; x and y are integers\r | |
1784 | # }\r | |
1785 | \r | |
1786 | # Single top-level ChangeLog, or one per subdirectory?\r | |
1787 | my $distributed;\r | |
1788 | sub distributed { $#_ ? ($distributed = $_[1]) : $distributed; }\r | |
1789 | \r | |
1790 | sub new {\r | |
1791 | my $class = shift;\r | |
1792 | my ($path, $time, $revision, $state, $lines,\r | |
1793 | $branch_names, $branch_roots, $branch_numbers, $symbolic_names) = @_;\r | |
1794 | \r | |
1795 | my %self = (time => $time,\r | |
1796 | revision => $revision,\r | |
1797 | state => $state,\r | |
1798 | lines => $lines,\r | |
1799 | branch_numbers => $branch_numbers,\r | |
1800 | );\r | |
1801 | \r | |
1802 | if ( $distributed ) {\r | |
1803 | @self{qw(filename dir_key)} = fileparse($path);\r | |
1804 | } else {\r | |
1805 | @self{qw(filename dir_key)} = ($path, './');\r | |
1806 | }\r | |
1807 | \r | |
1808 | { # Scope for $branch_prefix\r | |
1809 | (my ($branch_prefix) = ($revision =~ /((?:\d+\.)+)\d+/));\r | |
1810 | $branch_prefix =~ s/\.$//;\r | |
1811 | if ( $branch_names->{$branch_prefix} ) {\r | |
1812 | my $branch_name = $branch_names->{$branch_prefix};\r | |
1813 | $self{branch} = $branch_name;\r | |
1814 | $self{branches} = [$branch_name];\r | |
1815 | }\r | |
1816 | while ( $branch_prefix =~ s/^(\d+(?:\.\d+\.\d+)+)\.\d+\.\d+$/$1/ ) {\r | |
1817 | push @{$self{branches}}, $branch_names->{$branch_prefix}\r | |
1818 | if exists $branch_names->{$branch_prefix};\r | |
1819 | }\r | |
1820 | }\r | |
1821 | \r | |
1822 | # If there's anything in the @branch_roots array, then this\r | |
1823 | # revision is the root of at least one branch. We'll display\r | |
1824 | # them as branch names instead of revision numbers, the\r | |
1825 | # substitution for which is done directly in the array:\r | |
1826 | $self{'roots'} = [ map { $branch_names->{$_} } @$branch_roots ]\r | |
1827 | if @$branch_roots;\r | |
1828 | \r | |
1829 | if ( exists $symbolic_names->{$revision} ) {\r | |
1830 | $self{tags} = delete $symbolic_names->{$revision};\r | |
1831 | &main::delta_check($time, $self{tags});\r | |
1832 | }\r | |
1833 | \r | |
1834 | bless \%self, $class;\r | |
1835 | }\r | |
1836 | \r | |
1837 | sub filename { $_[0]->{filename} }\r | |
1838 | sub dir_key { $_[0]->{dir_key} }\r | |
1839 | sub revision { $_[0]->{revision} }\r | |
1840 | sub branch { $_[0]->{branch} }\r | |
1841 | sub state { $_[0]->{state} }\r | |
1842 | sub lines { $_[0]->{lines} }\r | |
1843 | sub roots { $_[0]->{roots} }\r | |
1844 | sub branch_numbers { $_[0]->{branch_numbers} }\r | |
1845 | \r | |
1846 | sub tags { $_[0]->{tags} }\r | |
1847 | sub tags_exists {\r | |
1848 | exists $_[0]->{tags};\r | |
1849 | }\r | |
1850 | \r | |
1851 | # This may someday be used in a more sophisticated calculation of what other\r | |
1852 | # files are involved in this commit. For now, we don't use it much except for\r | |
1853 | # delta mode, because the common-commit-detection algorithm is hypothesized to\r | |
1854 | # be "good enough" as it stands.\r | |
1855 | sub time { $_[0]->{time} }\r | |
1856 | \r | |
1857 | # ----------------------------------------------------------------------------\r | |
1858 | \r | |
1859 | package CVS::Utils::ChangeLog::EntrySetBuilder;\r | |
1860 | \r | |
1861 | use File::Basename qw( fileparse );\r | |
1862 | use Time::Local qw( timegm );\r | |
1863 | \r | |
1864 | use constant MAILNAME => "/etc/mailname";\r | |
1865 | \r | |
1866 | # In 'cvs log' output, one long unbroken line of equal signs separates files:\r | |
1867 | use constant FILE_SEPARATOR => '=' x 77;# . "\n";\r | |
1868 | # In 'cvs log' output, a shorter line of dashes separates log messages within\r | |
1869 | # a file:\r | |
1870 | use constant REV_SEPARATOR => '-' x 28;# . "\n";\r | |
1871 | \r | |
1872 | use constant EMPTY_LOG_MESSAGE => '*** empty log message ***';\r | |
1873 | \r | |
1874 | # -------------------------------------\r | |
1875 | \r | |
1876 | sub new {\r | |
1877 | my ($proto) = @_;\r | |
1878 | my $class = ref $proto || $proto;\r | |
1879 | \r | |
1880 | my $poobah = CVS::Utils::ChangeLog::EntrySet->new;\r | |
1881 | my $self = bless +{ grand_poobah => $poobah }, $class;\r | |
1882 | \r | |
1883 | $self->clear_file;\r | |
1884 | $self->maybe_read_user_map_file;\r | |
1885 | return $self;\r | |
1886 | }\r | |
1887 | \r | |
1888 | # -------------------------------------\r | |
1889 | \r | |
1890 | sub clear_msg {\r | |
1891 | my ($self) = @_;\r | |
1892 | \r | |
1893 | # Make way for the next message\r | |
1894 | undef $self->{rev_msg};\r | |
1895 | undef $self->{rev_time};\r | |
1896 | undef $self->{rev_revision};\r | |
1897 | undef $self->{rev_author};\r | |
1898 | undef $self->{rev_state};\r | |
1899 | undef $self->{lines};\r | |
1900 | $self->{rev_branch_roots} = []; # For showing which files are branch\r | |
1901 | # ancestors.\r | |
1902 | $self->{collecting_symbolic_names} = 0;\r | |
1903 | }\r | |
1904 | \r | |
1905 | # -------------------------------------\r | |
1906 | \r | |
1907 | sub clear_file {\r | |
1908 | my ($self) = @_;\r | |
1909 | $self->clear_msg;\r | |
1910 | \r | |
1911 | undef $self->{filename};\r | |
1912 | $self->{branch_names} = +{}; # We'll grab branch names while we're\r | |
1913 | # at it.\r | |
1914 | $self->{branch_numbers} = +{}; # Save some revisions for\r | |
1915 | # @Follow_Branches\r | |
1916 | $self->{symbolic_names} = +{}; # Where tag names get stored.\r | |
1917 | }\r | |
1918 | \r | |
1919 | # -------------------------------------\r | |
1920 | \r | |
1921 | sub grand_poobah { $_[0]->{grand_poobah} }\r | |
1922 | \r | |
1923 | # -------------------------------------\r | |
1924 | \r | |
1925 | sub read_changelog {\r | |
1926 | my ($self, $command) = @_;\r | |
1927 | \r | |
1928 | # my $grand_poobah = CVS::Utils::ChangeLog::EntrySet->new;\r | |
1929 | \r | |
1930 | if (! $Input_From_Stdin) {\r | |
1931 | my $Log_Source_Command = join(' ', @$command);\r | |
1932 | &main::debug ("(run \"${Log_Source_Command}\")\n");\r | |
1933 | open (LOG_SOURCE, "$Log_Source_Command |")\r | |
1934 | or die "unable to run \"${Log_Source_Command}\"";\r | |
1935 | }\r | |
1936 | else {\r | |
1937 | open (LOG_SOURCE, "-") or die "unable to open stdin for reading";\r | |
1938 | }\r | |
1939 | \r | |
1940 | binmode LOG_SOURCE;\r | |
1941 | \r | |
1942 | XX_Log_Source:\r | |
1943 | while (<LOG_SOURCE>) {\r | |
1944 | chomp;\r | |
1945 | s!\r$!!;\r | |
1946 | \r | |
1947 | # If on a new file and don't see filename, skip until we find it, and\r | |
1948 | # when we find it, grab it.\r | |
1949 | if ( ! defined $self->{filename} ) {\r | |
1950 | $self->read_file_path($_);\r | |
1951 | } elsif ( /^symbolic names:$/ ) {\r | |
1952 | $self->{collecting_symbolic_names} = 1;\r | |
1953 | } elsif ( $self->{collecting_symbolic_names} ) {\r | |
1954 | $self->read_symbolic_name($_);\r | |
1955 | } elsif ( $_ eq FILE_SEPARATOR and ! defined $self->{rev_revision} ) {\r | |
1956 | $self->clear_file;\r | |
1957 | } elsif ( ! defined $self->{rev_revision} ) {\r | |
1958 | # If have file name, but not revision, and see revision, then grab\r | |
1959 | # it. (We collect unconditionally, even though we may or may not\r | |
1960 | # ever use it.)\r | |
1961 | $self->read_revision($_);\r | |
1962 | } elsif ( ! defined $self->{rev_time} ) { # and /^date: /) {\r | |
1963 | $self->read_date_author_and_state($_);\r | |
1964 | } elsif ( /^branches:\s+(.*);$/ ) {\r | |
1965 | $self->read_branches($1);\r | |
1966 | } elsif ( ! ( $_ eq FILE_SEPARATOR or $_ eq REV_SEPARATOR ) ) {\r | |
1967 | # If have file name, time, and author, then we're just grabbing\r | |
1968 | # log message texts:\r | |
1969 | $self->{rev_msg} .= $_ . "\n"; # Normally, just accumulate the message...\r | |
1970 | } else {\r | |
1971 | if ( ! $self->{rev_msg}\r | |
1972 | or $self->{rev_msg} =~ /^\s*(\.\s*)?$/\r | |
1973 | or index($self->{rev_msg}, EMPTY_LOG_MESSAGE) > -1 ) {\r | |
1974 | # ... until a msg separator is encountered:\r | |
1975 | # Ensure the message contains something:\r | |
1976 | $self->clear_msg\r | |
1977 | if $Prune_Empty_Msgs;\r | |
1978 | $self->{rev_msg} = "[no log message]\n";\r | |
1979 | }\r | |
1980 | \r | |
1981 | $self->add_file_entry;\r | |
1982 | \r | |
1983 | if ( $_ eq FILE_SEPARATOR ) {\r | |
1984 | $self->clear_file;\r | |
1985 | } else {\r | |
1986 | $self->clear_msg;\r | |
1987 | }\r | |
1988 | }\r | |
1989 | }\r | |
1990 | \r | |
1991 | close LOG_SOURCE\r | |
1992 | or die sprintf("Problem reading log input (exit/signal/core: %d/%d/%d)\n",\r | |
1993 | $? >> 8, $? & 127, $? & 128);\r | |
1994 | return;\r | |
1995 | }\r | |
1996 | \r | |
1997 | # -------------------------------------\r | |
1998 | \r | |
1999 | sub add_file_entry {\r | |
2000 | $_[0]->grand_poobah->add_fileentry(@{$_[0]}{qw(filename rev_time rev_revision\r | |
2001 | rev_state lines branch_names\r | |
2002 | rev_branch_roots\r | |
2003 | branch_numbers\r | |
2004 | symbolic_names\r | |
2005 | rev_author rev_msg)});\r | |
2006 | }\r | |
2007 | \r | |
2008 | # -------------------------------------\r | |
2009 | \r | |
2010 | sub maybe_read_user_map_file {\r | |
2011 | my ($self) = @_;\r | |
2012 | \r | |
2013 | my %expansions;\r | |
2014 | my $User_Map_Input;\r | |
2015 | \r | |
2016 | if ($User_Map_File)\r | |
2017 | {\r | |
2018 | if ( $User_Map_File =~ m{^([-\w\@+=.,\/]+):([-\w\@+=.,\/:]+)} and\r | |
2019 | !-f $User_Map_File )\r | |
2020 | {\r | |
2021 | my $rsh = (exists $ENV{'CVS_RSH'} ? $ENV{'CVS_RSH'} : 'ssh');\r | |
2022 | $User_Map_Input = "$rsh $1 'cat $2' |";\r | |
2023 | &main::debug ("(run \"${User_Map_Input}\")\n");\r | |
2024 | }\r | |
2025 | else\r | |
2026 | {\r | |
2027 | $User_Map_Input = "<$User_Map_File";\r | |
2028 | }\r | |
2029 | \r | |
2030 | open (MAPFILE, $User_Map_Input)\r | |
2031 | or die ("Unable to open $User_Map_File ($!)");\r | |
2032 | \r | |
2033 | while (<MAPFILE>)\r | |
2034 | {\r | |
2035 | next if /^\s*#/; # Skip comment lines.\r | |
2036 | next if not /:/; # Skip lines without colons.\r | |
2037 | \r | |
2038 | # It is now safe to split on ':'.\r | |
2039 | my ($username, $expansion) = split ':';\r | |
2040 | chomp $expansion;\r | |
2041 | $expansion =~ s/^'(.*)'$/$1/;\r | |
2042 | $expansion =~ s/^"(.*)"$/$1/;\r | |
2043 | \r | |
2044 | # If it looks like the expansion has a real name already, then\r | |
2045 | # we toss the username we got from CVS log. Otherwise, keep\r | |
2046 | # it to use in combination with the email address.\r | |
2047 | \r | |
2048 | if ($expansion =~ /^\s*<{0,1}\S+@.*/) {\r | |
2049 | # Also, add angle brackets if none present\r | |
2050 | if (! ($expansion =~ /<\S+@\S+>/)) {\r | |
2051 | $expansions{$username} = "$username <$expansion>";\r | |
2052 | }\r | |
2053 | else {\r | |
2054 | $expansions{$username} = "$username $expansion";\r | |
2055 | }\r | |
2056 | }\r | |
2057 | else {\r | |
2058 | $expansions{$username} = $expansion;\r | |
2059 | }\r | |
2060 | } # fi ($User_Map_File)\r | |
2061 | \r | |
2062 | close (MAPFILE);\r | |
2063 | }\r | |
2064 | \r | |
2065 | if (defined $User_Passwd_File)\r | |
2066 | {\r | |
2067 | if ( ! defined $Domain ) {\r | |
2068 | if ( -e MAILNAME ) {\r | |
2069 | chomp($Domain = slurp_file(MAILNAME));\r | |
2070 | } else {\r | |
2071 | MAILDOMAIN_CMD:\r | |
2072 | for ([qw(hostname -d)], 'dnsdomainname', 'domainname') {\r | |
2073 | my ($text, $exit, $sig, $core) = run_ext($_);\r | |
2074 | if ( $exit == 0 && $sig == 0 && $core == 0 ) {\r | |
2075 | chomp $text;\r | |
2076 | if ( length $text ) {\r | |
2077 | $Domain = $text;\r | |
2078 | last MAILDOMAIN_CMD;\r | |
2079 | }\r | |
2080 | }\r | |
2081 | }\r | |
2082 | }\r | |
2083 | }\r | |
2084 | \r | |
2085 | die "No mail domain found\n"\r | |
2086 | unless defined $Domain;\r | |
2087 | \r | |
2088 | open (MAPFILE, "<$User_Passwd_File")\r | |
2089 | or die ("Unable to open $User_Passwd_File ($!)");\r | |
2090 | while (<MAPFILE>)\r | |
2091 | {\r | |
2092 | # all lines are valid\r | |
2093 | my ($username, $pw, $uid, $gid, $gecos, $homedir, $shell) = split ':';\r | |
2094 | my $expansion = '';\r | |
2095 | ($expansion) = split (',', $gecos)\r | |
2096 | if defined $gecos && length $gecos;\r | |
2097 | \r | |
2098 | my $mailname = $Domain eq '' ? $username : "$username\@$Domain";\r | |
2099 | $expansions{$username} = "$expansion <$mailname>";\r | |
2100 | }\r | |
2101 | close (MAPFILE);\r | |
2102 | }\r | |
2103 | \r | |
2104 | $self->{usermap} = \%expansions;\r | |
2105 | }\r | |
2106 | \r | |
2107 | # -------------------------------------\r | |
2108 | \r | |
2109 | sub read_file_path {\r | |
2110 | my ($self, $line) = @_;\r | |
2111 | \r | |
2112 | my $path;\r | |
2113 | \r | |
2114 | if ( $line =~ /^Working file: (.*)/ ) {\r | |
2115 | $path = $1;\r | |
2116 | } elsif ( defined $RCS_Root\r | |
2117 | and\r | |
2118 | $line =~ m|^RCS file: $RCS_Root[/\\](.*),v$| ) {\r | |
2119 | $path = $1;\r | |
2120 | $path =~ s!Attic/!!;\r | |
2121 | } else {\r | |
2122 | return;\r | |
2123 | }\r | |
2124 | \r | |
2125 | if ( @Ignore_Files ) {\r | |
2126 | my $base;\r | |
2127 | ($base, undef, undef) = fileparse($path);\r | |
2128 | \r | |
2129 | my $xpath = $Case_Insensitive ? lc($path) : $path;\r | |
2130 | if ( grep index($path, $_) > -1, @Ignore_Files ) {\r | |
2131 | return;\r | |
2132 | }\r | |
2133 | }\r | |
2134 | \r | |
2135 | $self->{filename} = $path;\r | |
2136 | return;\r | |
2137 | }\r | |
2138 | \r | |
2139 | # -------------------------------------\r | |
2140 | \r | |
2141 | sub read_symbolic_name {\r | |
2142 | my ($self, $line) = @_;\r | |
2143 | \r | |
2144 | # All tag names are listed with whitespace in front in cvs log\r | |
2145 | # output; so if see non-whitespace, then we're done collecting.\r | |
2146 | if ( /^\S/ ) {\r | |
2147 | $self->{collecting_symbolic_names} = 0;\r | |
2148 | return;\r | |
2149 | } else {\r | |
2150 | # we're looking at a tag name, so parse & store it\r | |
2151 | \r | |
2152 | # According to the Cederqvist manual, in node "Tags", tag names must start\r | |
2153 | # with an uppercase or lowercase letter and can contain uppercase and\r | |
2154 | # lowercase letters, digits, `-', and `_'. However, it's not our place to\r | |
2155 | # enforce that, so we'll allow anything CVS hands us to be a tag:\r | |
2156 | my ($tag_name, $tag_rev) = ($line =~ /^\s+([^:]+): ([\d.]+)$/);\r | |
2157 | \r | |
2158 | # A branch number either has an odd number of digit sections\r | |
2159 | # (and hence an even number of dots), or has ".0." as the\r | |
2160 | # second-to-last digit section. Test for these conditions.\r | |
2161 | my $real_branch_rev = '';\r | |
2162 | if ( $tag_rev =~ /^(\d+\.\d+\.)+\d+$/ # Even number of dots...\r | |
2163 | and\r | |
2164 | $tag_rev !~ /^(1\.)+1$/ ) { # ...but not "1.[1.]1"\r | |
2165 | $real_branch_rev = $tag_rev;\r | |
2166 | } elsif ($tag_rev =~ /(\d+\.(\d+\.)+)0.(\d+)/) { # Has ".0."\r | |
2167 | $real_branch_rev = $1 . $3;\r | |
2168 | }\r | |
2169 | \r | |
2170 | # If we got a branch, record its number.\r | |
2171 | if ( $real_branch_rev ) {\r | |
2172 | $self->{branch_names}->{$real_branch_rev} = $tag_name;\r | |
2173 | $self->{branch_numbers}->{$tag_name} = $real_branch_rev;\r | |
2174 | } else {\r | |
2175 | # Else it's just a regular (non-branch) tag.\r | |
2176 | push @{$self->{symbolic_names}->{$tag_rev}}, $tag_name;\r | |
2177 | }\r | |
2178 | }\r | |
2179 | \r | |
2180 | $self->{collecting_symbolic_names} = 1;\r | |
2181 | return;\r | |
2182 | }\r | |
2183 | \r | |
2184 | # -------------------------------------\r | |
2185 | \r | |
2186 | sub read_revision {\r | |
2187 | my ($self, $line) = @_;\r | |
2188 | \r | |
2189 | my ($revision) = ( $line =~ /^revision (\d+\.[\d.]+)/ );\r | |
2190 | \r | |
2191 | return\r | |
2192 | unless $revision;\r | |
2193 | \r | |
2194 | $self->{rev_revision} = $revision;\r | |
2195 | return;\r | |
2196 | }\r | |
2197 | \r | |
2198 | # -------------------------------------\r | |
2199 | \r | |
2200 | { # Closure over %gecos_warned\r | |
2201 | my %gecos_warned;\r | |
2202 | sub read_date_author_and_state {\r | |
2203 | my ($self, $line) = @_;\r | |
2204 | \r | |
2205 | my ($time, $author, $state) = $self->parse_date_author_and_state($line);\r | |
2206 | \r | |
2207 | if ( defined($self->{usermap}->{$author}) and $self->{usermap}->{$author} ) {\r | |
2208 | $author = $self->{usermap}->{$author};\r | |
2209 | } elsif ( defined $Domain or $Gecos == 1 ) {\r | |
2210 | my $email = $author;\r | |
2211 | $email = $author."@".$Domain\r | |
2212 | if defined $Domain && $Domain ne '';\r | |
2213 | \r | |
2214 | my $pw = getpwnam($author);\r | |
2215 | my ($fullname, $office, $workphone, $homephone, $gcos);\r | |
2216 | if ( defined $pw ) {\r | |
2217 | $gcos = (getpwnam($author))[6];\r | |
2218 | ($fullname, $office, $workphone, $homephone) =\r | |
2219 | split /\s*,\s*/, $gcos;\r | |
2220 | } else {\r | |
2221 | warn "Couldn't find gecos info for author '$author'\n"\r | |
2222 | unless $gecos_warned{$author}++;\r | |
2223 | $fullname = '';\r | |
2224 | }\r | |
2225 | for (grep defined, $fullname, $office, $workphone, $homephone) {\r | |
2226 | s/&/ucfirst(lc($pw->name))/ge;\r | |
2227 | }\r | |
2228 | $author = $fullname . " <" . $email . ">"\r | |
2229 | if $fullname ne '';\r | |
2230 | }\r | |
2231 | \r | |
2232 | $self->{rev_state} = $state;\r | |
2233 | $self->{rev_time} = $time;\r | |
2234 | $self->{rev_author} = $author;\r | |
2235 | return;\r | |
2236 | }\r | |
2237 | }\r | |
2238 | \r | |
2239 | # -------------------------------------\r | |
2240 | \r | |
2241 | sub read_branches {\r | |
2242 | # A "branches: ..." line here indicates that one or more branches\r | |
2243 | # are rooted at this revision. If we're showing branches, then we\r | |
2244 | # want to show that fact as well, so we collect all the branches\r | |
2245 | # that this is the latest ancestor of and store them in\r | |
2246 | # $self->[rev_branch_roots}. Just for reference, the format of the\r | |
2247 | # line we're seeing at this point is:\r | |
2248 | #\r | |
2249 | # branches: 1.5.2; 1.5.4; ...;\r | |
2250 | #\r | |
2251 | # Okay, here goes:\r | |
2252 | my ($self, $line) = @_;\r | |
2253 | \r | |
2254 | # Ugh. This really bothers me. Suppose we see a log entry\r | |
2255 | # like this:\r | |
2256 | #\r | |
2257 | # ----------------------------\r | |
2258 | # revision 1.1\r | |
2259 | # date: 1999/10/17 03:07:38; author: jrandom; state: Exp;\r | |
2260 | # branches: 1.1.2;\r | |
2261 | # Intended first line of log message begins here.\r | |
2262 | # ----------------------------\r | |
2263 | #\r | |
2264 | # The question is, how we can tell the difference between that\r | |
2265 | # log message and a *two*-line log message whose first line is\r | |
2266 | #\r | |
2267 | # "branches: 1.1.2;"\r | |
2268 | #\r | |
2269 | # See the problem? The output of "cvs log" is inherently\r | |
2270 | # ambiguous.\r | |
2271 | #\r | |
2272 | # For now, we punt: we liberally assume that people don't\r | |
2273 | # write log messages like that, and just toss a "branches:"\r | |
2274 | # line if we see it but are not showing branches. I hope no\r | |
2275 | # one ever loses real log data because of this.\r | |
2276 | if ( $Show_Branches ) {\r | |
2277 | $line =~ s/(1\.)+1;|(1\.)+1$//; # ignore the trivial branch 1.1.1\r | |
2278 | $self->{rev_branch_roots} = [split /;\s+/, $line]\r | |
2279 | if length $line;\r | |
2280 | }\r | |
2281 | }\r | |
2282 | \r | |
2283 | # -------------------------------------\r | |
2284 | \r | |
2285 | sub parse_date_author_and_state {\r | |
2286 | my ($self, $line) = @_;\r | |
2287 | # Parses the date/time and author out of a line like:\r | |
2288 | #\r | |
2289 | # date: 1999/02/19 23:29:05; author: apharris; state: Exp;\r | |
2290 | #\r | |
2291 | # or, in CVS 1.12.9:\r | |
2292 | #\r | |
2293 | # date: 2004-06-05 16:10:32 +0000; author: somebody; state: Exp;\r | |
2294 | \r | |
2295 | my ($year, $mon, $mday, $hours, $min, $secs, $utcOffset, $author, $state, $rest) =\r | |
2296 | $line =~\r | |
2297 | m!(\d+)[-/](\d+)[-/](\d+)\s+(\d+):(\d+):(\d+)(\s+[+-]\d{4})?;\s+\r | |
2298 | author:\s+([^;]+);\s+state:\s+([^;]+);(.*)!x\r | |
2299 | or die "Couldn't parse date ``$line''";\r | |
2300 | die "Bad date or Y2K issues"\r | |
2301 | unless $year > 1969 and $year < 2258;\r | |
2302 | # Kinda arbitrary, but useful as a sanity check\r | |
2303 | my $time = timegm($secs, $min, $hours, $mday, $mon-1, $year-1900);\r | |
2304 | if ( defined $utcOffset ) {\r | |
2305 | my ($plusminus, $hour, $minute) = ($utcOffset =~ m/([+-])(\d\d)(\d\d)/);\r | |
2306 | my $offset = (($hour * 60) + $minute) * 60 * ($plusminus eq '+' ? -1 : 1);\r | |
2307 | $time += $offset;\r | |
2308 | }\r | |
2309 | if ( $rest =~ m!\s+lines:\s+(.*)! ) {\r | |
2310 | $self->{lines} = $1;\r | |
2311 | }\r | |
2312 | \r | |
2313 | return $time, $author, $state;\r | |
2314 | }\r | |
2315 | \r | |
2316 | # Subrs ----------------------------------------------------------------------\r | |
2317 | \r | |
2318 | package main;\r | |
2319 | \r | |
2320 | sub delta_check {\r | |
2321 | my ($time, $tags) = @_;\r | |
2322 | \r | |
2323 | # If we're in 'delta' mode, update the latest observed times for the\r | |
2324 | # beginning and ending tags, and when we get around to printing output, we\r | |
2325 | # will simply restrict ourselves to that timeframe...\r | |
2326 | return\r | |
2327 | unless $Delta_Mode;\r | |
2328 | \r | |
2329 | $Delta_StartTime = $time\r | |
2330 | if $time > $Delta_StartTime and grep { $_ eq $Delta_From } @$tags;\r | |
2331 | \r | |
2332 | $Delta_EndTime = $time\r | |
2333 | if $time > $Delta_EndTime and grep { $_ eq $Delta_To } @$tags;\r | |
2334 | }\r | |
2335 | \r | |
2336 | sub run_ext {\r | |
2337 | my ($cmd) = @_;\r | |
2338 | $cmd = [$cmd]\r | |
2339 | unless ref $cmd;\r | |
2340 | local $" = ' ';\r | |
2341 | my $out = qx"@$cmd 2>&1";\r | |
2342 | my $rv = $?;\r | |
2343 | my ($sig, $core, $exit) = ($? & 127, $? & 128, $? >> 8);\r | |
2344 | return $out, $exit, $sig, $core;\r | |
2345 | }\r | |
2346 | \r | |
2347 | # -------------------------------------\r | |
2348 | \r | |
2349 | # If accumulating, grab the boundary date from pre-existing ChangeLog.\r | |
2350 | sub maybe_grab_accumulation_date {\r | |
2351 | if (! $Cumulative || $Update) {\r | |
2352 | return '';\r | |
2353 | }\r | |
2354 | \r | |
2355 | # else\r | |
2356 | \r | |
2357 | open (LOG, "$Log_File_Name")\r | |
2358 | or die ("trouble opening $Log_File_Name for reading ($!)");\r | |
2359 | \r | |
2360 | my $boundary_date;\r | |
2361 | while (<LOG>)\r | |
2362 | {\r | |
2363 | if (/^(\d\d\d\d-\d\d-\d\d\s+\d\d:\d\d)/)\r | |
2364 | {\r | |
2365 | $boundary_date = "$1";\r | |
2366 | last;\r | |
2367 | }\r | |
2368 | }\r | |
2369 | \r | |
2370 | close (LOG);\r | |
2371 | \r | |
2372 | # convert time from utc to local timezone if the ChangeLog has\r | |
2373 | # dates/times in utc\r | |
2374 | if ($UTC_Times && $boundary_date)\r | |
2375 | {\r | |
2376 | # convert the utc time to a time value\r | |
2377 | my ($year,$mon,$mday,$hour,$min) = $boundary_date =~\r | |
2378 | m#(\d+)-(\d+)-(\d+)\s+(\d+):(\d+)#;\r | |
2379 | my $time = timegm(0,$min,$hour,$mday,$mon-1,$year-1900);\r | |
2380 | # print the timevalue in the local timezone\r | |
2381 | my ($ignore,$wday);\r | |
2382 | ($ignore,$min,$hour,$mday,$mon,$year,$wday) = localtime($time);\r | |
2383 | $boundary_date=sprintf ("%4u-%02u-%02u %02u:%02u",\r | |
2384 | $year+1900,$mon+1,$mday,$hour,$min);\r | |
2385 | }\r | |
2386 | \r | |
2387 | return $boundary_date;\r | |
2388 | }\r | |
2389 | \r | |
2390 | # -------------------------------------\r | |
2391 | \r | |
2392 | # Fills up a ChangeLog structure in the current directory.\r | |
2393 | sub derive_changelog {\r | |
2394 | my ($command) = @_;\r | |
2395 | \r | |
2396 | # See "The Plan" above for a full explanation.\r | |
2397 | \r | |
2398 | # Might be adding to an existing ChangeLog\r | |
2399 | my $accumulation_date = maybe_grab_accumulation_date;\r | |
2400 | if ($accumulation_date) {\r | |
2401 | # Insert -d immediately after 'cvs log'\r | |
2402 | my $Log_Date_Command = "-d\'>${accumulation_date}\'";\r | |
2403 | \r | |
2404 | my ($log_index) = grep $command->[$_] eq 'log', 0..$#$command;\r | |
2405 | splice @$command, $log_index+1, 0, $Log_Date_Command;\r | |
2406 | &debug ("(adding log msg starting from $accumulation_date)\n");\r | |
2407 | }\r | |
2408 | \r | |
2409 | # output_changelog(read_changelog($command));\r | |
2410 | my $builder = CVS::Utils::ChangeLog::EntrySetBuilder->new;\r | |
2411 | $builder->read_changelog($command);\r | |
2412 | $builder->grand_poobah->output_changelog;\r | |
2413 | }\r | |
2414 | \r | |
2415 | # -------------------------------------\r | |
2416 | \r | |
2417 | sub min { $_[0] < $_[1] ? $_[0] : $_[1] }\r | |
2418 | \r | |
2419 | # -------------------------------------\r | |
2420 | \r | |
2421 | sub common_path_prefix {\r | |
2422 | my ($path1, $path2) = @_;\r | |
2423 | \r | |
2424 | # For compatibility (with older versions of cvs2cl.pl), we think in UN*X\r | |
2425 | # terms, and mould windoze filenames to match. Is this really appropriate?\r | |
2426 | # If a file is checked in under UN*X, and cvs log run on windoze, which way\r | |
2427 | # do the path separators slope? Can we use fileparse as per the local\r | |
2428 | # conventions? If so, we should probably have a user option to specify an\r | |
2429 | # OS to emulate to handle stdin-fed logs. If we did this, we could avoid\r | |
2430 | # the nasty \-/ transmogrification below.\r | |
2431 | \r | |
2432 | my ($dir1, $dir2) = map +(fileparse($_))[1], $path1, $path2;\r | |
2433 | \r | |
2434 | # Transmogrify Windows filenames to look like Unix.\r | |
2435 | # (It is far more likely that someone is running cvs2cl.pl under\r | |
2436 | # Windows than that they would genuinely have backslashes in their\r | |
2437 | # filenames.)\r | |
2438 | tr!\\!/!\r | |
2439 | for $dir1, $dir2;\r | |
2440 | \r | |
2441 | my ($accum1, $accum2, $last_common_prefix) = ('') x 3;\r | |
2442 | \r | |
2443 | my @path1 = grep length($_), split qr!/!, $dir1;\r | |
2444 | my @path2 = grep length($_), split qr!/!, $dir2;\r | |
2445 | \r | |
2446 | my @common_path;\r | |
2447 | for (0..min($#path1,$#path2)) {\r | |
2448 | if ( $path1[$_] eq $path2[$_]) {\r | |
2449 | push @common_path, $path1[$_];\r | |
2450 | } else {\r | |
2451 | last;\r | |
2452 | }\r | |
2453 | }\r | |
2454 | \r | |
2455 | return join '', map "$_/", @common_path;\r | |
2456 | }\r | |
2457 | \r | |
2458 | # -------------------------------------\r | |
2459 | sub parse_options {\r | |
2460 | # Check this internally before setting the global variable.\r | |
2461 | my $output_file;\r | |
2462 | \r | |
2463 | # If this gets set, we encountered unknown options and will exit at\r | |
2464 | # the end of this subroutine.\r | |
2465 | my $exit_with_admonishment = 0;\r | |
2466 | \r | |
2467 | # command to generate the log\r | |
2468 | my @log_source_command = qw( cvs log );\r | |
2469 | \r | |
2470 | my (@Global_Opts, @Local_Opts);\r | |
2471 | \r | |
2472 | Getopt::Long::Configure(qw( bundling permute no_getopt_compat\r | |
2473 | pass_through no_ignore_case ));\r | |
2474 | GetOptions('help|usage|h' => \$Print_Usage,\r | |
2475 | 'debug' => \$Debug, # unadvertised option, heh\r | |
2476 | 'version' => \$Print_Version,\r | |
2477 | \r | |
2478 | 'file|f=s' => \$output_file,\r | |
2479 | 'accum' => \$Cumulative,\r | |
2480 | 'update' => \$Update,\r | |
2481 | 'fsf' => \$FSF_Style,\r | |
2482 | 'rcs=s' => \$RCS_Root,\r | |
2483 | 'usermap|U=s' => \$User_Map_File,\r | |
2484 | 'gecos' => \$Gecos,\r | |
2485 | 'domain=s' => \$Domain,\r | |
2486 | 'passwd=s' => \$User_Passwd_File,\r | |
2487 | 'window|W=i' => \$Max_Checkin_Duration,\r | |
2488 | 'chrono' => \$Chronological_Order,\r | |
2489 | 'ignore|I=s' => \@Ignore_Files,\r | |
2490 | 'case-insensitive|C' => \$Case_Insensitive,\r | |
2491 | 'regexp|R=s' => \$Regexp_Gate,\r | |
2492 | 'stdin' => \$Input_From_Stdin,\r | |
2493 | 'stdout' => \$Output_To_Stdout,\r | |
2494 | 'distributed|d' => sub { CVS::Utils::ChangeLog::FileEntry->distributed(1) },\r | |
2495 | 'prune|P' => \$Prune_Empty_Msgs,\r | |
2496 | 'no-wrap' => \$No_Wrap,\r | |
2497 | 'gmt|utc' => \$UTC_Times,\r | |
2498 | 'day-of-week|w' => \$Show_Day_Of_Week,\r | |
2499 | 'revisions|r' => \$Show_Revisions,\r | |
2500 | 'show-dead' => \$Show_Dead,\r | |
2501 | 'tags|t' => \$Show_Tags,\r | |
2502 | 'tagdates|T' => \$Show_Tag_Dates,\r | |
2503 | 'branches|b' => \$Show_Branches,\r | |
2504 | 'follow|F=s' => \@Follow_Branches,\r | |
2505 | 'follow-only=s' => \@Follow_Only,\r | |
2506 | 'xml-encoding=s' => \$XML_Encoding,\r | |
2507 | 'xml' => \$XML_Output,\r | |
2508 | 'noxmlns' => \$No_XML_Namespace,\r | |
2509 | 'no-xml-iso-date' => \$No_XML_ISO_Date,\r | |
2510 | 'no-ancestors' => \$No_Ancestors,\r | |
2511 | 'lines-modified' => \$Show_Lines_Modified,\r | |
2512 | \r | |
2513 | 'no-indent' => sub {\r | |
2514 | $Indent = '';\r | |
2515 | },\r | |
2516 | \r | |
2517 | 'summary' => sub {\r | |
2518 | $Summary = 1;\r | |
2519 | $After_Header = "\n\n"; # Summary implies --separate-header\r | |
2520 | },\r | |
2521 | \r | |
2522 | 'no-times' => sub {\r | |
2523 | $Show_Times = 0;\r | |
2524 | },\r | |
2525 | \r | |
2526 | 'no-hide-branch-additions' => sub {\r | |
2527 | $Hide_Branch_Additions = 0;\r | |
2528 | },\r | |
2529 | \r | |
2530 | 'no-common-dir' => sub {\r | |
2531 | $Common_Dir = 0;\r | |
2532 | },\r | |
2533 | \r | |
2534 | 'ignore-tag=s' => sub {\r | |
2535 | $ignore_tags{$_[1]} = 1;\r | |
2536 | },\r | |
2537 | \r | |
2538 | 'show-tag=s' => sub {\r | |
2539 | $show_tags{$_[1]} = 1;\r | |
2540 | },\r | |
2541 | \r | |
2542 | # Deliberately undocumented. This is not a public interface, and\r | |
2543 | # may change/disappear at any time.\r | |
2544 | 'test-code=s' => \$TestCode,\r | |
2545 | \r | |
2546 | 'delta=s' => sub {\r | |
2547 | my $arg = $_[1];\r | |
2548 | if ( $arg =~\r | |
2549 | /^([A-Za-z][A-Za-z0-9_\-\]\[]*):([A-Za-z][A-Za-z0-9_\-\]\[]*)$/ ) {\r | |
2550 | $Delta_From = $1;\r | |
2551 | $Delta_To = $2;\r | |
2552 | $Delta_Mode = 1;\r | |
2553 | } else {\r | |
2554 | die "--delta FROM_TAG:TO_TAG is what you meant to say.\n";\r | |
2555 | }\r | |
2556 | },\r | |
2557 | \r | |
2558 | 'FSF' => sub {\r | |
2559 | $Show_Times = 0;\r | |
2560 | $Common_Dir = 0;\r | |
2561 | $No_Extra_Indent = 1;\r | |
2562 | $Indent = "\t";\r | |
2563 | },\r | |
2564 | \r | |
2565 | 'header=s' => sub {\r | |
2566 | my $narg = $_[1];\r | |
2567 | $ChangeLog_Header = &slurp_file ($narg);\r | |
2568 | if (! defined ($ChangeLog_Header)) {\r | |
2569 | $ChangeLog_Header = '';\r | |
2570 | }\r | |
2571 | },\r | |
2572 | \r | |
2573 | 'global-opts|g=s' => sub {\r | |
2574 | my $narg = $_[1];\r | |
2575 | push @Global_Opts, $narg;\r | |
2576 | splice @log_source_command, 1, 0, $narg;\r | |
2577 | },\r | |
2578 | \r | |
2579 | 'log-opts|l=s' => sub {\r | |
2580 | my $narg = $_[1];\r | |
2581 | push @Local_Opts, $narg;\r | |
2582 | push @log_source_command, $narg;\r | |
2583 | },\r | |
2584 | \r | |
2585 | 'mailname=s' => sub {\r | |
2586 | my $narg = $_[1];\r | |
2587 | warn "--mailname is deprecated; please use --domain instead\n";\r | |
2588 | $Domain = $narg;\r | |
2589 | },\r | |
2590 | \r | |
2591 | 'separate-header|S' => sub {\r | |
2592 | $After_Header = "\n\n";\r | |
2593 | $No_Extra_Indent = 1;\r | |
2594 | },\r | |
2595 | \r | |
2596 | 'group-within-date' => sub {\r | |
2597 | $GroupWithinDate = 1;\r | |
2598 | $Show_Times = 0;\r | |
2599 | },\r | |
2600 | \r | |
2601 | 'hide-filenames' => sub {\r | |
2602 | $Hide_Filenames = 1;\r | |
2603 | $After_Header = '';\r | |
2604 | },\r | |
2605 | )\r | |
2606 | or die "options parsing failed\n";\r | |
2607 | \r | |
2608 | push @log_source_command, map "'$_'", @ARGV;\r | |
2609 | \r | |
2610 | ## Check for contradictions...\r | |
2611 | \r | |
2612 | if ($Output_To_Stdout && CVS::Utils::ChangeLog::FileEntry->distributed) {\r | |
2613 | print STDERR "cannot pass both --stdout and --distributed\n";\r | |
2614 | $exit_with_admonishment = 1;\r | |
2615 | }\r | |
2616 | \r | |
2617 | if ($Output_To_Stdout && $output_file) {\r | |
2618 | print STDERR "cannot pass both --stdout and --file\n";\r | |
2619 | $exit_with_admonishment = 1;\r | |
2620 | }\r | |
2621 | \r | |
2622 | if ($Input_From_Stdin && @Global_Opts) {\r | |
2623 | print STDERR "cannot pass both --stdin and -g\n";\r | |
2624 | $exit_with_admonishment = 1;\r | |
2625 | }\r | |
2626 | \r | |
2627 | if ($Input_From_Stdin && @Local_Opts) {\r | |
2628 | print STDERR "cannot pass both --stdin and -l\n";\r | |
2629 | $exit_with_admonishment = 1;\r | |
2630 | }\r | |
2631 | \r | |
2632 | if ($XML_Output && $Cumulative) {\r | |
2633 | print STDERR "cannot pass both --xml and --accum\n";\r | |
2634 | $exit_with_admonishment = 1;\r | |
2635 | }\r | |
2636 | \r | |
2637 | # Other consistency checks and option-driven logic\r | |
2638 | \r | |
2639 | # Bleargh. Compensate for a deficiency of custom wrapping.\r | |
2640 | if ( ($After_Header ne " ") and $FSF_Style ) {\r | |
2641 | $After_Header .= "\t";\r | |
2642 | }\r | |
2643 | \r | |
2644 | @Ignore_Files = map lc, @Ignore_Files\r | |
2645 | if $Case_Insensitive;\r | |
2646 | \r | |
2647 | # Or if any other error message has already been printed out, we\r | |
2648 | # just leave now:\r | |
2649 | if ($exit_with_admonishment) {\r | |
2650 | &usage ();\r | |
2651 | exit (1);\r | |
2652 | }\r | |
2653 | elsif ($Print_Usage) {\r | |
2654 | &usage ();\r | |
2655 | exit (0);\r | |
2656 | }\r | |
2657 | elsif ($Print_Version) {\r | |
2658 | &version ();\r | |
2659 | exit (0);\r | |
2660 | }\r | |
2661 | \r | |
2662 | ## Else no problems, so proceed.\r | |
2663 | \r | |
2664 | if ($output_file) {\r | |
2665 | $Log_File_Name = $output_file;\r | |
2666 | }\r | |
2667 | \r | |
2668 | return \@log_source_command;\r | |
2669 | }\r | |
2670 | \r | |
2671 | # -------------------------------------\r | |
2672 | \r | |
2673 | sub slurp_file {\r | |
2674 | my $filename = shift || die ("no filename passed to slurp_file()");\r | |
2675 | my $retstr;\r | |
2676 | \r | |
2677 | open (SLURPEE, "<${filename}") or die ("unable to open $filename ($!)");\r | |
2678 | local $/ = undef;\r | |
2679 | $retstr = <SLURPEE>;\r | |
2680 | close (SLURPEE);\r | |
2681 | return $retstr;\r | |
2682 | }\r | |
2683 | \r | |
2684 | # -------------------------------------\r | |
2685 | \r | |
2686 | sub debug {\r | |
2687 | if ($Debug) {\r | |
2688 | my $msg = shift;\r | |
2689 | print STDERR $msg;\r | |
2690 | }\r | |
2691 | }\r | |
2692 | \r | |
2693 | # -------------------------------------\r | |
2694 | \r | |
2695 | sub version {\r | |
2696 | print "cvs2cl.pl version ${VERSION}; distributed under the GNU GPL.\n";\r | |
2697 | }\r | |
2698 | \r | |
2699 | # -------------------------------------\r | |
2700 | \r | |
2701 | sub usage {\r | |
2702 | &version ();\r | |
2703 | \r | |
2704 | eval "use Pod::Usage qw( pod2usage )";\r | |
2705 | \r | |
2706 | if ( $@ ) {\r | |
2707 | print <<'END';\r | |
2708 | \r | |
2709 | * Pod::Usage was not found. The formatting may be suboptimal. Consider\r | |
2710 | upgrading your Perl --- Pod::Usage is standard from 5.6 onwards, and\r | |
2711 | versions of perl prior to 5.6 are getting rather rusty, now. Alternatively,\r | |
2712 | install Pod::Usage direct from CPAN.\r | |
2713 | END\r | |
2714 | \r | |
2715 | local $/ = undef;\r | |
2716 | my $message = <DATA>;\r | |
2717 | $message =~ s/^=(head1|item) //gm;\r | |
2718 | $message =~ s/^=(over|back).*\n//gm;\r | |
2719 | $message =~ s/\n{3,}/\n\n/g;\r | |
2720 | print $message;\r | |
2721 | } else {\r | |
2722 | print "\n";\r | |
2723 | pod2usage( -exitval => 'NOEXIT',\r | |
2724 | -verbose => 1,\r | |
2725 | -output => \*STDOUT,\r | |
2726 | );\r | |
2727 | }\r | |
2728 | \r | |
2729 | return;\r | |
2730 | }\r | |
2731 | \r | |
2732 | # Main -----------------------------------------------------------------------\r | |
2733 | \r | |
2734 | my $log_source_command = parse_options;\r | |
2735 | if ( defined $TestCode ) {\r | |
2736 | eval $TestCode;\r | |
2737 | die "Eval failed: '$@'\n"\r | |
2738 | if $@;\r | |
2739 | } else {\r | |
2740 | derive_changelog($log_source_command);\r | |
2741 | }\r | |
2742 | \r | |
2743 | __DATA__\r | |
2744 | \r | |
2745 | =head1 NAME\r | |
2746 | \r | |
2747 | cvs2cl.pl - convert cvs log messages to changelogs\r | |
2748 | \r | |
2749 | =head1 SYNOPSIS\r | |
2750 | \r | |
2751 | B<cvs2cl> [I<options>] [I<FILE1> [I<FILE2> ...]]\r | |
2752 | \r | |
2753 | =head1 DESCRIPTION\r | |
2754 | \r | |
2755 | cvs2cl produces a GNU-style ChangeLog for CVS-controlled sources by\r | |
2756 | running "cvs log" and parsing the output. Duplicate log messages get\r | |
2757 | unified in the Right Way.\r | |
2758 | \r | |
2759 | The default output of cvs2cl is designed to be compact, formally unambiguous,\r | |
2760 | but still easy for humans to read. It should be largely self-explanatory; the\r | |
2761 | one abbreviation that might not be obvious is "utags". That stands for\r | |
2762 | "universal tags" -- a universal tag is one held by all the files in a given\r | |
2763 | change entry.\r | |
2764 | \r | |
2765 | If you need output that's easy for a program to parse, use the B<--xml> option.\r | |
2766 | Note that with XML output, just about all available information is included\r | |
2767 | with each change entry, whether you asked for it or not, on the theory that\r | |
2768 | your parser can ignore anything it's not looking for.\r | |
2769 | \r | |
2770 | If filenames are given as arguments cvs2cl only shows log information for the\r | |
2771 | named files.\r | |
2772 | \r | |
2773 | =head1 OPTIONS\r | |
2774 | \r | |
2775 | =over 4\r | |
2776 | \r | |
2777 | =item B<-h>, B<-help>, B<--help>, B<-?>\r | |
2778 | \r | |
2779 | Show a short help and exit.\r | |
2780 | \r | |
2781 | =item B<--version>\r | |
2782 | \r | |
2783 | Show version and exit.\r | |
2784 | \r | |
2785 | =item B<-r>, B<--revisions>\r | |
2786 | \r | |
2787 | Show revision numbers in output.\r | |
2788 | \r | |
2789 | =item B<-b>, B<--branches>\r | |
2790 | \r | |
2791 | Show branch names in revisions when possible.\r | |
2792 | \r | |
2793 | =item B<-t>, B<--tags>\r | |
2794 | \r | |
2795 | Show tags (symbolic names) in output.\r | |
2796 | \r | |
2797 | =item B<-T>, B<--tagdates>\r | |
2798 | \r | |
2799 | Show tags in output on their first occurance.\r | |
2800 | \r | |
2801 | =item B<--show-dead>\r | |
2802 | \r | |
2803 | Show dead files.\r | |
2804 | \r | |
2805 | =item B<--stdin>\r | |
2806 | \r | |
2807 | Read from stdin, don't run cvs log.\r | |
2808 | \r | |
2809 | =item B<--stdout>\r | |
2810 | \r | |
2811 | Output to stdout not to ChangeLog.\r | |
2812 | \r | |
2813 | =item B<-d>, B<--distributed>\r | |
2814 | \r | |
2815 | Put ChangeLogs in subdirs.\r | |
2816 | \r | |
2817 | =item B<-f> I<FILE>, B<--file> I<FILE>\r | |
2818 | \r | |
2819 | Write to I<FILE> instead of ChangeLog.\r | |
2820 | \r | |
2821 | =item B<--fsf>\r | |
2822 | \r | |
2823 | Use this if log data is in FSF ChangeLog style.\r | |
2824 | \r | |
2825 | =item B<--FSF>\r | |
2826 | \r | |
2827 | Attempt strict FSF-standard compatible output.\r | |
2828 | \r | |
2829 | =item B<-W> I<SECS>, B<--window> I<SECS>\r | |
2830 | \r | |
2831 | Window of time within which log entries unify.\r | |
2832 | \r | |
2833 | =item -B<U> I<UFILE>, B<--usermap> I<UFILE>\r | |
2834 | \r | |
2835 | Expand usernames to email addresses from I<UFILE>.\r | |
2836 | \r | |
2837 | =item B<--passwd> I<PASSWORDFILE>\r | |
2838 | \r | |
2839 | Use system passwd file for user name expansion. If no mail domain is provided\r | |
2840 | (via B<--domain>), it tries to read one from B</etc/mailname>, output of B<hostname\r | |
2841 | -d>, B<dnsdomainname>, or B<domain-name>. cvs2cl exits with an error if none of\r | |
2842 | those options is successful. Use a domain of '' to prevent the addition of a\r | |
2843 | mail domain.\r | |
2844 | \r | |
2845 | =item B<--domain> I<DOMAIN>\r | |
2846 | \r | |
2847 | Domain to build email addresses from.\r | |
2848 | \r | |
2849 | =item B<--gecos>\r | |
2850 | \r | |
2851 | Get user information from GECOS data.\r | |
2852 | \r | |
2853 | =item B<-R> I<REGEXP>, B<--regexp> I<REGEXP>\r | |
2854 | \r | |
2855 | Include only entries that match I<REGEXP>. This option may be used multiple\r | |
2856 | times.\r | |
2857 | \r | |
2858 | =item B<-I> I<REGEXP>, B<--ignore> I<REGEXP>\r | |
2859 | \r | |
2860 | Ignore files whose names match I<REGEXP>. This option may be used multiple\r | |
2861 | times.\r | |
2862 | \r | |
2863 | =item B<-C>, B<--case-insensitive>\r | |
2864 | \r | |
2865 | Any regexp matching is done case-insensitively.\r | |
2866 | \r | |
2867 | =item B<-F> I<BRANCH>, B<--follow> I<BRANCH>\r | |
2868 | \r | |
2869 | Show only revisions on or ancestral to I<BRANCH>.\r | |
2870 | \r | |
2871 | =item B<--follow-only> I<BRANCH>\r | |
2872 | \r | |
2873 | Like --follow, but sub-branches are not followed.\r | |
2874 | \r | |
2875 | =item B<--no-ancestors>\r | |
2876 | \r | |
2877 | When using B<-F>, only track changes since the I<BRANCH> started.\r | |
2878 | \r | |
2879 | =item B<--no-hide-branch-additions>\r | |
2880 | \r | |
2881 | By default, entries generated by cvs for a file added on a branch (a dead 1.1\r | |
2882 | entry) are not shown. This flag reverses that action.\r | |
2883 | \r | |
2884 | =item B<-S>, B<--separate-header>\r | |
2885 | \r | |
2886 | Blank line between each header and log message.\r | |
2887 | \r | |
2888 | =item B<--summary>\r | |
2889 | \r | |
2890 | Add CVS change summary information.\r | |
2891 | \r | |
2892 | =item B<--no-wrap>\r | |
2893 | \r | |
2894 | Don't auto-wrap log message (recommend B<-S> also).\r | |
2895 | \r | |
2896 | =item B<--no-indent>\r | |
2897 | \r | |
2898 | Don't indent log message\r | |
2899 | \r | |
2900 | =item B<--gmt>, B<--utc>\r | |
2901 | \r | |
2902 | Show times in GMT/UTC instead of local time.\r | |
2903 | \r | |
2904 | =item B<--accum>\r | |
2905 | \r | |
2906 | Add to an existing ChangeLog (incompatible with B<--xml>).\r | |
2907 | \r | |
2908 | =item B<-w>, B<--day-of-week>\r | |
2909 | \r | |
2910 | Show day of week.\r | |
2911 | \r | |
2912 | =item B<--no-times>\r | |
2913 | \r | |
2914 | Don't show times in output.\r | |
2915 | \r | |
2916 | =item B<--chrono>\r | |
2917 | \r | |
2918 | Output log in chronological order (default is reverse chronological order).\r | |
2919 | \r | |
2920 | =item B<--header> I<FILE>\r | |
2921 | \r | |
2922 | Get ChangeLog header from I<FILE> ("B<->" means stdin).\r | |
2923 | \r | |
2924 | =item B<--xml>\r | |
2925 | \r | |
2926 | Output XML instead of ChangeLog format.\r | |
2927 | \r | |
2928 | =item B<--xml-encoding> I<ENCODING.>\r | |
2929 | \r | |
2930 | Insert encoding clause in XML header.\r | |
2931 | \r | |
2932 | =item B<--noxmlns>\r | |
2933 | \r | |
2934 | Don't include xmlns= attribute in root element.\r | |
2935 | \r | |
2936 | =item B<--hide-filenames>\r | |
2937 | \r | |
2938 | Don't show filenames (ignored for XML output).\r | |
2939 | \r | |
2940 | =item B<--no-common-dir>\r | |
2941 | \r | |
2942 | Don't shorten directory names from filenames.\r | |
2943 | \r | |
2944 | =item B<--rcs> I<CVSROOT>\r | |
2945 | \r | |
2946 | Handle filenames from raw RCS, for instance those produced by "cvs rlog"\r | |
2947 | output, stripping the prefix I<CVSROOT>.\r | |
2948 | \r | |
2949 | =item B<-P>, B<--prune>\r | |
2950 | \r | |
2951 | Don't show empty log messages.\r | |
2952 | \r | |
2953 | =item B<--lines-modified>\r | |
2954 | \r | |
2955 | Output the number of lines added and the number of lines removed for\r | |
2956 | each checkin (if applicable). At the moment, this only affects the\r | |
2957 | XML output mode.\r | |
2958 | \r | |
2959 | =item B<--ignore-tag> I<TAG>\r | |
2960 | \r | |
2961 | Ignore individual changes that are associated with a given tag.\r | |
2962 | May be repeated, if so, changes that are associated with any of\r | |
2963 | the given tags are ignored.\r | |
2964 | \r | |
2965 | =item B<--show-tag> I<TAG>\r | |
2966 | \r | |
2967 | Log only individual changes that are associated with a given\r | |
2968 | tag. May be repeated, if so, changes that are associated with\r | |
2969 | any of the given tags are logged.\r | |
2970 | \r | |
2971 | =item B<--delta> I<FROM_TAG>B<:>I<TO_TAG>\r | |
2972 | \r | |
2973 | Attempt a delta between two tags (since I<FROM_TAG> up to and\r | |
2974 | including I<TO_TAG>). The algorithm is a simple date-based one\r | |
2975 | (this is a hard problem) so results are imperfect.\r | |
2976 | \r | |
2977 | =item B<-g> I<OPTS>, B<--global-opts> I<OPTS>\r | |
2978 | \r | |
2979 | Pass I<OPTS> to cvs like in "cvs I<OPTS> log ...".\r | |
2980 | \r | |
2981 | =item B<-l> I<OPTS>, B<--log-opts> I<OPTS>\r | |
2982 | \r | |
2983 | Pass I<OPTS> to cvs log like in "cvs ... log I<OPTS>".\r | |
2984 | \r | |
2985 | =back\r | |
2986 | \r | |
2987 | Notes about the options and arguments:\r | |
2988 | \r | |
2989 | =over 4\r | |
2990 | \r | |
2991 | =item *\r | |
2992 | \r | |
2993 | The B<-I> and B<-F> options may appear multiple times.\r | |
2994 | \r | |
2995 | =item *\r | |
2996 | \r | |
2997 | To follow trunk revisions, use "B<-F trunk>" ("B<-F TRUNK>" also works). This is\r | |
2998 | okay because no would ever, ever be crazy enough to name a branch "trunk",\r | |
2999 | right? Right.\r | |
3000 | \r | |
3001 | =item *\r | |
3002 | \r | |
3003 | For the B<-U> option, the I<UFILE> should be formatted like CVSROOT/users. That is,\r | |
3004 | each line of I<UFILE> looks like this:\r | |
3005 | \r | |
3006 | jrandom:jrandom@red-bean.com\r | |
3007 | \r | |
3008 | or maybe even like this\r | |
3009 | \r | |
3010 | jrandom:'Jesse Q. Random <jrandom@red-bean.com>'\r | |
3011 | \r | |
3012 | Don't forget to quote the portion after the colon if necessary.\r | |
3013 | \r | |
3014 | =item *\r | |
3015 | \r | |
3016 | Many people want to filter by date. To do so, invoke cvs2cl.pl like this:\r | |
3017 | \r | |
3018 | cvs2cl.pl -l "-d'DATESPEC'"\r | |
3019 | \r | |
3020 | where DATESPEC is any date specification valid for "cvs log -d". (Note that\r | |
3021 | CVS 1.10.7 and below requires there be no space between -d and its argument).\r | |
3022 | \r | |
3023 | =item *\r | |
3024 | \r | |
3025 | Dates/times are interpreted in the local time zone.\r | |
3026 | \r | |
3027 | =item *\r | |
3028 | \r | |
3029 | Remember to quote the argument to `B<-l>' so that your shell doesn't interpret\r | |
3030 | spaces as argument separators.\r | |
3031 | \r | |
3032 | =item *\r | |
3033 | \r | |
3034 | See the 'Common Options' section of the cvs manual ('info cvs' on UNIX-like\r | |
3035 | systems) for more information.\r | |
3036 | \r | |
3037 | =item *\r | |
3038 | \r | |
3039 | Note that the rules for quoting under windows shells are different.\r | |
3040 | \r | |
3041 | =back\r | |
3042 | \r | |
3043 | =head1 EXAMPLES\r | |
3044 | \r | |
3045 | Some examples (working on UNIX shells):\r | |
3046 | \r | |
3047 | # logs after 6th March, 2003 (inclusive)\r | |
3048 | cvs2cl.pl -l "-d'>2003-03-06'"\r | |
3049 | # logs after 4:34PM 6th March, 2003 (inclusive)\r | |
3050 | cvs2cl.pl -l "-d'>2003-03-06 16:34'"\r | |
3051 | # logs between 4:46PM 6th March, 2003 (exclusive) and\r | |
3052 | # 4:34PM 6th March, 2003 (inclusive)\r | |
3053 | cvs2cl.pl -l "-d'2003-03-06 16:46>2003-03-06 16:34'"\r | |
3054 | \r | |
3055 | Some examples (on non-UNIX shells):\r | |
3056 | \r | |
3057 | # Reported to work on windows xp/2000\r | |
3058 | cvs2cl.pl -l "-d"">2003-10-18;today<"""\r | |
3059 | \r | |
3060 | =head1 AUTHORS\r | |
3061 | \r | |
3062 | =over 4\r | |
3063 | \r | |
3064 | =item Karl Fogel\r | |
3065 | \r | |
3066 | =item Melissa O'Neill\r | |
3067 | \r | |
3068 | =item Martyn J. Pearce\r | |
3069 | \r | |
3070 | =back\r | |
3071 | \r | |
3072 | Contributions from\r | |
3073 | \r | |
3074 | =over 4\r | |
3075 | \r | |
3076 | =item Mike Ayers\r | |
3077 | \r | |
3078 | =item Tim Bradshaw\r | |
3079 | \r | |
3080 | =item Richard Broberg\r | |
3081 | \r | |
3082 | =item Nathan Bryant\r | |
3083 | \r | |
3084 | =item Oswald Buddenhagen\r | |
3085 | \r | |
3086 | =item Neil Conway\r | |
3087 | \r | |
3088 | =item Arthur de Jong\r | |
3089 | \r | |
3090 | =item Mark W. Eichin\r | |
3091 | \r | |
3092 | =item Dave Elcock\r | |
3093 | \r | |
3094 | =item Reid Ellis\r | |
3095 | \r | |
3096 | =item Simon Josefsson\r | |
3097 | \r | |
3098 | =item Robin Hugh Johnson\r | |
3099 | \r | |
3100 | =item Terry Kane\r | |
3101 | \r | |
3102 | =item Akos Kiss\r | |
3103 | \r | |
3104 | =item Claus Klein\r | |
3105 | \r | |
3106 | =item Eddie Kohler\r | |
3107 | \r | |
3108 | =item Richard Laager\r | |
3109 | \r | |
3110 | =item Kevin Lilly\r | |
3111 | \r | |
3112 | =item Karl-Heinz Marbaise\r | |
3113 | \r | |
3114 | =item Mitsuaki Masuhara\r | |
3115 | \r | |
3116 | =item Henrik Nordstrom\r | |
3117 | \r | |
3118 | =item Joe Orton\r | |
3119 | \r | |
3120 | =item Peter Palfrader\r | |
3121 | \r | |
3122 | =item Thomas Parmelan\r | |
3123 | \r | |
3124 | =item Johanne Stezenbach\r | |
3125 | \r | |
3126 | =item Joseph Walton\r | |
3127 | \r | |
3128 | =item Ernie Zapata\r | |
3129 | \r | |
3130 | =back\r | |
3131 | \r | |
3132 | =head1 BUGS\r | |
3133 | \r | |
3134 | Please report bugs to C<bug-cvs2cl@red-bean.com>.\r | |
3135 | \r | |
3136 | =head1 PREREQUISITES\r | |
3137 | \r | |
3138 | This script requires C<Text::Wrap>, C<Time::Local>, and C<File::Basename>. It\r | |
3139 | also seems to require C<Perl 5.004_04> or higher.\r | |
3140 | \r | |
3141 | =head1 OPERATING SYSTEM COMPATIBILITY\r | |
3142 | \r | |
3143 | Should work on any OS.\r | |
3144 | \r | |
3145 | =head1 SCRIPT CATEGORIES\r | |
3146 | \r | |
3147 | Version_Control/CVS\r | |
3148 | \r | |
3149 | =head1 COPYRIGHT\r | |
3150 | \r | |
3151 | (C) 2001,2002,2003,2004 Martyn J. Pearce <fluffy@cpan.org>, under the GNU GPL.\r | |
3152 | \r | |
3153 | (C) 1999 Karl Fogel <kfogel@red-bean.com>, under the GNU GPL.\r | |
3154 | \r | |
3155 | cvs2cl.pl is free software; you can redistribute it and/or modify\r | |
3156 | it under the terms of the GNU General Public License as published by\r | |
3157 | the Free Software Foundation; either version 2, or (at your option)\r | |
3158 | any later version.\r | |
3159 | \r | |
3160 | cvs2cl.pl is distributed in the hope that it will be useful,\r | |
3161 | but WITHOUT ANY WARRANTY; without even the implied warranty of\r | |
3162 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r | |
3163 | GNU General Public License for more details.\r | |
3164 | \r | |
3165 | You may have received a copy of the GNU General Public License\r | |
3166 | along with cvs2cl.pl; see the file COPYING. If not, write to the\r | |
3167 | Free Software Foundation, Inc., 59 Temple Place - Suite 330,\r | |
3168 | Boston, MA 02111-1307, USA.\r | |
3169 | \r | |
3170 | =head1 SEE ALSO\r | |
3171 | \r | |
3172 | cvs(1)\r | |
3173 | \r | |
3174 | \r |