1#!/usr/bin/perl
2
3use ExtUtils::MakeMaker;
4
5my $separator = "\n" . ( '=' x 79 ) . "\n";
6
7########################################################################
8
9print "\nReading test connection definitions from test.cfg file...\n";
10
11if ( -f 'test.cfg' ) {
12  open( CNXNS, 'test.cfg' ) or die $!;
13  @dsns = <CNXNS>;
14  chomp @dsns;
15  close( CNXNS ) or die $!;
16  print "  Found " . scalar(@dsns) . " lines.\n\n";
17} else {
18  print "  No test.cfg file found.\n\n";
19}
20
21########################################################################
22
23print "Loading DBI to query for available drivers and suggested DSNs...\n";
24
25require DBI;
26
27my %common_cases = (
28  'AnyData' => 'dbi:AnyData:',
29  'mysql'   => 'dbi:mysql:test',
30  'Pg'      => 'dbi:Pg:dbname=test',
31  'SQLite'  => 'dbi:SQLite:dbname=test_data/test.sqlite',
32  'Solid'   => 'dbi:Solid:',
33  'Sprite'  => 'dbi:Sprite:test_data',
34  'XBase'   => 'dbi:XBase:test_data',
35);
36my @exclude_patterns = (
37  'dbi:ExampleP', # Insufficient capabilities
38  'dbi:File',     # Insufficient capabilities
39  'AnyData:($|(?!test_data))', # for file-based DBDs, don't show other directories
40  'f_dir\\=(?!test_data)', # for file-based DBDs, don't show other directories
41);
42
43my @suggestions;
44foreach my $driver ( DBI->available_drivers ) {
45  eval {
46    DBI->install_driver($driver);
47    my @data_sources;
48    eval {
49      @data_sources = DBI->data_sources($driver);
50    };
51    push @data_sources, split(' ', $common_cases{$driver} || '');
52    if (@data_sources) {
53      foreach my $source ( @data_sources ) {
54	push @suggestions, ($source =~ /:/ ? $source : "dbi:$driver:$source");
55      }
56    } else {
57      push @suggestions, "dbi:$driver";
58    }
59  };
60}
61
62@suggestions = map { s{^(dbi:)(\w+)(.*?)(test_data)(.*)}{$1$2$3$4/\L$2\E$5}i; $_ } @suggestions;
63@suggestions = grep { my $s = $_; ! grep { $s =~ /$_/i } @exclude_patterns } @suggestions;
64
65my %byname = map { $_ => 1 } @suggestions;
66@suggestions = sort { lc($a) cmp lc($b) } keys %byname;
67
68if ( my $count = scalar @suggestions ) {
69  print "  Found $count suggestions.\n";
70} else {
71  print "  No suggestions found.\n";
72}
73
74########################################################################
75
76my $needs_save;
77while (1) {
78
79  print $separator;
80
81  if ( scalar @dsns ) {
82    print "\nThe current configuration in test.cfg is listed below:\n";
83    foreach ( 1 .. scalar @dsns ) {
84      print "  $_: $dsns[ $_ - 1 ]\n";
85    }
86  } else {
87    print "\nYou do not currently have any configurations in test.cfg\n";
88  }
89
90  my @available = grep { my $s = $_; ! grep { $_ eq $s } @dsns } @suggestions;
91  my %additions;
92  if ( scalar @available ) {
93    print "\nAvailable suggestions:\n";
94    my $a = 'a';
95    foreach my $dsn ( @available ) {
96      print "  $a: $dsn\n";
97      $additions{ $a } = $dsn;
98      ++ $a;
99    }
100  }
101
102  my $prompt = "Enter " . join( ', ',
103	'a new driver string',
104	( @dsns ? 'a number to edit' : () ),
105	( @available ? 'a letter to add' : () ),
106	'or q to quit'
107      );
108
109  my $next = prompt("\n$prompt:\n>");
110
111  if ( $next !~ /\S/ or $next =~ /^\s*q(uit)?\s*$/ ) {
112    last;
113
114  } elsif ( $next =~ /^\s*([a-z])\s*$/ ) {
115    my $line = $1;
116    unless ( exists $additions{ $line } ) {
117      print "Can't add '$line', no such suggestion.\n";
118      next;
119    }
120    push @dsns, $additions{ $line };
121    $needs_save ++;
122
123  } elsif ( $next =~ /^\s*(\d+)\s*$/ ) {
124    my $line = $1;
125    unless ( $line >= 0 and $line <= scalar @dsns ) {
126      print "Can't edit '$line', no such definition.\n";
127      next;
128    }
129    print "Current value for $line: $dsns[ $line -1 ]\n";
130    my $edit = prompt("Enter a new value or press return to delete: \n>");
131    if ( $edit =~ /^\s*(\S.*?)\s*$/ ) {
132      $dsns[ $line -1 ] = $1;
133    } else {
134      splice @dsns, $line -1, 1;
135    }
136    $needs_save ++;
137  } else {
138    push @dsns, $next;
139    $needs_save ++;
140  }
141}
142
143print $separator;
144
145if ( $needs_save ) {
146  print "\nWriting " . scalar(@dsns) . " connections to test.cfg file...\n";
147
148  open( CNXNS, '>test.cfg' ) or die $!;
149  print CNXNS map "$_\n", @dsns;
150  close( CNXNS ) or die $!;
151}
152
153print "\nDone.\n\n";
154
1551;
156