ExtUtils/Command/MM.pm

package ExtUtils::Command::MM;

use strict;

require 5.005_03;
require Exporter;
use vars qw($VERSION @ISA @EXPORT);
@ISA = qw(Exporter);

@EXPORT  = qw(test_harness pod2man perllocal_install uninstall 
              warn_if_old_packlist);
$VERSION = '0.03';

my $Is_VMS = $^O eq 'VMS';

=head1 NAME

ExtUtils::Command::MM - Commands for the MM's to use in Makefiles

=head1 SYNOPSIS

  perl "-MExtUtils::Command::MM" -e "function" "--" arguments...


=head1 DESCRIPTION

B<FOR INTERNAL USE ONLY!>  The interface is not stable.

ExtUtils::Command::MM encapsulates code which would otherwise have to
be done with large "one" liners.

Any $(FOO) used in the examples are make variables, not Perl.

=over 4

=item B<test_harness>

  test_harness($verbose, @test_libs);

Runs the tests on @ARGV via Test::Harness passing through the $verbose
flag.  Any @test_libs will be unshifted onto the test's @INC.

@test_libs are run in alphabetical order.

=cut

sub test_harness {
    require Test::Harness;
    require File::Spec;

    $Test::Harness::verbose = shift;

    local @INC = @INC;
    unshift @INC, map { File::Spec->rel2abs($_) } @_;
    Test::Harness::runtests(sort { lc $a cmp lc $b } @ARGV);
}


=item B<pod2man>

  pod2man( '--option=value',
           $podfile1 => $manpage1,
           $podfile2 => $manpage2,
           ...
         );

  # or args on @ARGV

pod2man() is a function performing most of the duties of the pod2man
program.  Its arguments are exactly the same as pod2man as of 5.8.0
with the addition of:

    --perm_rw   octal permission to set the resulting manpage to

And the removal of:

    --verbose/-v
    --help/-h

If no arguments are given to pod2man it will read from @ARGV.

=cut

sub pod2man {
    require Pod::Man;
    require Getopt::Long;

    my %options = ();

    # We will cheat and just use Getopt::Long.  We fool it by putting
    # our arguments into @ARGV.  Should be safe.
    local @ARGV = @_ ? @_ : @ARGV;
    Getopt::Long::config ('bundling_override');
    Getopt::Long::GetOptions (\%options, 
                'section|s=s', 'release|r=s', 'center|c=s',
                'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
                'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l',
                'name|n=s', 'perm_rw:i'
    );

    # If there's no files, don't bother going further.
    return 0 unless @ARGV;

    # Official sets --center, but don't override things explicitly set.
    if ($options{official} && !defined $options{center}) {
        $options{center} = 'Perl Programmers Reference Guide';
    }

    # This isn't a valid Pod::Man option and is only accepted for backwards
    # compatibility.
    delete $options{lax};

    my $parser = Pod::Man->new(%options);

    do {{  # so 'next' works
        my ($pod, $man) = splice(@ARGV, 0, 2);

        next if ((-e $man) &&
                 (-M $man < -M $pod) &&
                 (-M $man < -M "Makefile"));

        print "Manifying $man\n";

        $parser->parse_from_file($pod, $man)
          or do { warn("Could not install $man\n");  next };

        if (length $options{perm_rw}) {
            chmod(oct($options{perm_rw}), $man)
              or do { warn("chmod $options{perm_rw} $man: $!\n"); next };
        }
    }} while @ARGV;

    return 1;
}


=item B<warn_if_old_packlist>

  perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile>

Displays a warning that an old packlist file was found.  Reads the
filename from @ARGV.

=cut

sub warn_if_old_packlist {
    my $packlist = $ARGV[0];

    return unless -f $packlist;
    print <<"PACKLIST_WARNING";
WARNING: I have found an old package in
    $packlist.
Please make sure the two installations are not conflicting
PACKLIST_WARNING

}


=item B<perllocal_install>

    perl "-MExtUtils::Command::MM" -e perllocal_install 
        <type> <module name> <key> <value> ...

    # VMS only, key/value pairs come on STDIN
    perl "-MExtUtils::Command::MM" -e perllocal_install
        <type> <module name> < <key> <value> ...

Prints a fragment of POD suitable for appending to perllocal.pod.
Arguments are read from @ARGV.

'type' is the type of what you're installing.  Usually 'Module'.

'module name' is simply the name of your module.  (Foo::Bar)

