File Coverage

blib/lib/DhMakePerl/Command/make.pm
Criterion Covered Total %
statement 11 11 100.0
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 15 15 100.0


line stmt bran cond sub pod time code
1             package DhMakePerl::Command::make;
2              
3 3     3   26449353 use warnings;
  3         7  
  3         185  
4 3     3   21 use strict;
  3         12  
  3         161  
5             our $VERSION = '0.84';
6 3     3   166 use 5.010; # we use smart matching
  3         10  
7              
8 3     3   24 use base 'DhMakePerl::Command::Packaging';
  3         7  
  3         2492  
9              
10             __PACKAGE__->mk_accessors(
11             qw(
12             cfg apt_contents main_dir debian_dir meta
13             perlname version pkgversion
14             copyright author
15             extrasfields extrapfields
16             docs examples
17             )
18             );
19              
20             =head1 NAME
21              
22             DhMakePerl::Command::make - implementation of 'dh-make-perl make'
23              
24             =cut
25              
26             =head1 SYNOPSIS
27              
28             TO BE FILLED
29              
30             use DhMakePerl;
31              
32             my $foo = DhMakePerl->new();
33             ...
34              
35             =head1 METHODS
36              
37             =over
38              
39             =cut
40              
41             use AptPkg::Cache ();
42             use CPAN ();
43             use Cwd qw( realpath );
44             use Debian::Dependencies ();
45             use Debian::Dependency ();
46             use Debian::WNPP::Query;
47             use DhMakePerl::Utils qw(
48             find_cpan_module find_cpan_distribution
49             is_core_module );
50             use Email::Date::Format qw(email_date);
51             use File::Basename qw( basename dirname );
52             use File::Copy qw( copy move );
53             use File::Path ();
54             use File::Spec::Functions qw( catdir catfile updir );
55             use Module::Depends ();
56             use Module::Metadata;
57             use Text::Wrap qw( wrap );
58              
59             sub check_deprecated_overrides {
60             my $self = shift;
61              
62             my $overrides = catfile( $self->cfg->data_dir, 'overrides' );
63              
64             if ( -e $overrides ) {
65             warn "*** deprecated overrides file ignored\n";
66             warn "***\n";
67             warn "*** Overrides mechanism is deprecated in dh-make-perl 0.65\n";
68             warn "*** You may want to remove $overrides\n";
69             }
70             }
71              
72             sub execute {
73             my ( $self, $already_done ) = @_;
74              
75             die "CPANPLUS support disabled, sorry" if $self->cfg->cpanplus;
76              
77             $self->check_deprecated_overrides;
78              
79             my $tarball = $self->setup_dir();
80             $self->process_meta;
81             $self->findbin_fix();
82              
83             $self->extract_basic();
84              
85             $tarball //= $self->guess_debian_tarball if $self->cfg->{vcs} eq 'git';
86              
87             unless ( defined $self->cfg->version ) {
88             $self->pkgversion( $self->version . '-1' );
89             }
90             else {
91             $self->pkgversion( $self->cfg->version );
92             }
93              
94             $self->fill_maintainer;
95              
96             my $bin = $self->control->binary_tie->Values(0);
97             $bin->short_description( $self->cfg->desc )
98             if $self->cfg->desc;
99              
100             if ( $tarball and $tarball =~ /(?:\.tar\.gz|\.tgz)$/ ) {
101             my $dest = sprintf( "%s/%s_%s.orig.tar.gz",
102             dirname($tarball), $self->pkgname, $self->version );
103              
104             move( $tarball, $dest ) or die "move($tarball, $dest): $!";
105              
106             $tarball = $dest;
107             }
108              
109             # Here I init the git repo. If the upstream has a debian/ directory, this is
110             # removed in a separate git commit
111             $self->git_import_upstream__init_debian
112             if $self->cfg->{vcs} eq 'git';
113              
114             # if the upstream has a debian/ directory, rename it to debian.bak so that
115             # dh-make-perl can create its own debian/ directory. If we're creating a git
116             # repo, the original debian/ directory was already dealt with by
117             # git_import_upstream__init_debian()
118             if ( -d $self->debian_dir ) {
119             $self->warning( $self->debian_dir . ' already exists' );
120             my $bak = $self->debian_dir . '.bak';
121             $self->warning( "moving to $bak" );
122             if ( -d $bak ) {
123             $self->warning("overwriting existing $bak");
124             File::Path::rmtree($bak);
125             }
126             rename $self->debian_dir, $bak or die $!;
127             }
128              
129             my $apt_contents = $self->get_apt_contents;
130             my $src = $self->control->source;
131              
132             $src->Testsuite('autopkgtest-pkg-perl') if $self->cfg->{pkg_perl};
133              
134             my @missing = $self->discover_dependencies;
135              
136             $bin->Depends->add( $self->cfg->depends )
137             if $self->cfg->depends;
138              
139             $src->Build_Depends->add( $self->cfg->bdepends )
140             if $self->cfg->bdepends;
141              
142             $src->Build_Depends_Indep->add( $self->cfg->bdependsi )
143             if $self->cfg->bdependsi;
144              
145             $self->extract_docs;
146             $self->extract_examples;
147              
148             die "Cannot find a description for the package: use the --desc switch\n"
149             unless $bin->short_description;
150              
151             print "Package does not provide a long description - ",
152             " Please fill it in manually.\n"
153             if ( !defined $bin->long_description
154             or $bin->long_description =~ /^\s*\.?\s*$/ )
155             and $self->cfg->verbose;
156              
157             printf( "Using maintainer: %s\n", $src->Maintainer )
158             if $self->cfg->verbose;
159              
160             print "Found docs: @{ $self->docs }\n" if $self->cfg->verbose;
161             print "Found examples: @{ $self->examples }\n"
162             if @{ $self->examples } and $self->cfg->verbose;
163              
164             # start writing out the data
165             mkdir( $self->debian_dir, 0755 )
166             || die "Cannot create " . $self->debian_dir . " dir: $!\n";
167             $self->write_source_format(
168             catfile( $self->debian_dir, 'source', 'format' ) );
169             $self->create_changelog( $self->debian_file('changelog'),
170             $self->cfg->closes // $self->get_wnpp( $self->pkgname ) );
171             $self->create_rules;
172              
173             # now that rules are there, see if we need some dependency for them
174             $self->discover_utility_deps( $self->control );
175             $self->control->prune_perl_deps;
176             $self->prune_deps;
177             $src->Standards_Version( $self->debstdversion );
178             $src->Homepage( $self->upsurl );
179             if ( $self->cfg->pkg_perl ) {
180             my $vcs = lc( $self->cfg->vcs );
181             if ( $vcs eq 'svn' ) {
182             $self->control->source->Vcs_Svn(
183             sprintf( "svn://svn.debian.org/pkg-perl/trunk/%s/",
184             $self->pkgname )
185             );
186             $self->control->source->Vcs_Browser(
187             sprintf( "http://anonscm.debian.org/viewvc/pkg-perl/trunk/%s/",
188             $self->pkgname )
189             );
190             }
191             elsif ( $vcs eq 'git' ) {
192             $self->control->source->Vcs_Git(
193             sprintf( "git://anonscm.debian.org/pkg-perl/packages/%s.git",
194             $self->pkgname )
195             );
196             $self->control->source->Vcs_Browser(
197             sprintf( "https://anonscm.debian.org/cgit/pkg-perl/packages/%s.git",
198             $self->pkgname )
199             );
200             }
201             else {
202             warn "Version control system '$vcs' not known. Please submit a patch :)\n";
203             }
204             }
205             $self->control->write( $self->debian_file('control') );
206              
207             $self->create_compat( $self->debian_file('compat') );
208             $self->create_watch( $self->debian_file('watch') );
209              
210             #create_readme("$debiandir/README.Debian");
211             $self->create_copyright( $self->debian_file('copyright') );
212             $self->update_file_list( docs => $self->docs, examples => $self->examples );
213              
214             $self->create_upstream_metadata;
215              
216             if ( $self->cfg->recursive ) {
217             $already_done //= {};
218             my $mod_name = $self->perlname;
219             $mod_name =~ s/-/::/g;
220             $already_done->{$mod_name} = 1;
221              
222             for my $m (@missing) {
223             next if exists $already_done->{$m};
224              
225             if ( $self->cfg->verbose ) {
226             print "\n";
227             print "==================================\n";
228             print " recursively building $m\n";
229             print "==================================\n";
230             }
231              
232             my $new_cfg
233             = DhMakePerl::Config->new( { %{ $self->cfg }, cpan => $m, } );
234             my $maker = $self->new( { cfg => $new_cfg } );
235             $maker->execute($already_done)
236             }
237             }
238              
239             $self->git_add_debian($tarball)
240             if $self->cfg->{vcs} eq 'git';
241              
242             $self->build_source_package
243             if $self->cfg->build_source;
244             $self->build_package
245             if $self->cfg->build or $self->cfg->install;
246             $self->install_package if $self->cfg->install;
247             print "--- Done\n" if $self->cfg->verbose;
248              
249             $self->package_already_exists($apt_contents)
250             or $self->modules_already_packaged($apt_contents);
251              
252             # explicitly call Debian::Rules destroy
253             # this is needed because after the rename the object's
254             # destroy method would update a file on a stale path
255             $self->rules( undef );
256             $self->rename_to_debian_package_dir;
257              
258             return(0);
259             }
260              
261             sub guess_debian_tarball {
262             my $self = shift;
263              
264             my $prefix = catfile( $self->main_dir, '..',
265             $self->control->source->Source . '_'
266             . $self->version
267             . '.orig' );
268             $self->guess_tarball($prefix);
269             }
270              
271             sub guess_tarball {
272             my $self = shift;
273             my $prefix = shift;
274             die "guess_tarball(): Needs everything except the file type suffix as parameter"
275             unless defined $prefix;
276              
277             foreach my $compression_suffix (qw(gz bz2 xz lzma)) {
278             my $try = "$prefix.tar.$compression_suffix";
279              
280             print "Trying $try...";
281             if ( -f $try ) {
282             print " found!\n";
283             return $try;
284             }
285             else {
286             print " not found.\n";
287             }
288             }
289             return undef;
290             }
291              
292             sub setup_dir {
293             my ($self) = @_;
294              
295             my ( $tarball );
296             if ( $self->cfg->cpan ) {
297             my ( $new_maindir, $orig_pwd, $mod, $dist );
298              
299             # CPAN::Distribution::get() sets $ENV{'PWD'} to $CPAN::Config->{build_dir}
300             # so we have to save it here
301             $orig_pwd = $ENV{'PWD'};
302              
303             # Is the module a core module?
304             if ( is_core_module( $self->cfg->cpan ) ) {
305             die $self->cfg->cpan
306             . " is a standard module. Will not build without --core-ok.\n"
307             unless $self->cfg->core_ok;
308             }
309              
310             $self->configure_cpan;
311              
312             if ( $mod = find_cpan_module( $self->cfg->cpan ) ) {
313             $self->mod_cpan_version( $mod->cpan_version );
314              
315             $dist = $CPAN::META->instance( 'CPAN::Distribution',
316             $mod->cpan_file );
317             }
318             elsif ( $dist = find_cpan_distribution( $self->cfg->cpan ) ) {
319             my $ver;
320             if ( $dist->base_id =~ /-v?(\d[\d._]*)\./ ) {
321             $self->mod_cpan_version($1);
322             }
323             else {
324             die "Unable to determine the version of "
325             . $dist->base_id . "\n";
326             }
327             }
328             else {
329             die "Can't find '"
330             . $self->cfg->cpan
331             . "' module or distribution on CPAN\n";
332             }
333              
334             $dist->get; # <- here $ENV{'PWD'} gets set to $HOME/.cpan/build
335             chdir $orig_pwd; # so set it back
336             $dist->pretty_id =~ /^(.)(.)/;
337             $tarball = $CPAN::Config->{'keep_source_where'} . "/authors/id/$1/$1$2/";
338             # the file is under authors/id/A/AU/AUTHOR directory
339             # how silly there is no $dist->filename method
340              
341             $tarball .= $dist->pretty_id;
342             $self->main_dir( $dist->dir );
343              
344             copy( $tarball, $orig_pwd ) or die "copy($tarball, $orig_pwd): $!";
345             $tarball = $orig_pwd . "/" . basename($tarball);
346              
347             # build_dir contains a random part since 1.88_59
348             # use the new CPAN::Distribution::base_id (introduced in 1.91_53)
349             $new_maindir = $orig_pwd . "/" . $dist->base_id;
350              
351             # rename existing directory
352             my $new_inc;
353             my $rename_to = "$new_maindir.$$";
354             while (-d $rename_to)
355             {
356             $new_inc++;
357             $rename_to = "$new_maindir.$$-$new_inc";
358             }
359             if ( -d $new_maindir
360             && rename $new_maindir, $rename_to)
361             {
362             print '=' x 70, "\n";
363             print
364             "Unpacked tarball already existed, directory renamed to $rename_to\n";
365             print '=' x 70, "\n";
366             }
367             system( "mv", $self->main_dir, "$new_maindir" ) == 0
368             or die "Failed to move " . $self->main_dir . " to $new_maindir: $!";
369             $self->main_dir($new_maindir);
370              
371             }
372             elsif ( $self->cfg->cpanplus ) {
373             die "CPANPLUS support is b0rken at the moment.";
374              
375             # my ($cb, $href, $file);
376              
377             # eval "use CPANPLUS 0.045;";
378             # $cb = CPANPLUS::Backend->new(conf => {debug => 1, verbose => 1});
379             # $href = $cb->fetch( modules => [ $self->cfg->cpanplus ], fetchdir => $ENV{'PWD'});
380             # die "Cannot get " . $self->cfg->cpanplus . "\n" if keys(%$href) != 1;
381             # $file = (values %$href)[0];
382             # print $file, "\n\n";
383             # $self->main_dir(
384             # $cb->extract( files => [ $file ], extractdir => $ENV{'PWD'} )->{$file}
385             # );
386             }
387             else {
388             my $maindir = realpath( shift(@ARGV) || '.' );
389             $maindir =~ s/\/$//;
390             $self->main_dir($maindir);
391             my $guessed_tarball_prefix = catfile( $self->main_dir, "..",
392             basename( $self->main_dir ) );
393              
394             $tarball = $self->guess_tarball($guessed_tarball_prefix);
395             }
396             return $tarball;
397             }
398              
399             sub build_package {
400             my ( $self ) = @_;
401              
402             my $main_dir = $self->main_dir;
403             # uhmf! dpkg-genchanges doesn't cope with the deb being in another dir..
404             #system("dpkg-buildpackage -b -us -uc " . $self->cfg->dbflags) == 0
405             system("fakeroot make -C $main_dir -f debian/rules clean");
406             system("make -C $main_dir -f debian/rules build") == 0
407             || die "Cannot create deb package: 'debian/rules build' failed.\n";
408             system("fakeroot make -C $main_dir -f debian/rules binary") == 0
409             || die "Cannot create deb package: 'fakeroot debian/rules binary' failed.\n";
410             }
411              
412             sub build_source_package {
413             my ( $self ) = @_;
414              
415             my $main_dir = $self->main_dir;
416             # uhmf! dpkg-genchanges doesn't cope with the deb being in another dir..
417             #system("dpkg-buildpackage -S -us -uc " . $self->cfg->dbflags) == 0
418             system("fakeroot make -C $main_dir -f debian/rules clean");
419             system("dpkg-source -b $main_dir") == 0
420             || die "Cannot create source package: 'dpkg-source -b' failed.\n";
421             }
422              
423             sub install_package {
424             my ($self) = @_;
425              
426             my ( $archspec, $debname );
427              
428             my $arch = $self->control->binary_tie->Values(0)->Architecture;
429              
430             if ( !defined $arch || $arch eq 'any' ) {
431             $archspec = `dpkg --print-architecture`;
432             chomp($archspec);
433             }
434             else {
435             $archspec = $arch;
436             }
437              
438             $debname = sprintf( "%s_%s-1_%s.deb", $self->pkgname, $self->version,
439             $archspec );
440              
441             my $deb = $self->main_dir . "/../$debname";
442             my $dpkg_cmd = "dpkg -i $deb";
443             $dpkg_cmd = "sudo $dpkg_cmd" if $>;
444             $self->info("Running '$dpkg_cmd'...");
445             system($dpkg_cmd) == 0
446             || die "Cannot install package $deb\n";
447             }
448              
449             sub findbin_fix {
450             my ($self) = @_;
451              
452             # FindBin requires to know the name of the invoker - and requires it to be
453             # Makefile.PL to function properly :-/
454             $0 = $self->makefile_pl();
455             if ( exists $FindBin::{Bin} ) {
456             FindBin::again();
457             }
458             }
459              
460             # finds the list of modules that the distribution depends on
461             # if $build_deps is true, returns build-time dependencies, otherwise
462             # returns run-time dependencies
463             sub run_depends {
464             my ( $self, $depends_module, $build_deps ) = @_;
465              
466             no warnings;
467             local *STDERR;
468             open( STDERR, ">/dev/null" );
469             my $mod_dep = $depends_module->new();
470              
471             $mod_dep->dist_dir( $self->main_dir );
472             $mod_dep->find_modules();
473              
474             my $deps = $build_deps ? $mod_dep->build_requires : $mod_dep->requires;
475              
476             my $error = $mod_dep->error();
477             die "Error: $error\n" if $error;
478              
479             return $deps;
480             }
481              
482             # filter @deps to contain only one instance of each package
483             # say we have te following list of dependencies:
484             # libppi-perl, libppi-perl (>= 3.0), libarm-perl, libalpa-perl, libarm-perl (>= 2)
485             # we want a clean list instead:
486             # libalpa-perl, libarm-perl (>= 2), libppi-perl (>= 3.0)
487             sub prune_deps(@) {
488             my $self = shift;
489              
490             my %deps;
491             for (@_) {
492             my $p = $_->pkg;
493             my $v = $_->ver;
494             if ( exists $deps{$p} ) {
495             my $cur_ver = $deps{$p};
496              
497             $deps{$p} = $v
498             if defined($v)
499             and ( not defined($cur_ver)
500             or $cur_ver < $v );
501             }
502             else {
503             $deps{$p} = $v;
504             }
505              
506             }
507              
508             return map( Debian::Dependency->new( $_, $deps{$_} ), sort( keys(%deps) ) );
509             }
510              
511             sub create_changelog {
512             my ( $self, $file, $bug ) = @_;
513              
514             my $fh = $self->_file_w($file);
515              
516             my $closes = $bug ? " (Closes: #$bug)" : '';
517             my $changelog_dist = $self->cfg->pkg_perl ? "UNRELEASED" : "unstable";
518              
519             $fh->printf( "%s (%s) %s; urgency=low\n",
520             $self->srcname, $self->pkgversion, $changelog_dist );
521             $fh->print("\n * Initial Release.$closes\n\n");
522             $fh->printf( " -- %s %s\n", $self->get_developer,
523             email_date(time) );
524              
525             #$fh->print("Local variables:\nmode: debian-changelog\nEnd:\n");
526             $fh->close;
527             }
528              
529             sub create_readme {
530             my ( $self, $filename ) = @_;
531              
532             my $fh = $self->_file_w($filename);
533             $fh->printf(
534             "This is the debian package for the %s module.
535             It was created by %s using dh-make-perl.
536             ", $self->perlname, $self->maintainer,
537             );
538             $fh->close;
539             }
540              
541             sub create_watch {
542             my ( $self, $filename ) = @_;
543              
544             my $fh = $self->_file_w($filename);
545              
546             my $version_re = 'v?(\d[\d.-]*)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)';
547              
548             $fh->printf( "version=3\n%s .*/%s-%s\$\n",
549             $self->upsurl, $self->perlname, $version_re );
550             $fh->close;
551             }
552              
553             sub search_pkg_perl {
554             my $self = shift;
555              
556             return undef unless $self->cfg->network;
557              
558             my $pkg = $self->pkgname;
559              
560             require LWP::UserAgent;
561             require LWP::ConnCache;
562              
563             my ( $ua, $resp );
564              
565             $ua = LWP::UserAgent->new;
566             $ua->env_proxy;
567             $ua->conn_cache( LWP::ConnCache->new );
568              
569             $resp = $ua->get(
570             "https://anonscm.debian.org/cgit/pkg-perl/packages/$pkg.git");
571             return { url => $resp->request->uri }
572             if $resp->is_success;
573              
574             $resp = $ua->get(
575             "https://anonscm.debian.org/cgit/pkg-perl/attic/$pkg.git");
576             return { url => $resp->request->uri }
577             if $resp->is_success;
578              
579             return undef;
580             }
581              
582             sub rename_to_debian_package_dir {
583             my( $self ) = @_;
584             return unless $self->cfg->cpan;
585              
586             my $maindir = $self->main_dir;
587             my $newmaindir = catdir( $maindir, updir(), $self->pkgname );
588              
589             if( -d $newmaindir ) {
590             warn "$newmaindir already exists, skipping rename";
591             return;
592             }
593              
594             rename $maindir, $newmaindir or die "rename failed: $self->main_dir to $newmaindir";
595             $self->main_dir( $newmaindir );
596             return;
597             }
598              
599             sub package_already_exists {
600             my( $self, $apt_contents ) = @_;
601              
602             my $found;
603              
604             eval {
605             my $apt_cache = AptPkg::Cache->new;
606             $found = $apt_cache->packages->lookup( $self->pkgname )
607             if $apt_cache;
608             };
609              
610             warn "Error initializing AptPkg::Cache: $@" if $@;
611              
612             if ($found) {
613             warn "**********\n";
614             warn "WARNING: a package named\n";
615             warn " '" . $self->pkgname ."'\n";
616             warn " is already available in APT repositories\n";
617             warn "Maintainer: ", $found->{Maintainer}, "\n";
618             my $short_desc = (split( /\n/, $found->{LongDesc} ))[0];
619             warn "Description: $short_desc\n";
620             }
621             elsif ($apt_contents) {
622             $found = $apt_contents->find_perl_module_package( $self->perlname );
623              
624             if ($found) {
625             ( my $mod_name = $self->perlname ) =~ s/-/::/g;
626             warn "**********\n";
627             warn "NOTICE: the package '$found', available in APT repositories\n";
628             warn " already contains a module named "
629             . $self->perlname . "\n";
630             }
631             elsif ( $found = $self->search_pkg_perl ) {
632             warn "********************\n";
633             warn sprintf(
634             "The Debian Perl Group has a repository for the %s package\n at %s\n",
635             $self->pkgname, $found->{url} );
636             warn "You may want to contact them to avoid duplication of effort.\n";
637             warn "More information is available at https://wiki.debian.org/Teams/DebianPerlGroup\n";
638             }
639             }
640             else {
641             ( my $mod_name = $self->perlname ) =~ s/-/::/g;
642             require Debian::DpkgLists;
643             my @found = Debian::DpkgLists->scan_perl_mod($mod_name);
644              
645             if (@found) {
646             warn "**********\n";
647             warn "NOTICE: the following locally installed package(s) already\n";
648             warn " contain $mod_name\n";
649             warn " ", join ( ', ', @found ), "\n";
650             $found = 1;
651             }
652             }
653              
654             return $found ? 1 : 0;
655             }
656              
657             sub modules_already_packaged {
658             my( $self, $apt_contents ) = @_;
659              
660             my @modules;
661              
662             File::Find::find(
663             sub {
664             if (basename($File::Find::dir)
665             =~ /^(?:
666             \.(?:git|svn|hg|)
667             |CVS
668             |eg|samples?|examples?
669             |t|xt
670             |inc|privinc
671             )$/x
672             )
673             {
674             $File::Find::prune = 1;
675             return;
676             }
677             if (/.+\.pm$/) {
678             my $mi = Module::Metadata->new_from_file($_);
679             push @modules, $mi->packages_inside;
680             }
681             },
682             $self->main_dir,
683             );
684              
685             my $found;
686              
687             sub show_notice($$) {
688             warn $_[0] unless $_[1];
689             $_[1] = 1;
690             }
691              
692             my $notice = <
693             *** Notice ***
694             Some of the modules in the newly created package are already present
695             in other packages.
696              
697             EOF
698             my $notice_shown = 0;
699              
700             for my $mod (@modules) {
701             if ($apt_contents) {
702             $found = $apt_contents->find_perl_module_package($mod);
703              
704             if ($found) {
705             show_notice( $notice, $notice_shown );
706             warn " $mod is in '$found' (APT)\n";
707             }
708             }
709             if ( !$found ) {
710             require Debian::DpkgLists;
711             my @found = Debian::DpkgLists->scan_perl_mod($mod);
712              
713             if (@found) {
714             show_notice( $notice, $notice_shown );
715             warn " $mod is in " . join( ', ', @found ), " (local .deb)\n";
716             $found = 1;
717             }
718             }
719             }
720              
721             warn "\n" if $notice_shown;
722              
723             return $found ? 1 : 0;
724             }
725              
726             sub reset_git_environment {
727             # The Git environment variables may be set from previous iterations
728             # of this program being run. In this case, it's possible that the
729             # Git module will use these to point to the wrong source tree.
730             delete $ENV{'GIT_DIR'};
731             delete $ENV{'GIT_WORK_TREE'};
732             }
733              
734             sub git_import_upstream__init_debian {
735             my ( $self ) = @_;
736              
737             require Git;
738              
739             $self->reset_git_environment();
740              
741             Git::command( 'init', $self->main_dir );
742              
743             my $git = Git->repository( $self->main_dir );
744             $git->command( qw(symbolic-ref HEAD refs/heads/upstream) );
745             $git->command( 'add', '.' );
746             $git->command( 'commit', '-m',
747             "Import original source of "
748             . $self->perlname . ' '
749             . $self->version );
750             $git->command( 'tag', "upstream/".$self->version, 'upstream' );
751              
752             $git->command( qw( checkout -b master upstream ) );
753             if ( -d $self->debian_dir ) {
754             # remove debian/ directory if the upstream ships it. This goes into the
755             # 'master' branch, so the 'upstream' branch contains the original debian/
756             # directory, and thus matches the pristine-tar. Here I also remove the
757             # debian/ directory from the working tree; git has the history, so I don't
758             # need the debian.bak
759             $git->command( 'rm', '-r', $self->debian_dir );
760             $git->command( 'commit', '-m',
761             'Removed debian directory embedded in upstream source' );
762             }
763             }
764              
765             sub git_add_debian {
766             my ( $self, $tarball ) = @_;
767              
768             require Git;
769             require File::Which;
770              
771             $self->reset_git_environment;
772              
773             my $git = Git->repository( $self->main_dir );
774             $git->command( 'add', 'debian' );
775             $git->command( 'commit', '-m',
776             "Initial packaging by dh-make-perl $VERSION" );
777             $git->command(
778             qw( remote add origin ),
779             sprintf( "ssh://git.debian.org/git/pkg-perl/packages/%s.git",
780             $self->pkgname ),
781             ) if $self->cfg->pkg_perl;
782              
783             if ( File::Which::which('pristine-tar') ) {
784             if ( $tarball and -f $tarball ) {
785             $ENV{GIT_DIR} = File::Spec->catdir( $self->main_dir, '.git' );
786             system( 'pristine-tar', 'commit', $tarball, "upstream/".$self->version ) >= 0
787             or warn "error running pristine-tar: $!\n";
788             }
789             else {
790             die "No tarball found to handle with pristine-tar. Bailing out."
791             }
792             }
793             else {
794             warn "W: pristine-tar not available. Please run\n";
795             warn "W: apt-get install pristine-tar\n";
796             warn "W: followed by\n";
797             warn "W: pristine-tar commit $tarball upstream/"
798             . $self->version . "\n";
799             }
800             }
801              
802             =item warning I ...
803              
804             In verbose mode, prints supplied arguments on STDERR, prepended with C and
805             suffixed with a new line.
806              
807             Does nothing in non-verbose mode.
808              
809             =cut
810              
811             sub warning {
812             my $self = shift;
813              
814             return unless $self->cfg->verbose;
815              
816             warn "W: ", @_, "\n";
817             }
818              
819             =item info I ...
820              
821             In verbose mode, prints supplied arguments on STDERR, prepended with C and
822             suffixed with a new line.
823              
824             Does nothing in non-verbose mode.
825              
826             =cut
827              
828             sub info {
829             my $self = shift;
830              
831             return unless $self->cfg->verbose;
832              
833             warn "I: ", @_, "\n";
834             }
835              
836             =back
837              
838             =head1 AUTHOR
839              
840             dh-make-perl was created by Paolo Molaro.
841              
842             It is currently maintained by Gunnar Wolf and others, under the umbrella of the
843             Debian Perl Group
844              
845             =head1 BUGS
846              
847             Please report any bugs or feature requests to the Debian Bug Tracking System
848             (L, use I as package name) or to the
849             L mailing list.
850              
851             =head1 SUPPORT
852              
853             You can find documentation for this module with the perldoc command.
854              
855             perldoc DhMakePerl
856              
857             You can also look for information at:
858              
859             =over 4
860              
861             =item * Debian Bugtracking System
862              
863             L
864              
865             =back
866              
867              
868              
869             =head1 COPYRIGHT & LICENSE
870              
871             =over 4
872              
873             =item Copyright (C) 2000, 2001 Paolo Molaro
874              
875             =item Copyright (C) 2002, 2003, 2008 Ivan Kohler
876              
877             =item Copyright (C) 2003, 2004 Marc 'HE' Brockschmidt
878              
879             =item Copyright (C) 2005-2007 Gunnar Wolf
880              
881             =item Copyright (C) 2006 Frank Lichtenheld
882              
883             =item Copyright (C) 2007-2014 Gregor Herrmann
884              
885             =item Copyright (C) 2007,2008,2009,2010,2011,2012,2015 Damyan Ivanov
886              
887             =item Copyright (C) 2008, Roberto C. Sanchez
888              
889             =item Copyright (C) 2009-2010, Salvatore Bonaccorso
890              
891             =item Copyright (C) 2013, Axel Beckert
892              
893             =back
894              
895             This program is free software; you can redistribute it and/or modify it under
896             the terms of the GNU General Public License version 2 as published by the Free
897             Software Foundation.
898              
899             This program is distributed in the hope that it will be useful, but WITHOUT ANY
900             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
901             PARTICULAR PURPOSE. See the GNU General Public License for more details.
902              
903             You should have received a copy of the GNU General Public License along with
904             this program; if not, write to the Free Software Foundation, Inc., 51 Franklin
905             Street, Fifth Floor, Boston, MA 02110-1301 USA.
906              
907             =cut
908              
909             1; # End of DhMakePerl