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