1use strict;
2use Cwd;
3use File::Path;
4use File::Find;
5
6my %opts = (
7  #defaults
8    'verbose' => 1, # verbose level, in range from 0 to 2
9    'distdir' => 'distdir',
10    'unicode' => 1, # include unicode by default
11    'minimal' => 0, # minimal possible distribution.
12                    # actually this is just perl.exe and perlXX.dll
13		    # but can be extended by additional exts
14		    #  ... (as soon as this will be implemented :)
15    'cross-name' => 'wince',
16    'strip-pod' => 0, # strip POD from perl modules
17    'adaptation' => 1, # do some adaptation, such as stripping such
18                       # occurences as "if ($^O eq 'VMS'){...}" for Dynaloader.pm
19    'zip' => 0,     # perform zip
20    'clean-exts' => 0,
21  #options itself
22    (map {/^--([\-_\w]+)=(.*)$/} @ARGV),                            # --opt=smth
23    (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV),  # --opt --no-opt --noopt
24  );
25
26# TODO
27#   -- error checking. When something goes wrong, just exit with rc!=0
28#   -- may be '--zip' option should be made differently?
29
30my $cwd = cwd;
31
32if ($opts{'clean-exts'}) {
33  # unfortunately, unlike perl58.dll and like, extensions for different
34  # platforms are built in same directory, therefore we must be able to clean
35  # them often
36  unlink '../config.sh'; # delete cache config file, which remembers our previous config
37  chdir '../ext';
38  find({no_chdir=>1,wanted => sub{
39        unlink if /((?:\.obj|\/makefile|\/errno\.pm))$/i;
40      }
41    },'.');
42  exit;
43}
44
45# zip
46if ($opts{'zip'}) {
47  if ($opts{'verbose'} >=1) {
48    print STDERR "zipping...\n";
49  }
50  chdir $opts{'distdir'};
51  unlink <*.zip>;
52  `zip -R perl-$opts{'cross-name'} *`;
53  exit;
54}
55
56my (%libexclusions, %extexclusions);
57my @lfiles;
58sub copy($$);
59
60# lib
61chdir '../lib';
62find({no_chdir=>1,wanted=>sub{push @lfiles, $_ if /\.p[lm]$/}},'.');
63chdir $cwd;
64# exclusions
65@lfiles = grep {!exists $libexclusions{$_}} @lfiles;
66#inclusions
67#...
68#copy them
69if ($opts{'verbose'} >=1) {
70  print STDERR "Copying perl lib files...\n";
71}
72for (@lfiles) {
73  /^(.*)\/[^\/]+$/;
74  mkpath "$opts{distdir}/lib/$1";
75  copy "../lib/$_", "$opts{distdir}/lib/$_";
76}
77
78#ext
79my @efiles;
80chdir '../ext';
81find({no_chdir=>1,wanted=>sub{push @efiles, $_ if /\.pm$/}},'.');
82chdir $cwd;
83# exclusions
84#...
85#inclusions
86#...
87#copy them
88#{s[/(\w+)/\1\.pm][/$1.pm]} @efiles;
89if ($opts{'verbose'} >=1) {
90  print STDERR "Copying perl core extensions...\n";
91}
92for (@efiles) {
93  if (m#^.*?/lib/(.*)$#) {
94    copy "../ext/$_", "$opts{distdir}/lib/$1";
95  }
96  else {
97    /^(.*)\/([^\/]+)\/([^\/]+)$/;
98    copy "../ext/$_", "$opts{distdir}/lib/$1/$3";
99  }
100}
101my ($dynaloader_pm);
102if ($opts{adaptation}) {
103  # let's copy our Dynaloader.pm (make this optional?)
104  open my $fhdyna, ">$opts{distdir}/lib/Dynaloader.pm";
105  print $fhdyna $dynaloader_pm;
106  close $fhdyna;
107}
108
109# Config.pm, perl binaries
110if ($opts{'verbose'} >=1) {
111  print STDERR "Copying Config.pm, perl.dll and perl.exe...\n";
112}
113copy "../xlib/$opts{'cross-name'}/Config.pm", "$opts{distdir}/lib/Config.pm";
114copy "$opts{'cross-name'}/perl.exe", "$opts{distdir}/bin/perl.exe";
115copy "$opts{'cross-name'}/perl.dll", "$opts{distdir}/bin/perl.dll";
116# how do we know exact name of perl.dll?
117
118# auto
119my %aexcl = (socket=>'Socket_1');
120# Socket.dll and may be some other conflict with same file in \windows dir
121# on WinCE, %aexcl needed to replace it with a different name that however
122# will be found by Dynaloader
123my @afiles;
124chdir "../xlib/$opts{'cross-name'}/auto";
125find({no_chdir=>1,wanted=>sub{push @afiles, $_ if /\.(dll|bs)$/}},'.');
126chdir $cwd;
127if ($opts{'verbose'} >=1) {
128  print STDERR "Copying binaries for perl core extensions...\n";
129}
130for (@afiles) {
131  if (/^(.*)\/(\w+)\.dll$/i && exists $aexcl{lc($2)}) {
132    copy "../xlib/$opts{'cross-name'}/auto/$_", "$opts{distdir}/lib/auto/$1/$aexcl{lc($2)}.dll";
133  }
134  else {
135    copy "../xlib/$opts{'cross-name'}/auto/$_", "$opts{distdir}/lib/auto/$_";
136  }
137}
138
139sub copy($$) {
140  my ($fnfrom, $fnto) = @_;
141  open my $fh, "<$fnfrom" or die "can not open $fnfrom: $!";
142  binmode $fh;
143  local $/;
144  my $ffrom = <$fh>;
145  if ($opts{'strip-pod'}) {
146    # actually following regexp is suspicious to not work everywhere.
147    # but we've checked on our set of modules, and it's fit for our purposes
148    $ffrom =~ s/^=\w+.*?^=cut(?:\n|\Z)//msg;
149    unless ($ffrom=~/\bAutoLoader\b/) {
150      # this logic actually strip less than could be stripped, but we're
151      # not risky. Just strip only of no mention of AutoLoader
152      $ffrom =~ s/^__END__.*\Z//msg;
153    }
154  }
155  mkpath $1 if $fnto=~/^(.*)\/([^\/]+)$/;
156  open my $fhout, ">$fnto";
157  binmode $fhout;
158  print $fhout $ffrom;
159  if ($opts{'verbose'} >=2) {
160    print STDERR "copying $fnfrom=>$fnto\n";
161  }
162}
163
164BEGIN {
165%libexclusions = map {$_=>1} split/\s/, <<"EOS";
166abbrev.pl bigfloat.pl bigint.pl bigrat.pl cacheout.pl complete.pl ctime.pl
167dotsh.pl exceptions.pl fastcwd.pl flush.pl ftp.pl getcwd.pl getopt.pl
168getopts.pl hostname.pl look.pl newgetopt.pl pwd.pl termcap.pl
169EOS
170%extexclusions = map {$_=>1} split/\s/, <<"EOS";
171EOS
172$dynaloader_pm=<<'EOS';
173# This module designed *only* for WinCE
174# if you encounter a problem with this file, try using original Dynaloader.pm
175# from perl distribution, it's larger but essentially the same.
176package DynaLoader;
177our $VERSION = 1.04;
178
179$dl_debug ||= 0;
180
181@dl_require_symbols = ();       # names of symbols we need
182
183#@dl_librefs = (); # things we have loaded
184#@dl_modules = (); # Modules we have loaded
185
186boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && !defined(&dl_error);
187
188print STDERR "DynaLoader not linked into this perl\n"
189  unless defined(&boot_DynaLoader);
190
1911; # End of main code
192
193sub croak{require Carp;Carp::croak(@_)}
194sub bootstrap_inherit {
195    my $module = $_[0];
196    local *isa = *{"$module\::ISA"};
197    local @isa = (@isa, 'DynaLoader');
198    bootstrap(@_);
199}
200sub bootstrap {
201    # use local vars to enable $module.bs script to edit values
202    local(@args) = @_;
203    local($module) = $args[0];
204    local(@dirs, $file);
205
206    unless ($module) {
207	require Carp;
208	Carp::confess("Usage: DynaLoader::bootstrap(module)");
209    }
210
211    croak("Can't load module $module, dynamic loading not available in this perl.\n")
212	unless defined(&dl_load_file);
213
214    my @modparts = split(/::/,$module);
215    my $modfname = $modparts[-1];
216    my $modpname = join('/',@modparts);
217
218    for (@INC) {
219	my $dir = "$_/auto/$modpname";
220	next unless -d $dir;
221	my $try = "$dir/$modfname.dll";
222	last if $file = ( (-f $try) && $try);
223
224	$try = "$dir/${modfname}_1.dll";
225	last if $file = ( (-f $try) && $try);
226	push @dirs, $dir;
227    }
228    $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
229
230    croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
231	unless $file;
232
233    (my $bootname = "boot_$module") =~ s/\W/_/g;
234    @dl_require_symbols = ($bootname);
235
236    # optional '.bootstrap' perl script
237    my $bs = $file;
238    $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/;
239    if (-s $bs) { # only read file if it's not empty
240        eval { do $bs; };
241        warn "$bs: $@\n" if $@;
242    }
243
244    my $libref = dl_load_file($file, 0) or
245	croak("Can't load '$file' for module $module: ".dl_error());
246
247    push(@dl_librefs,$libref);  # record loaded object
248
249    my @unresolved = dl_undef_symbols();
250    if (@unresolved) {
251	require Carp;
252	Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
253    }
254
255    my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or
256         croak("Can't find '$bootname' symbol in $file\n");
257
258    push(@dl_modules, $module);
259
260  boot:
261    my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
262    &$xs(@args);
263}
264
265sub dl_findfile {
266    my (@args) = @_;
267    my (@dirs,  $dir);
268    my (@found);
269
270    arg: foreach(@args) {
271        if (m:/: && -f $_) {
272	    push(@found,$_);
273	    last arg unless wantarray;
274	    next;
275	}
276
277        if (s:^-L::) {push(@dirs, $_); next;}
278        if (m:/: && -d $_) {push(@dirs, $_); next;}
279
280        for $dir (@dirs) {
281            next unless -d $dir;
282            for my $name (/\.dll$/i?($_):("$_.dll",$_)) {
283                print STDERR " checking in $dir for $name\n" if $dl_debug;
284        	if (-f "$dir/$name") {
285                    push(@found, "$dir/$name");
286                    next arg;
287                }
288            }
289        }
290    }
291    return $found[0] unless wantarray;
292    @found;
293}
294EOS
295}
296
297