Changelog.pm 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978
  1. #
  2. # Dpkg::Changelog
  3. #
  4. # Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de>
  5. # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
  6. #
  7. # This program is free software; you can redistribute it and/or modify
  8. # it under the terms of the GNU General Public License as published by
  9. # the Free Software Foundation; either version 2 of the License, or
  10. # (at your option) any later version.
  11. #
  12. # This program is distributed in the hope that it will be useful,
  13. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. # GNU General Public License for more details.
  16. #
  17. # You should have received a copy of the GNU General Public License
  18. # along with this program; if not, write to the Free Software
  19. # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
  20. #
  21. =head1 NAME
  22. Dpkg::Changelog
  23. =head1 DESCRIPTION
  24. FIXME: to be written
  25. =head2 Functions
  26. =cut
  27. package Dpkg::Changelog;
  28. use strict;
  29. use warnings;
  30. use English;
  31. use Dpkg;
  32. use Dpkg::Gettext;
  33. use Dpkg::ErrorHandling qw(:DEFAULT report);
  34. use Dpkg::Control;
  35. use Dpkg::Version;
  36. use Dpkg::Vendor qw(run_vendor_hook);
  37. use base qw(Exporter);
  38. our %EXPORT_TAGS = ( 'util' => [ qw(
  39. find_closes
  40. data2rfc822
  41. data2rfc822_mult
  42. get_dpkg_changes
  43. parse_changelog
  44. ) ] );
  45. our @EXPORT_OK = @{$EXPORT_TAGS{util}};
  46. =pod
  47. =head3 init
  48. Creates a new object instance. Takes a reference to a hash as
  49. optional argument, which is interpreted as configuration options.
  50. There are currently no supported general configuration options, but
  51. see the other methods for more specific configuration options which
  52. can also specified to C<init>.
  53. If C<infile>, C<inhandle>, or C<instring> are specified, C<parse()>
  54. is called from C<init>. If a fatal error is encountered during parsing
  55. (e.g. the file can't be opened), C<init> will not return a
  56. valid object but C<undef>!
  57. =cut
  58. sub init {
  59. my $classname = shift;
  60. my $config = shift || {};
  61. my $self = {};
  62. bless( $self, $classname );
  63. $config->{verbose} = 1 if $config->{debug};
  64. $self->{config} = $config;
  65. $self->reset_parse_errors;
  66. if ($self->{config}{infile}
  67. || $self->{config}{inhandle}
  68. || $self->{config}{instring}) {
  69. defined($self->parse) or return undef;
  70. }
  71. return $self;
  72. }
  73. =pod
  74. =head3 reset_parse_errors
  75. Can be used to delete all information about errors ocurred during
  76. previous L<parse> runs. Note that C<parse()> also calls this method.
  77. =cut
  78. sub reset_parse_errors {
  79. my ($self) = @_;
  80. $self->{errors}{parser} = [];
  81. }
  82. sub _do_parse_error {
  83. my ($self, $file, $line_nr, $error, $line) = @_;
  84. shift;
  85. push @{$self->{errors}{parser}}, [ @_ ];
  86. unless ($self->{config}{quiet}) {
  87. if ($line) {
  88. warning("%20s(l$NR): $error\nLINE: $line", $file);
  89. } else {
  90. warning("%20s(l$NR): $error", $file);
  91. }
  92. }
  93. }
  94. =pod
  95. =head3 get_parse_errors
  96. Returns all error messages from the last L<parse> run.
  97. If called in scalar context returns a human readable
  98. string representation. If called in list context returns
  99. an array of arrays. Each of these arrays contains
  100. =over 4
  101. =item 1.
  102. the filename of the parsed file or C<FileHandle> or C<String>
  103. if the input came from a file handle or a string. If the
  104. reportfile configuration option was given, its value will be
  105. used instead
  106. =item 2.
  107. the line number where the error occurred
  108. =item 3.
  109. an error description
  110. =item 4.
  111. the original line
  112. =back
  113. NOTE: This format isn't stable yet and may change in later versions
  114. of this module.
  115. =cut
  116. sub get_parse_errors {
  117. my ($self) = @_;
  118. if (wantarray) {
  119. return @{$self->{errors}{parser}};
  120. } else {
  121. my $res = "";
  122. foreach my $e (@{$self->{errors}{parser}}) {
  123. if ($e->[3]) {
  124. $res .= report(_g('warning'),_g("%s(l%s): %s\nLINE: %s"), @$e );
  125. } else {
  126. $res .= report(_g('warning'),_g("%s(l%s): %s"), @$e );
  127. }
  128. }
  129. return $res;
  130. }
  131. }
  132. sub _do_fatal_error {
  133. my ($self, $msg, @msg) = @_;
  134. $self->{errors}{fatal} = report(_g('fatal error'), $msg, @msg);
  135. warning($msg, @msg) unless $self->{config}{quiet};
  136. }
  137. =pod
  138. =head3 get_error
  139. Get the last non-parser error (e.g. the file to parse couldn't be opened).
  140. =cut
  141. sub get_error {
  142. my ($self) = @_;
  143. return $self->{errors}{fatal};
  144. }
  145. =pod
  146. =head3 data
  147. C<data> returns an array (if called in list context) or a reference
  148. to an array of Dpkg::Changelog::Entry objects which each
  149. represent one entry of the changelog.
  150. This method supports the common output options described in
  151. section L<"COMMON OUTPUT OPTIONS">.
  152. =cut
  153. sub data {
  154. my ($self, $config) = @_;
  155. my $data = $self->{data};
  156. if ($config) {
  157. $self->{config}{DATA} = $config if $config;
  158. $data = $self->_data_range( $config ) or return undef;
  159. }
  160. return @$data if wantarray;
  161. return $data;
  162. }
  163. sub __sanity_check_range {
  164. my ( $data, $from, $to, $since, $until, $start, $end ) = @_;
  165. if (($$start || $$end) &&
  166. (length($$from) || length($$since) || length($$to) || length($$until)))
  167. {
  168. warning(_g( "you can't combine 'count' or 'offset' with any other range option" ));
  169. $$from = $$since = $$to = $$until = '';
  170. }
  171. if (length($$from) && length($$since)) {
  172. warning(_g( "you can only specify one of 'from' and 'since', using 'since'" ));
  173. $$from = '';
  174. }
  175. if (length($$to) && length($$until)) {
  176. warning(_g( "you can only specify one of 'to' and 'until', using 'until'" ));
  177. $$to = '';
  178. }
  179. $$start = 0 if $$start < 0;
  180. return if $$start > $#$data;
  181. $$end = $#$data if $$end > $#$data;
  182. return if $$end < 0;
  183. $$end = $$start if $$end < $$start;
  184. # Handle non-existing versions
  185. my (%versions, @versions);
  186. foreach my $entry (@{$data}) {
  187. $versions{$entry->{Version}} = 1;
  188. push @versions, $entry->{Version};
  189. }
  190. if ((length($$since) and not exists $versions{$$since})) {
  191. warning(_g("'%s' option specifies non-existing version"), "since");
  192. warning(_g("use newest entry that is smaller than the one specified"));
  193. foreach my $v (@versions) {
  194. if (version_compare_relation($v, REL_LT, $$since)) {
  195. $$since = $v;
  196. last;
  197. }
  198. }
  199. if (not exists $versions{$$since}) {
  200. # No version was smaller, include all
  201. warning(_g("none found, starting from the oldest entry"));
  202. $$since = '';
  203. $$from = $versions[-1];
  204. }
  205. }
  206. if ((length($$from) and not exists $versions{$$from})) {
  207. warning(_g("'%s' option specifies non-existing version"), "from");
  208. warning(_g("use oldest entry that is bigger than the one specified"));
  209. my $oldest;
  210. foreach my $v (@versions) {
  211. if (version_compare_relation($v, REL_GT, $$from)) {
  212. $oldest = $v;
  213. }
  214. }
  215. if (defined($oldest)) {
  216. $$from = $oldest;
  217. } else {
  218. warning(_g("no such entry found, ignoring '%s' parameter"), "from");
  219. $$from = ''; # No version was bigger
  220. }
  221. }
  222. if ((length($$until) and not exists $versions{$$until})) {
  223. warning(_g("'%s' option specifies non-existing version"), "until");
  224. warning(_g("use oldest entry that is bigger than the one specified"));
  225. my $oldest;
  226. foreach my $v (@versions) {
  227. if (version_compare_relation($v, REL_GT, $$until)) {
  228. $oldest = $v;
  229. }
  230. }
  231. if (defined($oldest)) {
  232. $$until = $oldest;
  233. } else {
  234. warning(_g("no such entry found, ignoring '%s' parameter"), "until");
  235. $$until = ''; # No version was bigger
  236. }
  237. }
  238. if ((length($$to) and not exists $versions{$$to})) {
  239. warning(_g("'%s' option specifies non-existing version"), "to");
  240. warning(_g("use newest entry that is smaller than the one specified"));
  241. foreach my $v (@versions) {
  242. if (version_compare_relation($v, REL_LT, $$to)) {
  243. $$to = $v;
  244. last;
  245. }
  246. }
  247. if (not exists $versions{$$to}) {
  248. # No version was smaller
  249. warning(_g("no such entry found, ignoring '%s' parameter"), "to");
  250. $$to = '';
  251. }
  252. }
  253. if (length($$since) && ($data->[0]{Version} eq $$since)) {
  254. warning(_g( "'since' option specifies most recent version, ignoring" ));
  255. $$since = '';
  256. }
  257. if (length($$until) && ($data->[$#{$data}]{Version} eq $$until)) {
  258. warning(_g( "'until' option specifies oldest version, ignoring" ));
  259. $$until = '';
  260. }
  261. return 1;
  262. }
  263. sub _data_range {
  264. my ($self, $config) = @_;
  265. my $data = $self->data or return undef;
  266. return [ @$data ] if $config->{all};
  267. my ($since, $until, $from, $to, $count, $offset) = ('', '', '', '', 0, 0);
  268. $since = $config->{since} if defined($config->{since});
  269. $until = $config->{until} if defined($config->{until});
  270. $from = $config->{from} if defined($config->{from});
  271. $to = $config->{to} if defined($config->{to});
  272. $count = $config->{count} if defined($config->{count});
  273. $offset = $config->{offset} if defined($config->{offset});
  274. return if $offset and not $count;
  275. if ($offset > 0) {
  276. $offset -= ($count < 0);
  277. } elsif ($offset < 0) {
  278. $offset = $#$data + ($count > 0) + $offset;
  279. } else {
  280. $offset = $#$data if $count < 0;
  281. }
  282. my $start = my $end = $offset;
  283. $start += $count+1 if $count < 0;
  284. $end += $count-1 if $count > 0;
  285. return unless __sanity_check_range( $data, \$from, \$to,
  286. \$since, \$until,
  287. \$start, \$end );
  288. unless (length($from) or length($to) or length($since) or length($until)
  289. or $start or $end)
  290. {
  291. return [ @$data ] if $config->{default_all} and not $count;
  292. return [ $data->[0] ];
  293. }
  294. return [ @{$data}[$start .. $end] ] if $start or $end;
  295. my @result;
  296. my $include = 1;
  297. $include = 0 if length($to) or length($until);
  298. foreach (@$data) {
  299. my $v = $_->{Version};
  300. $include = 1 if $v eq $to;
  301. last if $v eq $since;
  302. push @result, $_ if $include;
  303. $include = 1 if $v eq $until;
  304. last if $v eq $from;
  305. }
  306. return \@result if scalar(@result);
  307. return undef;
  308. }
  309. sub _abort_early {
  310. my ($self) = @_;
  311. my $data = $self->data or return;
  312. my $config = $self->{config} or return;
  313. # use Data::Dumper;
  314. # warn "Abort early? (\$# = $#$data)\n".Dumper($config);
  315. return if $config->{all};
  316. my ($since, $until, $from, $to, $count, $offset) = ('', '', '', '', 0, 0);
  317. $since = $config->{since} if defined($config->{since});
  318. $until = $config->{until} if defined($config->{until});
  319. $from = $config->{from} if defined($config->{from});
  320. $to = $config->{to} if defined($config->{to});
  321. $count = $config->{count} if defined($config->{count});
  322. $offset = $config->{offset} if defined($config->{offset});
  323. return if $offset and not $count;
  324. return if $offset < 0 or $count < 0;
  325. if ($offset > 0) {
  326. $offset -= ($count < 0);
  327. }
  328. my $start = my $end = $offset;
  329. $end += $count-1 if $count > 0;
  330. unless (length($from) or length($to) or length($since) or length($until)
  331. or $start or $end)
  332. {
  333. return if not $count;
  334. return 1 if @$data;
  335. }
  336. return 1 if ($start or $end)
  337. and $start < @$data and $end < @$data;
  338. return unless length($since) or length($from);
  339. foreach (@$data) {
  340. my $v = $_->{Version};
  341. return 1 if $v eq $since;
  342. return 1 if $v eq $from;
  343. }
  344. return;
  345. }
  346. =pod
  347. =head3 dpkg
  348. (and B<dpkg_str>)
  349. C<dpkg> returns a hash (in list context) or a hash reference
  350. (in scalar context) where the keys are field names and the values are
  351. field values. The following fields are given:
  352. =over 4
  353. =item Source
  354. package name (in the first entry)
  355. =item Version
  356. packages' version (from first entry)
  357. =item Distribution
  358. target distribution (from first entry)
  359. =item Urgency
  360. urgency (highest of all printed entries)
  361. =item Maintainer
  362. person that created the (first) entry
  363. =item Date
  364. date of the (first) entry
  365. =item Closes
  366. bugs closed by the entry/entries, sorted by bug number
  367. =item Changes
  368. content of the the entry/entries
  369. =back
  370. C<dpkg_str> returns a stringified version of this hash. The fields are
  371. ordered like in the list above.
  372. Both methods support the common output options described in
  373. section L<"COMMON OUTPUT OPTIONS">.
  374. =head3 dpkg_str
  375. See L<dpkg>.
  376. =cut
  377. our ( @CHANGELOG_FIELDS, $CHANGELOG_FIELDS );
  378. our ( @URGENCIES, %URGENCIES );
  379. BEGIN {
  380. @CHANGELOG_FIELDS = qw(Source Version Distribution
  381. Urgency Maintainer Date Closes Changes
  382. Timestamp Header Items Trailer
  383. BlankAfterHeader BlankAfterChanges
  384. BlankAfterTrailer
  385. Urgency_comment Urgency_lc);
  386. $CHANGELOG_FIELDS = Dpkg::Control->new(type => CTRL_CHANGELOG);
  387. %$CHANGELOG_FIELDS = map { $_ => 1 } @CHANGELOG_FIELDS;
  388. @URGENCIES = qw(low medium high critical emergency);
  389. my $i = 1;
  390. %URGENCIES = map { $_ => $i++ } @URGENCIES;
  391. }
  392. sub dpkg {
  393. my ($self, $config) = @_;
  394. $self->{config}{DPKG} = $config if $config;
  395. $config = $self->{config}{DPKG} || {};
  396. my $data = $self->_data_range( $config ) or return undef;
  397. my $f = new Dpkg::Changelog::Entry;
  398. foreach my $field (qw( Urgency Source Version
  399. Distribution Maintainer Date )) {
  400. $f->{$field} = $data->[0]{$field};
  401. }
  402. # handle unknown fields
  403. foreach my $field (keys %{$data->[0]}) {
  404. next if $CHANGELOG_FIELDS->{$field};
  405. $f->{$field} = $data->[0]{$field};
  406. }
  407. $f->{Changes} = get_dpkg_changes( $data->[0] );
  408. $f->{Closes} = [ @{$data->[0]{Closes}} ];
  409. my $first = 1; my $urg_comment = '';
  410. foreach my $entry (@$data) {
  411. $first = 0, next if $first;
  412. my $oldurg = $f->{Urgency} || '';
  413. my $oldurgn = $URGENCIES{$f->{Urgency}} || -1;
  414. my $newurg = $entry->{Urgency_lc} || '';
  415. my $newurgn = $URGENCIES{$entry->{Urgency_lc}} || -1;
  416. $f->{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg;
  417. $urg_comment .= $entry->{Urgency_comment};
  418. $f->{Changes} .= "\n .".get_dpkg_changes( $entry );
  419. push @{$f->{Closes}}, @{$entry->{Closes}};
  420. # handle unknown fields
  421. foreach my $field (keys %$entry) {
  422. next if $CHANGELOG_FIELDS->{$field};
  423. next if exists $f->{$field};
  424. $f->{$field} = $entry->{$field};
  425. }
  426. }
  427. $f->{Closes} = join " ", sort { $a <=> $b } @{$f->{Closes}};
  428. $f->{Urgency} .= $urg_comment;
  429. run_vendor_hook("post-process-changelog-entry", $f);
  430. return %$f if wantarray;
  431. return $f;
  432. }
  433. sub dpkg_str {
  434. return data2rfc822(scalar dpkg(@_));
  435. }
  436. =pod
  437. =head3 rfc822
  438. (and B<rfc822_str>)
  439. C<rfc822> returns an array of hashes (in list context) or a reference
  440. to this array (in scalar context) where each hash represents one entry
  441. in the changelog. For the format of such a hash see the description
  442. of the L<"dpkg"> method (while ignoring the remarks about which
  443. values are taken from the first entry).
  444. C<rfc822_str> returns a stringified version of this array.
  445. Both methods support the common output options described in
  446. section L<"COMMON OUTPUT OPTIONS">.
  447. =head3 rfc822_str
  448. See L<rfc822>.
  449. =cut
  450. sub rfc822 {
  451. my ($self, $config) = @_;
  452. $self->{config}{RFC822} = $config if $config;
  453. $config = $self->{config}{RFC822} || {};
  454. my $data = $self->_data_range( $config ) or return undef;
  455. my @out_data;
  456. foreach my $entry (@$data) {
  457. my $f = new Dpkg::Changelog::Entry;
  458. foreach my $field (qw( Urgency Source Version
  459. Distribution Maintainer Date )) {
  460. $f->{$field} = $entry->{$field};
  461. }
  462. $f->{Urgency} .= $entry->{Urgency_Comment};
  463. $f->{Changes} = get_dpkg_changes( $entry );
  464. $f->{Closes} = join " ", sort { $a <=> $b } @{$entry->{Closes}};
  465. # handle unknown fields
  466. foreach my $field (keys %$entry) {
  467. next if $CHANGELOG_FIELDS->{$field};
  468. $f->{$field} = $entry->{$field};
  469. }
  470. run_vendor_hook("post-process-changelog-entry", $f);
  471. push @out_data, $f;
  472. }
  473. return @out_data if wantarray;
  474. return \@out_data;
  475. }
  476. sub rfc822_str {
  477. return data2rfc822(scalar rfc822(@_));
  478. }
  479. =pod
  480. =head1 COMMON OUTPUT OPTIONS
  481. The following options are supported by all output methods,
  482. all take a version number as value:
  483. =over 4
  484. =item since
  485. Causes changelog information from all versions strictly
  486. later than B<version> to be used.
  487. =item until
  488. Causes changelog information from all versions strictly
  489. earlier than B<version> to be used.
  490. =item from
  491. Similar to C<since> but also includes the information for the
  492. specified B<version> itself.
  493. =item to
  494. Similar to C<until> but also includes the information for the
  495. specified B<version> itself.
  496. =back
  497. The following options are also supported by all output methods but
  498. don't take version numbers as values:
  499. =over 4
  500. =item all
  501. If set to a true value, all entries of the changelog are returned,
  502. this overrides all other options.
  503. =item count
  504. Expects a signed integer as value. Returns C<value> entries from the
  505. top of the changelog if set to a positive integer, and C<abs(value)>
  506. entries from the tail if set to a negative integer.
  507. =item offset
  508. Expects a signed integer as value. Changes the starting point for
  509. C<count>, either counted from the top (positive integer) or from
  510. the tail (negative integer). C<offset> has no effect if C<count>
  511. wasn't given as well.
  512. =back
  513. Some examples for the above options. Imagine an example changelog with
  514. entries for the versions 1.2, 1.3, 2.0, 2.1, 2.2, 3.0 and 3.1.
  515. Call Included entries
  516. C<E<lt>formatE<gt>({ since =E<gt> '2.0' })> 3.1, 3.0, 2.2
  517. C<E<lt>formatE<gt>({ until =E<gt> '2.0' })> 1.3, 1.2
  518. C<E<lt>formatE<gt>({ from =E<gt> '2.0' })> 3.1, 3.0, 2.2, 2.1, 2.0
  519. C<E<lt>formatE<gt>({ to =E<gt> '2.0' })> 2.0, 1.3, 1.2
  520. C<E<lt>formatE<gt>({ count =E<gt> 2 }>> 3.1, 3.0
  521. C<E<lt>formatE<gt>({ count =E<gt> -2 }>> 1.3, 1.2
  522. C<E<lt>formatE<gt>({ count =E<gt> 3,
  523. offset=E<gt> 2 }>> 2.2, 2.1, 2.0
  524. C<E<lt>formatE<gt>({ count =E<gt> 2,
  525. offset=E<gt> -3 }>> 2.0, 1.3
  526. C<E<lt>formatE<gt>({ count =E<gt> -2,
  527. offset=E<gt> 3 }>> 3.0, 2.2
  528. C<E<lt>formatE<gt>({ count =E<gt> -2,
  529. offset=E<gt> -3 }>> 2.2, 2.1
  530. Any combination of one option of C<since> and C<from> and one of
  531. C<until> and C<to> returns the intersection of the two results
  532. with only one of the options specified.
  533. =head1 UTILITY FUNCTIONS
  534. =head3 find_closes
  535. Takes one string as argument and finds "Closes: #123456, #654321" statements
  536. as supported by the Debian Archive software in it. Returns all closed bug
  537. numbers in an array reference.
  538. =cut
  539. sub find_closes {
  540. my $changes = shift;
  541. my @closes = ();
  542. while ($changes &&
  543. ($changes =~ /closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*/ig)) {
  544. push(@closes, $& =~ /\#?\s?(\d+)/g);
  545. }
  546. @closes = sort { $a <=> $b } @closes;
  547. return \@closes;
  548. }
  549. =pod
  550. =head3 data2rfc822
  551. Takes a single argument, either a Dpkg::Changelog::Entry object
  552. or a reference to an array of such objects.
  553. Returns the data in RFC822 format as string.
  554. =cut
  555. sub data2rfc822 {
  556. my ($data) = @_;
  557. if (ref($data) eq "ARRAY") {
  558. my @rfc822 = ();
  559. foreach my $entry (@$data) {
  560. push @rfc822, data2rfc822($entry);
  561. }
  562. return join "\n", @rfc822;
  563. } elsif (ref($data)) {
  564. my $rfc822_str = $data->output;
  565. return $rfc822_str;
  566. } else {
  567. return;
  568. }
  569. }
  570. =pod
  571. =head3 get_dpkg_changes
  572. Takes a Dpkg::Changelog::Entry object as first argument.
  573. Returns a string that is suitable for using it in a C<Changes> field
  574. in the output format of C<dpkg-parsechangelog>.
  575. =cut
  576. sub get_dpkg_changes {
  577. my $entry = shift;
  578. $entry->{Header} =~ s/\s+$// if defined $entry->{Header};
  579. my $changes = "\n " . ($entry->{Header} || '') . "\n .\n";
  580. foreach my $line (@{$entry->{Changes}}) {
  581. $line =~ s/\s+$//;
  582. if ($line eq "") {
  583. $changes .= " .\n";
  584. } else {
  585. $changes .= " $line\n";
  586. }
  587. }
  588. chomp $changes;
  589. return $changes;
  590. }
  591. =pod
  592. =head3 my $fields = parse_changelog(%opt)
  593. This function will parse a changelog. In list context, it return as many
  594. Dpkg::Control object as the parser did output. In scalar context, it will
  595. return only the first one. If the parser didn't return any data, it will
  596. return an empty in list context or undef on scalar context. If the parser
  597. failed, it will die.
  598. The parsing itself is done by an external program (searched in the
  599. following list of directories: $opt{libdir},
  600. /usr/local/lib/dpkg/parsechangelog, /usr/lib/dpkg/parsechangelog) That
  601. program is named according to the format that it's able to parse. By
  602. default it's either "debian" or the format name lookep up in the 40 last
  603. lines of the changelog itself (extracted with this perl regular expression
  604. "\schangelog-format:\s+([0-9a-z]+)\W"). But it can be overriden
  605. with $opt{changelogformat}. The program expects the content of the
  606. changelog file on its standard input.
  607. The changelog file that is parsed is debian/changelog by default but it
  608. can be overriden with $opt{file}.
  609. All the other keys in %opt are forwarded as parameter to the external
  610. parser. If the key starts with "-", it's passed as is. If not, it's passed
  611. as "--<key>". If the value of the corresponding hash entry is defined, then
  612. it's passed as the parameter that follows.
  613. =cut
  614. sub parse_changelog {
  615. my (%options) = @_;
  616. my @parserpath = ("/usr/local/lib/dpkg/parsechangelog",
  617. "$dpkglibdir/parsechangelog",
  618. "/usr/lib/dpkg/parsechangelog");
  619. my $format = "debian";
  620. my $changelogfile = "debian/changelog";
  621. my $force = 0;
  622. # Extract and remove options that do not concern the changelog parser
  623. # itself (and that we shouldn't forward)
  624. if (exists $options{"libdir"}) {
  625. unshift @parserpath, $options{"libdir"};
  626. delete $options{"libdir"};
  627. }
  628. if (exists $options{"file"}) {
  629. $changelogfile = $options{"file"};
  630. delete $options{"file"};
  631. }
  632. if (exists $options{"changelogformat"}) {
  633. $format = $options{"changelogformat"};
  634. delete $options{"changelogformat"};
  635. $force = 1;
  636. }
  637. # XXX: For compatibility with old parsers, don't use --since but -v
  638. # This can be removed later (in lenny+1 for example)
  639. if (exists $options{"since"}) {
  640. my $since = $options{"since"};
  641. $options{"-v$since"} = undef;
  642. delete $options{"since"};
  643. }
  644. # Extract the format from the changelog file if possible
  645. unless($force or ($changelogfile eq "-")) {
  646. open(P, "-|", "tail", "-n", "40", $changelogfile);
  647. while(<P>) {
  648. $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/;
  649. }
  650. close(P) or subprocerr(_g("tail of %s"), $changelogfile);
  651. }
  652. # Find the right changelog parser
  653. my $parser;
  654. foreach my $dir (@parserpath) {
  655. my $candidate = "$dir/$format";
  656. next if not -e $candidate;
  657. if (-x _) {
  658. $parser = $candidate;
  659. last;
  660. } else {
  661. warning(_g("format parser %s not executable"), $candidate);
  662. }
  663. }
  664. error(_g("changelog format %s is unknown"), $format) if not defined $parser;
  665. # Create the arguments for the changelog parser
  666. my @exec = ($parser, "-l$changelogfile");
  667. foreach (keys %options) {
  668. if (m/^-/) {
  669. # Options passed untouched
  670. push @exec, $_;
  671. } else {
  672. # Non-options are mapped to long options
  673. push @exec, "--$_";
  674. }
  675. push @exec, $options{$_} if defined($options{$_});
  676. }
  677. # Fork and call the parser
  678. my $pid = open(P, "-|");
  679. syserr(_g("fork for %s"), $parser) unless defined $pid;
  680. if (not $pid) {
  681. if ($changelogfile ne "-") {
  682. open(STDIN, "<", $changelogfile) or
  683. syserr(_g("cannot open %s"), $changelogfile);
  684. }
  685. exec(@exec) || syserr(_g("cannot exec format parser: %s"), $parser);
  686. }
  687. # Get the output into several Dpkg::Control objects
  688. my (@res, $fields);
  689. while (1) {
  690. $fields = Dpkg::Control->new(type => CTRL_CHANGELOG);
  691. last unless $fields->parse_fh(\*P, _g("output of changelog parser"));
  692. push @res, $fields;
  693. }
  694. close(P) or subprocerr(_g("changelog parser %s"), $parser);
  695. if (wantarray) {
  696. return @res;
  697. } else {
  698. return $res[0] if (@res);
  699. return undef;
  700. }
  701. }
  702. =head1 NAME
  703. Dpkg::Changelog::Entry - represents one entry in a Debian changelog
  704. =head1 SYNOPSIS
  705. FIXME: to be written
  706. =head1 DESCRIPTION
  707. =cut
  708. package Dpkg::Changelog::Entry;
  709. use Dpkg::Control;
  710. use base qw(Dpkg::Control);
  711. sub new {
  712. my ($classname) = @_;
  713. my $entry = Dpkg::Control->new(type => CTRL_CHANGELOG);
  714. $entry->set_output_order(@CHANGELOG_FIELDS);
  715. bless $entry, $classname;
  716. }
  717. sub is_empty {
  718. my ($self) = @_;
  719. return !($self->{Changes}
  720. || $self->{Source}
  721. || $self->{Version}
  722. || $self->{Maintainer}
  723. || $self->{Date});
  724. }
  725. 1;
  726. __END__
  727. =head1 AUTHOR
  728. Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt>
  729. =head1 COPYRIGHT AND LICENSE
  730. Copyright E<copy> 2005, 2007 by Frank Lichtenheld
  731. Copyright E<copy> 2009 by Raphael Hertzog
  732. This program is free software; you can redistribute it and/or modify
  733. it under the terms of the GNU General Public License as published by
  734. the Free Software Foundation; either version 2 of the License, or
  735. (at your option) any later version.
  736. This program is distributed in the hope that it will be useful,
  737. but WITHOUT ANY WARRANTY; without even the implied warranty of
  738. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  739. GNU General Public License for more details.
  740. You should have received a copy of the GNU General Public License
  741. along with this program; if not, write to the Free Software
  742. Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
  743. =cut