File Coverage

blib/lib/CPANPLUS/Dist/Slackware.pm
Criterion Covered Total %
statement 39 399 9.7
branch 0 178 0.0
condition 0 26 0.0
subroutine 13 37 35.1
pod 5 5 100.0
total 57 645 8.8


line stmt bran cond sub pod time code
1             package CPANPLUS::Dist::Slackware;
2              
3 1     1   68026 use strict;
  1         4  
  1         29  
4 1     1   6 use warnings;
  1         2  
  1         43  
5              
6             our $VERSION = '1.029';
7              
8 1     1   6 use base qw(CPANPLUS::Dist::Base);
  1         2  
  1         563  
9              
10 1     1   101226 use English qw( -no_match_vars );
  1         3717  
  1         6  
11              
12 1     1   987 use CPANPLUS::Dist::Slackware::PackageDescription;
  1         4  
  1         51  
13             use CPANPLUS::Dist::Slackware::Util
14 1     1   9 qw(can_run run catdir catfile spurt filetype gzip strip);
  1         3  
  1         88  
15 1     1   7 use CPANPLUS::Error;
  1         2  
  1         57  
16              
17 1     1   6 use Cwd qw();
  1         3  
  1         30  
18 1     1   500 use ExtUtils::Packlist;
  1         1813  
  1         33  
19 1     1   8 use File::Find qw();
  1         2  
  1         23  
20 1     1   5 use Locale::Maketext::Simple ( Style => 'gettext' );
  1         4  
  1         9  
21 1     1   800 use Module::Pluggable require => 1;
  1         8139  
  1         9  
22 1     1   112 use Params::Check qw();
  1         3  
  1         4135  
