File: xtract

package info (click to toggle)
msql-mysql-modules 1.2005-1
  • links: PTS
  • area: contrib
  • in suites: slink
  • size: 744 kB
  • ctags: 412
  • sloc: perl: 4,402; ansic: 1,753; makefile: 73
file content (87 lines) | stat: -rw-r--r-- 1,893 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
# -*- perl -*-

require 5.004;
use strict;
require Config;
require File::Basename;
require File::Path;

my($EXPERIMENTAL) = 1;


use vars qw($MyConfig);

if (!$MyConfig) {
    my $file;
    foreach $file (".status", "../.status") {
	if (-f $file) {
	    $@ = '';
	    $MyConfig = do $file;
	    if ($@) {
		die "Error while loading $file: $@";
	    }
	    last;
	}
    }
    if (!$MyConfig) {
	die "No such file: .status";
    }
}


sub Extract ($$$$$$) {
    my($from, $to, $driver, $dbd_driver, $version, $dbd_version) = @_;
    my($on) = 1;
	
    my $dir = File::Basename::dirname($to);
    if (!(-d $dir)  &&  !File::Path::mkpath([$dir], 0, 0755)) {
	die "Cannot create directory $dir: $!";
    }

    if (!open(IN, "<$from")) {
	print STDERR "Cannot open $from for reading: $!\n";
	exit 10;
    }
    my ($line, $contents);
    $contents = '';
    while (defined($line = <IN>)) {
	if ($line =~ /^\#xtract\s+(\S+)\s*$/) {
	    $on = ($1 eq $driver)
		||  ($1 eq 'experimental'  &&  $EXPERIMENTAL);
	} elsif ($line =~ /^\#endxtract\s*/) {
	    $on = 1;
	} elsif ($on) {
	    $contents .= $line;
	}
    }
    close IN;

    $contents =~ s/\~startperl\~/$Config::Config{startperl}/;
    $contents =~ s/\~DRIVER\~/$driver/g;
    $contents =~ s/\~DBD_DRIVER\~/$dbd_driver/g;
    $contents =~ s/\~NODBD_VERSION\~/$version/g;
    $contents =~ s/\~DBD_VERSION\~/$dbd_version/g;
    $contents =~ s/\~(\w+)\~/$MyConfig->{$dbd_driver}->{$1}/eg;

    if (!open(OUT, ">$to")) {
	print STDERR "Cannot open $to for writing: $!\n";
	exit 10;
    }
    
    if (!(print OUT $contents)  ||  !close(OUT)) {
	print STDERR "Cannot write $to: $!\n";
	exit 10;
    }
}

if (!$ENV{'XTRACT_NOT_RUNNING'}) {
    if (@ARGV != 6) {
	print "Usage: $0 <from> <to> <driver> <dbd_driver> <version>",
	    " <dbd_version>\n";
	exit 10;
    }

    Extract($ARGV[0], $ARGV[1], $ARGV[2], $ARGV[3], $ARGV[4], $ARGV[5]);
}

1;