Key/value pairs are extra information about the module.  Fields include:

    installed into      which directory your module was out into
    LINKTYPE            dynamic or static linking
    VERSION             module version number
    EXE_FILES           any executables installed in a space seperated 
                        list

=cut

sub perllocal_install {
    my($type, $name) = splice(@ARGV, 0, 2);

    # VMS feeds args as a piped file on STDIN since it usually can't
    # fit all the args on a single command line.
    @ARGV = split /\|/, <STDIN> if $Is_VMS;

    my $pod;
    $pod = sprintf <<POD, scalar localtime;
 =head2 %s: C<$type> L<$name|$name>
 
 =over 4
 
POD

    do {
        my($key, $val) = splice(@ARGV, 0, 2);

        $pod .= <<POD
 =item *
 
 C<$key: $val>
 
POD

    } while(@ARGV);

    $pod .= "=back\n\n";
    $pod =~ s/^ //mg;
    print $pod;

    return 1;
}

=item B<uninstall>

    perl "-MExtUtils::Command::MM" -e uninstall <packlist>

A wrapper around ExtUtils::Install::uninstall().  Warns that
uninstallation is deprecated and doesn't actually perform the
uninstallation.

=cut

sub uninstall {
    my($packlist) = shift;

    require ExtUtils::Install;

    print <<'WARNING';

Uninstall is unsafe and deprecated, the uninstallation was not performed.
We will show what would have been done.

WARNING

    ExtUtils::Install::uninstall($packlist, 1, 1);

    print <<'WARNING';

Uninstall is unsafe and deprecated, the uninstallation was not performed.
Please check the list above carefully, there may be errors.
Remove the appropriate files manually.
Sorry for the inconvenience.

WARNING

}

=back

=cut