23              
24             local $Params::Check::VERBOSE = 1;
25              
26             my $NONROOT_WARNING = <<'END_NONROOT_WARNING';
27             In order to manage packages as a non-root user, which is highly recommended,
28             you must have sudo and, optionally, fakeroot.
29             END_NONROOT_WARNING
30              
31             sub format_available {
32 0     0 1   my $missing_programs_count = 0;
33 0           for my $program (
34             qw(/sbin/makepkg /sbin/installpkg /sbin/upgradepkg /sbin/removepkg))
35             {
36 0 0         if ( !can_run($program) ) {
37 0           error(
38             loc(q{You do not have '%1' -- '%2' not available}, $program,
39             __PACKAGE__
40             )
41             );
42 0           ++$missing_programs_count;
43             }
44             }
45 0           return ( $missing_programs_count == 0 );
46             }
47              
48             sub init {
49 0     0 1   my $dist = shift;
50              
51 0           my $status = $dist->status;
52              
53 0           $status->mk_accessors(qw(_pkgdesc _fakeroot_cmd _plugins));
54              
55 0           $status->_fakeroot_cmd( can_run('fakeroot') );
56              
57 0           $status->_plugins( [ grep { $_->available($dist) } $dist->plugins ] );
  0            
58              
59 0           return 1;
60             }
61              
62             sub prepare {
63 0     0 1   my ( $dist, @params ) = @_;
64              
65 0 0         my $param_ref = $dist->_parse_params(@params) or die;
66 0           my $status = $dist->status;
67 0           my $module = $dist->parent;
68              
69             my $pkgdesc = CPANPLUS::Dist::Slackware::PackageDescription->new(
70             module => $module,
71             installdirs => $param_ref->{installdirs},
72 0           );
73 0           $status->_pkgdesc($pkgdesc);
74              
75 0           $status->dist( $pkgdesc->outputname );
76              
77 0           umask oct '022';
78              
79             {
80              
81             # CPANPLUS::Dist:MM does not accept multiple options in
82             # makemakerflags. Instead, the options are passed in PERL_MM_OPT.
83             # PERL_MB_OPT requires Module::Build 0.36.
84 0           local $ENV{PERL_MM_OPT} = $dist->_perl_mm_opt;
  0            
85 0           local $ENV{PERL_MB_OPT} = $dist->_perl_mb_opt;
86 0           local $ENV{MODULEBUILDRC} = 'NONE';
87              
88             # We are not allowed to write to XML/SAX/ParserDetails.ini.
89 0           local $ENV{SKIP_SAX_INSTALL} = 1;
90              
91 0 0         $dist->_call_plugins('pre_prepare') or return;
92              
93 0 0         $dist->SUPER::prepare(@params) or return;
94              
95 0 0         $dist->_call_plugins('post_prepare') or return;
96             }
97              
98 0           return $status->prepared(1);
99             }
100              
101             sub create {
102 0     0 1   my ( $dist, @params ) = @_;
103              
104 0 0         my $param_ref = $dist->_parse_params(@params) or return;
105 0           my $status = $dist->status;
106              
107             {
108              
109             # Some tests fail if PERL_MM_OPT and PERL_MB_OPT are set during the
110             # create stage.
111 0           delete local $ENV{PERL_MM_OPT};
  0            
112 0           delete local $ENV{PERL_MB_OPT};
113 0           local $ENV{MODULEBUILDRC} = 'NONE';
114              
115 0 0         $dist->SUPER::create(@params) or return;
116              
117 0           $status->created(0);
118              
119 0 0         $dist->_fake_install($param_ref) or return;
120             }
121              
122 0 0         $dist->_compress_manual_pages($param_ref) or return;
123              
124 0 0         $dist->_install_docfiles($param_ref) or return;
125              
126 0 0         $dist->_process_installed_files($param_ref) or return;
127              
128 0 0         $dist->_make_installdir($param_ref) or return;
129              
130 0 0         $dist->_write_slack_desc($param_ref) or return;
131              
132 0 0         $dist->_call_plugins('pre_package') or return;
133              
134 0 0         $dist->_write_config_files($param_ref) or return;
135              
136 0 0         $dist->_makepkg($param_ref) or return;
137              
138 0           return $status->created(1);
139             }
140              
141             sub install {
142 0     0 1   my ( $dist, @params ) = @_;
143              
144 0 0         my $param_ref = $dist->_parse_params(@params) or return;
145 0           my $status = $dist->status;
146              
147 0 0         $dist->_installpkg($param_ref) or return;
148              
149 0           return $status->installed(1);
150             }
151              
152             sub _parse_params {
153 0     0     my ( $dist, %params ) = @_;
154              
155 0           my $module = $dist->parent;
156 0           my $cb = $module->parent;
157 0           my $conf = $cb->configure_object;
158              
159 0           my $param_ref;
160             {
161 0           local $Params::Check::ALLOW_UNKNOWN = 1;
  0            
162             my $tmpl = {
163             force => { default => $conf->get_conf('force') },
164             verbose => { default => $conf->get_conf('verbose') },
165             keep_source => { default => 0 },
166             make => { default => $conf->get_program('make') },
167             perl => { default => $EXECUTABLE_NAME },
168             installdirs => {
169 0   0       default => $ENV{INSTALLDIRS} || 'vendor',
170             allow => [ 'site', 'vendor' ]
171             },
172             };
173 0 0         $param_ref = Params::Check::check( $tmpl, \%params ) or return;
174             }
175 0           return $param_ref;
176             }
177              
178             sub _call_plugins {
179 0     0     my ( $dist, $method ) = @_;
180              
181 0           my $status = $dist->status;
182 0           my $module = $dist->parent;
183              
184 0           my $orig_dir = Cwd::cwd();
185 0 0         chdir $module->status->extract or return;
186              
187 0           for my $plugin ( @{ $status->_plugins } ) {
  0            
188 0 0         if ( $plugin->can($method) ) {
189 0 0         $plugin->$method($dist) or return;
190             }
191             }
192              
193 0 0         chdir $orig_dir or return;
194              
195 0           return 1;
196             }
197              
198             sub _perl_mm_opt {
199 0     0     my $dist = shift;
200              
201 0           my $status = $dist->status;
202 0           my $pkgdesc = $status->_pkgdesc;
203              
204 0           my $installdirs = $pkgdesc->installdirs;
205 0           my $INSTALLDIRS = uc $installdirs;
206 0           my %mandir = $pkgdesc->mandirs;
207              
208 0           return << "END_PERL_MM_OPT";
209             INSTALLDIRS=$installdirs
210             INSTALL${INSTALLDIRS}MAN1DIR=$mandir{1}
211             INSTALL${INSTALLDIRS}MAN3DIR=$mandir{3}
212             END_PERL_MM_OPT
213             }
214              
215             sub _perl_mb_opt {
216 0     0     my $dist = shift;
217              
218 0           my $status = $dist->status;
219 0           my $pkgdesc = $status->_pkgdesc;
220              
221 0           my $installdirs = $pkgdesc->{installdirs};
222 0           my %mandir = $pkgdesc->mandirs;
223              
224 0           return << "END_PERL_MB_OPT";
225             --installdirs $installdirs
226             --config install${installdirs}man1dir=$mandir{1}
227             --config install${installdirs}man3dir=$mandir{3}
228             END_PERL_MB_OPT
229             }
230              
231             sub _fake_install {
232 0     0     my ( $dist, $param_ref ) = @_;
233              
234 0           my $status = $dist->status;
235 0           my $module = $dist->parent;
236 0           my $pkgdesc = $status->_pkgdesc;
237              
238 0           my $verbose = $param_ref->{verbose};
239              
240 0           my $wrksrc = $module->status->extract;
241 0 0         if ( !$wrksrc ) {
242 0           error( loc(q{No dir found to operate on!}) );
243 0           return;
244             }
245              
246 0           my $destdir = $pkgdesc->destdir;
247              
248 0           my $cmd;
249 0           my $installer_type = $module->status->installer_type;
250 0 0         if ( $installer_type eq 'CPANPLUS::Dist::MM' ) {
    0          
251 0           my $make = $param_ref->{make};
252 0           $cmd = [ $make, 'install', "DESTDIR=$destdir" ];
253             }
254             elsif ( $installer_type eq 'CPANPLUS::Dist::Build' ) {
255 0           my $perl = $param_ref->{perl};
256 0           $cmd = [
257             $perl, '-MCPANPLUS::Internals::Utils::Autoflush',
258             'Build', 'install', '--destdir', $destdir,
259             split( ' ', $dist->_perl_mb_opt )
260             ];
261             }
262             else {
263 0           error( loc( q{Unknown type '%1'}, $installer_type ) );
264 0           return;
265             }
266              
267 0           msg( loc( q{Staging distribution in '%1'}, $destdir ) );
268              
269 0           return run( $cmd, { dir => $wrksrc, verbose => $verbose } );
270             }
271              
272             sub _makepkg {
273 0     0     my ( $dist, $param_ref ) = @_;
274              
275 0           my $status = $dist->status;
276 0           my $module = $dist->parent;
277 0           my $cb = $module->parent;
278 0           my $conf = $cb->configure_object;
279 0           my $pkgdesc = $status->_pkgdesc;
280              
281 0           my $verbose = $param_ref->{verbose};
282 0           my $destdir = $pkgdesc->destdir;
283 0           my $outputname = $pkgdesc->outputname;
284              
285 0           my $needs_chown = 0;
286 0           my $cmd = [ '/sbin/makepkg', '-l', 'y', '-c', 'y', $outputname ];
287 0 0         if ( $EFFECTIVE_USER_ID > 0 ) {
288 0           my $fakeroot = $status->_fakeroot_cmd;
289 0 0         if ($fakeroot) {
290 0           unshift @{$cmd}, $fakeroot;
  0            
291             }
292             else {
293 0           my $sudo = $conf->get_program('sudo');
294 0 0         if ($sudo) {
295 0           unshift @{$cmd}, $sudo;
  0            
296 0           $needs_chown = 1;
297             }
298             else {
299 0           error( loc($NONROOT_WARNING) );
300 0           return;
301             }
302             }
303             }
304              
305 0           msg( loc( q{Creating package '%1'}, $outputname ) );
306              
307 0           my $orig_uid = $UID;
308 0           my $orig_gid = ( split /\s+/, $GID )[0];
309 0 0         if ($needs_chown) {
310 0           my @stat = stat($destdir);
311 0 0         if ( !@stat ) {
312 0           error( loc( q{Could not stat '%1': %2}, $destdir, $OS_ERROR ) );
313 0           return;
314             }
315 0           $orig_uid = $stat[4];
316 0           $orig_gid = $stat[5];
317              
318 0 0         $dist->_chown_recursively( 0, 0, $destdir ) or return;
319             }
320              
321 0           my $fail = 0;
322 0 0         if ( !run( $cmd, { dir => $destdir, verbose => $verbose } ) ) {
323 0           ++$fail;
324             }
325              
326 0 0         if ($needs_chown) {
327 0 0         if ( -d $destdir ) {
328 0 0         if (!$dist->_chown_recursively( $orig_uid, $orig_gid, $destdir ) )
329             {
330 0           ++$fail;
331             }
332             }
333 0 0         if ( -f $outputname ) {
334 0 0         if (!$dist->_chown_recursively(
335             $orig_uid, $orig_gid, $outputname
336             )
337             )
338             {
339 0           ++$fail;
340             }
341             }
342             }
343              
344 0 0         if ( !$param_ref->{keep_source} ) {
345              
346             # Keep the staging directory if something failed.
347 0 0         if ( !$fail ) {
348 0           msg( loc( q{Removing '%1'}, $destdir ) );
349 0 0         if ( !$cb->_rmdir( dir => $destdir ) ) {
350 0           ++$fail;
351             }
352             }
353             }
354              
355 0 0         return ( $fail ? 0 : 1 );
356             }
357              
358             sub _installpkg {
359 0     0     my ( $dist, $param_ref ) = @_;
360              
361 0           my $status = $dist->status;
362 0           my $module = $dist->parent;
363 0           my $cb = $module->parent;
364 0           my $conf = $cb->configure_object;
365 0           my $pkgdesc = $status->_pkgdesc;
366              
367 0           my $verbose = $param_ref->{verbose};
368 0           my $outputname = $pkgdesc->outputname;
369              
370 0           my $cmd
371             = [ '/sbin/upgradepkg', '--install-new', '--reinstall', $outputname ];
372 0 0         if ( $EFFECTIVE_USER_ID > 0 ) {
373 0           my $sudo = $conf->get_program('sudo');
374 0 0         if ($sudo) {
375 0           unshift @{$cmd}, $sudo;
  0            
376             }
377             else {
378 0           error( loc($NONROOT_WARNING) );
379 0           return;
380             }
381             }
382              
383 0           msg( loc( q{Installing package '%1'}, $outputname ) );
384              
385 0           return run( $cmd, { verbose => $verbose } );
386             }
387              
388             sub _compress_manual_pages {
389 0     0     my ( $dist, $param_ref ) = @_;
390              
391 0           my $status = $dist->status;
392 0           my $pkgdesc = $status->_pkgdesc;
393              
394 0           my %mandir = $pkgdesc->mandirs;
395 0           my @mandirs = grep { -d $_ }
396 0           map { catdir( $pkgdesc->destdir, $_ ) } values %mandir;
  0            
397              
398 0           my $fail = 0;
399             my $wanted = sub {
400 0     0     my $filename = $_;
401 0 0 0       if ( $filename !~ /\.gz$/ && ( -f $filename || -l $filename ) ) {
      0        
402 0 0 0       if ( !( gzip($filename) && unlink $filename ) ) {
403 0           error( loc( q{Could not compress file '%1'}, $filename ) );
404 0           ++$fail;
405             }
406             }
407 0           };
408 0 0         if (@mandirs) {
409 0           File::Find::find( $wanted, @mandirs );
410             }
411              
412 0 0         return ( $fail ? 0 : 1 );
413             }
414              
415             sub _install_docfiles {
416 0     0     my ( $dist, $param_ref ) = @_;
417              
418 0           my $status = $dist->status;
419 0           my $module = $dist->parent;
420 0           my $cb = $module->parent;
421 0           my $pkgdesc = $status->_pkgdesc;
422              
423 0           my $wrksrc = $module->status->extract;
424 0 0         if ( !$wrksrc ) {
425 0           error( loc(q{No dir found to operate on!}) );
426 0           return;
427             }
428              
429 0           my @docfiles = $pkgdesc->docfiles;
430              
431 0           my $docdir = catdir( $pkgdesc->destdir, $pkgdesc->docdir );
432 0 0         $cb->_mkdir( dir => $docdir ) or return;
433              
434             # Create README.SLACKWARE.
435 0           my $readme = $pkgdesc->readme_slackware;
436 0           my $readmefile = catfile( $docdir, 'README.SLACKWARE' );
437 0 0         spurt( $readmefile, $readme ) or return;
438              
439             # Create perl-Some-Module.SlackBuild.
440 0           my $script = $pkgdesc->build_script;
441 0           my $scriptfile
442             = catfile( $docdir, $pkgdesc->normalized_name . '.SlackBuild' );
443 0 0         spurt( $scriptfile, $script ) or return;
444              
445             # Copy files like README and Changes.
446 0           my $fail = 0;
447 0           for my $docfile (@docfiles) {
448 0           my $from = catfile( $wrksrc, $docfile );
449 0 0         if ( !$cb->_copy( file => $from, to => $docdir ) ) {
450 0           ++$fail;
451             }
452             }
453              
454 0 0         return ( $fail ? 0 : 1 );
455             }
456              
457             sub _process_packlist {
458 0     0     my ( $dist, $filename ) = @_;
459              
460 0           my $status = $dist->status;
461 0           my $pkgdesc = $status->_pkgdesc;
462              
463 0           my $destdir = $pkgdesc->destdir;
464              
465 0           my ($old_pl) = ExtUtils::Packlist->new($filename);
466 0           my @keys = grep {m{^\Q$destdir\E}xms} keys %{$old_pl};
  0            
  0            
467 0 0         if ( !@keys ) {
468 0           @keys = keys %{$old_pl};
  0            
469             }
470 0 0         if (@keys) {
471 0           my ($new_pl) = ExtUtils::Packlist->new();
472 0           for my $key (@keys) {
473 0           my $value = $old_pl->{$key};
474 0           $key =~ s{^\Q$destdir\E}{}xms;
475              
476             # Add .gz to manual pages.
477 0 0         if ( $key =~ m{/man/man}xms ) {
478 0 0         if ( $key !~ m{\.gz$}xms ) {
479 0           $key .= '.gz';
480             }
481 0 0         if ( ref $value eq 'HASH' ) {
482 0 0 0       if ( defined $value->{type}
      0        
483             && $value->{type} eq 'link'
484             && defined $value->{from} )
485             {
486 0           my $from = $value->{from};
487 0 0         if ( $from =~ m{/man/man}xms ) {
488 0 0         if ( $from !~ m{\.gz$}xms ) {
489 0           $from .= '.gz';
490 0           $value->{from} = $from;
491             }
492             }
493             }
494             }
495             }
496              
497 0 0         if ( -e "$destdir$key" ) {
498 0           $new_pl->{$key} = $value;
499             }
500             }
501 0           $new_pl->write($filename);
502             }
503 0           return 1;
504             }
505              
506             sub _process_installed_files {
507 0     0     my ( $dist, $param_ref ) = @_;
508              
509 0           my $status = $dist->status;
510 0           my $module = $dist->parent;
511 0           my $cb = $module->parent;
512 0           my $pkgdesc = $status->_pkgdesc;
513              
514 0           my $destdir = $pkgdesc->destdir;
515              
516 0           my $orig_dir = Cwd::cwd();
517 0 0         if ( !$cb->_chdir( dir => $destdir ) ) {
518 0           return;
519             }
520              
521 0           my $fail = 0;
522 0           my @packlists;
523             my $wanted = sub {
524 0     0     my $filename = $_;
525              
526 0 0         return if $filename eq q{.};
527              
528 0           my @stat = lstat($filename);
529 0 0         if ( !@stat ) {
530 0           error( loc( q{Could not lstat '%1': %2}, $filename, $OS_ERROR ) );
531 0           return;
532             }
533              
534             # Skip symbolic links.
535 0 0         return if -l _;
536              
537             # Sanitize the file modes.
538 0           my $perm = ( $stat[2] & oct '0755' ) | oct '0200';
539 0 0         if ( !chmod $perm, $filename ) {
540 0           error( loc( q{Could not chmod '%1': %2}, $filename, $OS_ERROR ) );
541 0           ++$fail;
542             }
543              
544 0 0         if ( -d $filename ) {
    0          
545              
546             # Remove empty directories.
547 0           rmdir $filename;
548             }
549             elsif ( -f $filename ) {
550 0 0 0       if ( $filename eq 'perllocal.pod'
    0 0        
551             || ( $filename =~ /\.bs$/ && -z $filename ) )
552             {
553 0 0         if ( !unlink $filename ) {
554 0           error(
555             loc(q{Could not unlink '%1': %2}, $filename,
556             $OS_ERROR
557             )
558             );
559 0           ++$fail;
560             }
561             }
562             elsif ( $filename eq '.packlist' ) {
563 0           push @packlists, $File::Find::name;
564             }
565             else {
566 0           my $type = filetype($filename);
567 0 0         if ( $type =~ /ELF.+(?:executable|shared object)/s ) {
568 0 0         if ( !strip($filename) ) {
569 0           ++$fail;
570             }
571             }
572             }
573             }
574 0           };
575 0           File::Find::finddepth( $wanted, q{.} );
576              
577 0           for my $packlist (@packlists) {
578 0 0         if ( !$dist->_process_packlist($packlist) ) {
579 0           ++$fail;
580             }
581             }
582              
583 0 0         if ( !$cb->_chdir( dir => $orig_dir ) ) {
584 0           ++$fail;
585             }
586              
587 0 0         return ( $fail ? 0 : 1 );
588             }
589              
590             sub _make_installdir {
591 0     0     my ( $dist, $param_ref ) = @_;
592              
593 0           my $status = $dist->status;
594 0           my $module = $dist->parent;
595 0           my $cb = $module->parent;
596 0           my $pkgdesc = $status->_pkgdesc;
597              
598 0           my $installdir = catdir( $pkgdesc->destdir, 'install' );
599 0           return $cb->_mkdir( dir => $installdir );
600             }
601              
602             sub _write_config_files {
603 0     0     my ( $dist, $param_ref ) = @_;
604              
605 0           my $status = $dist->status;
606 0           my $module = $dist->parent;
607 0           my $cb = $module->parent;
608 0           my $pkgdesc = $status->_pkgdesc;
609              
610 0           my $destdir = $pkgdesc->destdir;
611              
612 0 0         return 1 if !-d catdir( $destdir, 'etc' );
613              
614 0           my $orig_dir = Cwd::cwd();
615 0 0         if ( !$cb->_chdir( dir => $destdir ) ) {
616 0           return;
617             }
618              
619             # Find and rename the configuration files.
620 0           my $fail = 0;
621 0           my @conffiles;
622             my $wanted = sub {
623 0     0     my $filename = $_;
624              
625             # Skip files that have already been renamed.
626 0 0         return if $filename =~ /\.new$/;
627              
628 0 0 0       if ( -l $filename || -f $filename ) {
629 0 0         if ( !$cb->_move( file => $filename, to => "$filename.new" ) ) {
630 0           ++$fail;
631             }
632 0           push @conffiles, $filename;
633             }
634 0           };
635 0           File::Find::find( { wanted => $wanted, no_chdir => 1 }, 'etc' );
636              
637 0 0         if ( !$cb->_chdir( dir => $orig_dir ) ) {
638 0           ++$fail;
639             }
640              
641 0 0         return if $fail;
642 0 0         return 1 if !@conffiles;
643              
644 0           @conffiles = sort { uc $a cmp uc $b } @conffiles;
  0            
645              
646             # List the configuration files in README.SLACKWARE.
647 0 0         $dist->_append_config_files_to_readme_slackware(@conffiles) or return;
648              
649             # Add a config function to doinst.sh.
650 0           my $script = $pkgdesc->config_function;
651 0           for my $conffile (@conffiles) {
652 0           $conffile =~ s/('+)/'"$1"'/g; # Quote single quotes.
653 0           $script .= "config '$conffile.new'\n";
654             }
655              
656 0           my $installdir = catdir( $pkgdesc->destdir, 'install' );
657 0           my $doinstfile = catfile( $installdir, 'doinst.sh' );
658 0           return spurt( $doinstfile, { append => 1 }, $script );
659             }
660              
661             sub _append_config_files_to_readme_slackware {
662 0     0     my ( $dist, @conffiles ) = @_;
663              
664 0           my $status = $dist->status;
665 0           my $pkgdesc = $status->_pkgdesc;
666              
667             my $readme
668             = "\n"
669             . "Configuration files\n"
670             . "-------------------\n\n"
671             . "This package provides the following configuration files:\n\n"
672 0           . join( "\n", map {"* /$_"} @conffiles ) . "\n";
  0            
673              
674 0           my $docdir = catdir( $pkgdesc->destdir, $pkgdesc->docdir );
675 0           my $readmefile = catfile( $docdir, 'README.SLACKWARE' );
676 0           return spurt( $readmefile, { append => 1 }, $readme );
677             }
678              
679             sub _write_slack_desc {
680 0     0     my ( $dist, $param_ref ) = @_;
681              
682 0           my $status = $dist->status;
683 0           my $module = $dist->parent;
684 0           my $cb = $module->parent;
685 0           my $pkgdesc = $status->_pkgdesc;
686              
687 0           my $installdir = catdir( $pkgdesc->destdir, 'install' );
688 0           my $descfile = catfile( $installdir, 'slack-desc' );
689 0           my $desc = $pkgdesc->slack_desc;
690 0           return spurt( $descfile, $desc );
691             }
692              
693             sub _chown_recursively {
694 0     0     my ( $dist, $uid, $gid, @filenames ) = @_;
695              
696 0           my $module = $dist->parent;
697 0           my $cb = $module->parent;
698 0           my $conf = $cb->configure_object;
699              
700 0           my $cmd = [ '/bin/chown', '-R', "$uid:$gid", @filenames ];
701 0 0         if ( $EFFECTIVE_USER_ID > 0 ) {
702 0           my $sudo = $conf->get_program('sudo');
703 0 0         if ($sudo) {
704 0           unshift @{$cmd}, $sudo;
  0            
705             }
706             else {
707 0           error( loc($NONROOT_WARNING) );
708 0           return;
709             }
710             }
711 0           return run($cmd);
712             }
713              
714             1;
715             __END__