1;
Revision:	1.1
Committed:	Thu Jun 30 14:27:11 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package ExtUtils::Command::MM;
2
3			use strict;
4
5			require 5.005_03;
6			require Exporter;
7			use vars qw($VERSION @ISA @EXPORT);
8			@ISA = qw(Exporter);
9
10			@EXPORT = qw(test_harness pod2man perllocal_install uninstall
11			warn_if_old_packlist);
12			$VERSION = '0.03';
13
14			my $Is_VMS = $^O eq 'VMS';
15
16			=head1 NAME
17
18			ExtUtils::Command::MM - Commands for the MM's to use in Makefiles
19
20			=head1 SYNOPSIS
21
22			perl "-MExtUtils::Command::MM" -e "function" "--" arguments...
23
24
25			=head1 DESCRIPTION
26
27			B<FOR INTERNAL USE ONLY!> The interface is not stable.
28
29			ExtUtils::Command::MM encapsulates code which would otherwise have to
30			be done with large "one" liners.
31
32			Any $(FOO) used in the examples are make variables, not Perl.
33
34			=over 4
35
36			=item B<test_harness>
37
38			test_harness($verbose, @test_libs);
39
40			Runs the tests on @ARGV via Test::Harness passing through the $verbose
41			flag. Any @test_libs will be unshifted onto the test's @INC.
42
43			@test_libs are run in alphabetical order.
44
45			=cut
46
47			sub test_harness {
48			require Test::Harness;
49			require File::Spec;
50
51			$Test::Harness::verbose = shift;
52
53			local @INC = @INC;
54			unshift @INC, map { File::Spec->rel2abs($_) } @_;
55			Test::Harness::runtests(sort { lc $a cmp lc $b } @ARGV);
56			}
57
58
59
60			=item B<pod2man>
61
62			pod2man( '--option=value',
63			$podfile1 => $manpage1,
64			$podfile2 => $manpage2,
65			...
66			);
67
68			# or args on @ARGV
69
70			pod2man() is a function performing most of the duties of the pod2man
71			program. Its arguments are exactly the same as pod2man as of 5.8.0
72			with the addition of:
73
74			--perm_rw octal permission to set the resulting manpage to
75
76			And the removal of:
77
78			--verbose/-v
79			--help/-h
80
81			If no arguments are given to pod2man it will read from @ARGV.
82
83			=cut
84
85			sub pod2man {
86			require Pod::Man;
87			require Getopt::Long;
88
89			my %options = ();
90
91			# We will cheat and just use Getopt::Long. We fool it by putting
92			# our arguments into @ARGV. Should be safe.
93			local @ARGV = @_ ? @_ : @ARGV;
94			Getopt::Long::config ('bundling_override');
95			Getopt::Long::GetOptions (\%options,
96			'section\|s=s', 'release\|r=s', 'center\|c=s',
97			'date\|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
98			'fixedbolditalic=s', 'official\|o', 'quotes\|q=s', 'lax\|l',
99			'name\|n=s', 'perm_rw:i'
100			);
101
102			# If there's no files, don't bother going further.
103			return 0 unless @ARGV;
104
105			# Official sets --center, but don't override things explicitly set.
106			if ($options{official} && !defined $options{center}) {
107			$options{center} = 'Perl Programmers Reference Guide';
108			}
109
110			# This isn't a valid Pod::Man option and is only accepted for backwards
111			# compatibility.
112			delete $options{lax};
113
114			my $parser = Pod::Man->new(%options);
115
116			do {{ # so 'next' works
117			my ($pod, $man) = splice(@ARGV, 0, 2);
118
119			next if ((-e $man) &&
120			(-M $man < -M $pod) &&
121			(-M $man < -M "Makefile"));
122
123			print "Manifying $man\n";
124
125			$parser->parse_from_file($pod, $man)
126			or do { warn("Could not install $man\n"); next };
127
128			if (length $options{perm_rw}) {
129			chmod(oct($options{perm_rw}), $man)
130			or do { warn("chmod $options{perm_rw} $man: $!\n"); next };
131			}
132			}} while @ARGV;
133
134			return 1;
135			}
136
137
138			=item B<warn_if_old_packlist>
139
140			perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile>
141
142			Displays a warning that an old packlist file was found. Reads the
143			filename from @ARGV.
144
145			=cut
146
147			sub warn_if_old_packlist {
148			my $packlist = $ARGV[0];
149
150			return unless -f $packlist;
151			print <<"PACKLIST_WARNING";
152			WARNING: I have found an old package in
153			$packlist.
154			Please make sure the two installations are not conflicting
155			PACKLIST_WARNING
156
157			}
158
159
160			=item B<perllocal_install>
161
162			perl "-MExtUtils::Command::MM" -e perllocal_install
163			<type> <module name> <key> <value> ...
164
165			# VMS only, key/value pairs come on STDIN
166			perl "-MExtUtils::Command::MM" -e perllocal_install
167			<type> <module name> < <key> <value> ...
168
169			Prints a fragment of POD suitable for appending to perllocal.pod.
170			Arguments are read from @ARGV.
171
172			'type' is the type of what you're installing. Usually 'Module'.
173
174			'module name' is simply the name of your module. (Foo::Bar)
175
176			Key/value pairs are extra information about the module. Fields include:
177
178			installed into which directory your module was out into
179			LINKTYPE dynamic or static linking
180			VERSION module version number
181			EXE_FILES any executables installed in a space seperated
182			list
183
184			=cut
185
186			sub perllocal_install {
187			my($type, $name) = splice(@ARGV, 0, 2);
188
189			# VMS feeds args as a piped file on STDIN since it usually can't
190			# fit all the args on a single command line.
191			@ARGV = split /\\|/, <STDIN> if $Is_VMS;
192
193			my $pod;
194			$pod = sprintf <<POD, scalar localtime;
195			=head2 %s: C<$type> L<$name\|$name>
196
197			=over 4
198
199			POD
200
201			do {
202			my($key, $val) = splice(@ARGV, 0, 2);
203
204			$pod .= <<POD
205			=item *
206
207			C<$key: $val>
208
209			POD
210
211			} while(@ARGV);
212
213			$pod .= "=back\n\n";
214			$pod =~ s/^ //mg;
215			print $pod;
216
217			return 1;
218			}
219
220			=item B<uninstall>
221
222			perl "-MExtUtils::Command::MM" -e uninstall <packlist>
223
224			A wrapper around ExtUtils::Install::uninstall(). Warns that
225			uninstallation is deprecated and doesn't actually perform the
226			uninstallation.
227
228			=cut
229
230			sub uninstall {
231			my($packlist) = shift;
232
233			require ExtUtils::Install;
234
235			print <<'WARNING';
236
237			Uninstall is unsafe and deprecated, the uninstallation was not performed.
238			We will show what would have been done.
239
240			WARNING
241
242			ExtUtils::Install::uninstall($packlist, 1, 1);
243
244			print <<'WARNING';
245
246			Uninstall is unsafe and deprecated, the uninstallation was not performed.
247			Please check the list above carefully, there may be errors.
248			Remove the appropriate files manually.
249			Sorry for the inconvenience.
250
251			WARNING
252
253			}
254
255			=back
256
257			=cut
258
259			1;