Changeset 30347 for gs2-extensions/tdb
- Timestamp:
- 2015-12-10T12:19:20+13:00 (8 years ago)
- Location:
- gs2-extensions/tdb/trunk/perllib
- Files:
-
- 8 edited
Legend:
- Unmodified
- Added
- Removed
-
gs2-extensions/tdb/trunk/perllib/DBDrivers/70HyphenFormat.pm
r30341 r30347 32 32 # 33 33 ############################################################################### 34 35 # Note: This driver may be a candidate for further splitting, maybe into a 36 # PipedExecutableDriver and a 70HyphenFormatDriver... but for now all piped 37 # drivers are 70 hyphen format ones, so, yeah. 34 38 35 39 package DBDrivers::70HyphenFormat; … … 59 63 $self->{'read_executable'} = 'error'; 60 64 $self->{'write_executable'} = 'error'; 65 $self->{'forced_affinity'} = -1; # Set to processor number for forced affinity 61 66 bless($self, $class); 62 67 return $self; … … 68 73 69 74 70 ## @function close_infodb_handle(filehandle)71 #72 sub close_infodb_handle73 {74 my $self = shift(@_);75 my $infodb_handle = shift(@_);76 $self->debugPrintFunctionHeader();77 close($infodb_handle);78 }79 ## close_infodb_handle(filehandle) => void ##80 81 82 75 ## @function close_infodb_write_handle(filehandle) 83 76 # … … 85 78 { 86 79 my $self = shift(@_); 87 $self->close_infodb_handle(@_); 80 $self->debugPrintFunctionHeader(@_); 81 my $handle = shift(@_); 82 my $force_close = shift(@_); # Undefined most of the time 83 my $continue_close = $self->removeConnectionIfPersistent($handle, $force_close); 84 if ($continue_close) { 85 close($handle); 86 } 87 return; 88 88 } 89 89 ## close_infodb_write_handle(filehandle) => void ## … … 142 142 { 143 143 my $self = shift(@_); 144 $self->debugPrintFunctionHeader(@_); 144 145 my $infodb_handle = shift(@_); 145 146 my $infodb_key = shift(@_); 146 147 147 # A minus at the end of a key (after the ]) signifies 'delete' 148 print $infodb_handle "[$infodb_key]-\n"; 149 148 print $infodb_handle '[' . $infodb_key . ']-' . "\n"; 150 149 # The 70 minus signs are also needed, to help make the parsing by db2txt simple 151 150 print $infodb_handle '-' x 70, "\n"; … … 160 159 my $self = shift(@_); 161 160 $self->debugPrintFunctionHeader(@_); 162 my $infodb_file_handle = $self->openWriteHandle(@_); 161 my $path = shift(@_); 162 my $append = shift(@_); 163 my $infodb_file_handle = $self->retrieveConnectionIfPersistent($path, $append);; 164 # No available existing connection 165 if (!defined $infodb_file_handle || !$infodb_file_handle) { 166 $infodb_file_handle = $self->openWriteHandle($path, $append, @_); 167 $self->registerConnectionIfPersistent($infodb_file_handle, $path, $append); 168 } 163 169 return $infodb_file_handle; 164 170 } … … 181 187 } 182 188 my $infodb_file_handle = undef; 183 my $cmd = '"' . $exe . '" ' . $default_args; 189 my $cmd = ''; 190 if ($self->{'forced_affinity'} >= 0) 191 { 192 $cmd = 'taskset -c ' . $self->{'forced_affinity'} . ' '; 193 } 194 $cmd .= '"' . $exe . '" ' . $default_args; 184 195 foreach my $open_arg (@_) { 196 # Special - append is typically missing a hyphen 197 if ($open_arg eq 'append') { 198 $open_arg = '-append'; 199 } 185 200 $cmd .= ' ' . $open_arg; 186 201 } … … 199 214 200 215 ## @function openReadHandle(string, string) => filehandle 216 # 201 217 sub openReadHandle 202 218 { … … 207 223 208 224 225 ## @function openWriteHandle(*) => filehandle 226 # 209 227 sub openWriteHandle 210 228 { … … 212 230 return $self->openPipedHandle(RWMODE_WRITE, $self->{'write_executable'}, @_); 213 231 } 232 ## openWriteHandle(*) => filehandle ## 233 214 234 215 235 ## @function read_infodb_entry(string, string) => hashmap … … 232 252 my $infodb_file_path = shift(@_); 233 253 my $infodb_map = shift(@_); 254 $self->debugPrintFunctionHeader($infodb_file_path, $infodb_map); 234 255 my $infodb_file_handle = $self->openReadHandle($infodb_file_path); 235 256 my $infodb_line = ""; … … 250 271 } 251 272 } 252 $self->close_infodb_ handle($infodb_file_handle);273 $self->close_infodb_write_handle($infodb_file_handle); 253 274 } 254 275 ## read_infodb_file(string, hashmap) => void ## … … 291 312 } 292 313 } 293 $self->close_infodb_ handle($infodb_file_handle);314 $self->close_infodb_write_handle($infodb_file_handle); 294 315 } 295 316 ## read_infodb_keys(string, hashmap) => void ## … … 354 375 print $infodb_file_handle "[$infodb_key]\n"; 355 376 print $infodb_file_handle "$serialized_infodb_map\n"; 356 $self->close_infodb_ handle($infodb_file_handle);377 $self->close_infodb_write_handle($infodb_file_handle); 357 378 $status = 0; # as in exit status of cmd OK 358 379 } -
gs2-extensions/tdb/trunk/perllib/DBDrivers/BaseDBDriver.pm
r30343 r30347 44 44 # Debug messages for this driver 45 45 $self->{'debug'} = $debug; # 1 to enable 46 # Keep track of all opened file handles, but only for drivers that support 47 # persistent connections 48 $self->{'handle_pool'} = {}; 46 49 # Default file extension - in this case it is an error to create a DB from 47 50 # BaseDBDriver 48 51 $self->{'default_file_extension'} = 'err'; 49 52 # Support 53 $self->{'supports_datestamp'} = 0; 54 $self->{'supports_merge'} = 0; 55 $self->{'supports_persistentconnection'} = 0; 56 $self->{'supports_rss'} = 0; 50 57 $self->{'supports_set'} = 0; 51 58 bless($self, $class); … … 68 75 if ($self->{'debug'}) { 69 76 my ($seconds, $microseconds) = gettimeofday(); 70 print STDERR '[DEBUG:' . $seconds . '.' . $microseconds . '] ' . (caller 1)[3] . $message . "\n";77 print STDERR '[DEBUG:' . $seconds . '.' . $microseconds . '] ' . (caller 1)[3] . '() ' . $message . "\n"; 71 78 } 72 79 } … … 112 119 ## errorPrint(string, integer) => void ## 113 120 121 122 ## @function registerConnectionIfPersistent(filehandle, string, string) => void 123 # 124 sub registerConnectionIfPersistent 125 { 126 my $self = shift(@_); 127 my $conn = shift(@_); 128 my $path = shift(@_); 129 my $append = shift(@_); 130 if ($self->{'supports_persistentconnection'}) { 131 $self->debugPrintFunctionHeader($conn, $path, $append); 132 my $fhid = $path; 133 if (defined $append && $append eq '-append') { 134 $fhid .= ' [APPEND]'; 135 } 136 $self->debugPrint('Registering connection: "' . $fhid . '"'); 137 $self->{'handle_pool'}->{$fhid} = $conn; 138 } 139 return; 140 } 141 ## registerConnectionIfPersistent(filehandle, string, string) => void ## 142 143 144 ## @function removeConnectionIfPersistent(filehandle, string) => integer 145 # 146 sub removeConnectionIfPersistent 147 { 148 my $self = shift(@_); 149 my $handle = shift(@_); 150 my $force_close = shift(@_); 151 my $continue_close = 1; 152 if ($self->{'supports_persistentconnection'}) { 153 $self->debugPrintFunctionHeader($handle, $force_close); 154 if (defined($force_close)) { 155 # We'll need the file path so we can locate and remove the entry 156 # in the handle pool (plus possibly the [APPEND] suffix for those 157 # connections in opened in append mode) 158 my $fhid = undef; 159 # Sometimes we can cheat, as the force_close variable will have the 160 # file_path in it thanks to the DESTROY block above. Doing a regex 161 # on force_close will treat it like a string no matter what it was, 162 # and we can search for the appropriate file extension that should 163 # be there for valid paths. 164 my $pattern = '\.' . $self->{'default_file_extension'} . '(\s\[APPEND\])?$'; 165 if ($force_close =~ /$pattern/) { 166 $fhid = $force_close; 167 } 168 # If we can't cheat then we are stuck finding which connection in 169 # the handle_pool we are about to close. Need to compare objects 170 # using refaddr() 171 else { 172 foreach my $possible_fhid (keys %{$self->{'handle_pool'}}) { 173 my $possible_handle = $self->{'handle_pool'}->{$possible_fhid}; 174 if (ref($handle) && ref($possible_handle) && refaddr($handle) == refaddr($possible_handle)) { 175 $fhid = $possible_fhid; 176 last; 177 } 178 } 179 } 180 # If we found the fhid we can proceed to close the connection 181 if (defined($fhid)) { 182 $self->debugPrint('Closing persistent connection: ' . $fhid); 183 delete($self->{'handle_pool'}->{$fhid}); 184 $continue_close = 1; 185 } 186 else { 187 print STDERR "Warning! About to close persistent database handle, but couldn't locate in open handle pool.\n"; 188 } 189 } 190 # Persistent connection don't close *unless* force close is set 191 else { 192 $continue_close = 0; 193 } 194 } 195 return $continue_close; 196 } 197 ## removeConnectionIfPersistent(filehandle, string) => integer ## 198 199 200 ## 201 # 202 sub retrieveConnectionIfPersistent 203 { 204 my $self = shift(@_); 205 my $path = shift(@_); 206 my $append = shift(@_); # -append support 207 my $conn; # This should be populated 208 if ($self->{'supports_persistentconnection'}) { 209 $self->debugPrintFunctionHeader($path, $append); 210 my $fhid = $path; 211 # special case: if the append mode has changed for a persistent 212 # connection, we need to close the old connection first or things 213 # will get wiggy. 214 if (defined $append && $append eq '-append') { 215 # see if there is a non-append mode connection already open 216 if (defined $self->{'handle_pool'}->{$path}) { 217 $self->debugPrint("Append mode added - closing existing non-append mode connection"); 218 my $old_conn = $self->{'handle_pool'}->{$path}; 219 $self->close_infodb_write_handle($old_conn, $path); 220 } 221 # Append -append so we know what happened. 222 $fhid .= ' [APPEND]'; 223 } 224 else { 225 my $fhid_append = $path . ' [APPEND]'; 226 if (defined $self->{'handle_pool'}->{$fhid_append}) { 227 $self->debugPrint("Append mode removed - closing existing append mode connection"); 228 my $old_conn = $self->{'handle_pool'}->{$fhid_append}; 229 $self->close_infodb_write_handle($old_conn, $fhid_append); 230 } 231 } 232 if (defined $self->{'handle_pool'}->{$fhid}) { 233 $self->debugPrint('Retrieving existing connection: ' . $fhid); 234 $conn = $self->{'handle_pool'}->{$fhid}; 235 } 236 } 237 return $conn; 238 } 239 ## ## 240 241 242 243 244 245 246 114 247 ############################################################################### 115 248 ## Public Functions … … 126 259 my $infodb_file_name = &util::get_dirsep_tail($collection_name) . '.' . $self->{'default_file_extension'}; 127 260 my $infodb_file_path = &FileUtils::filenameConcatenate($infodb_directory_path, $infodb_file_name); 261 # Correct the path separators to work in Cygwin 262 if ($^O eq "cygwin") { 263 $infodb_file_path = `cygpath -w "$infodb_file_path"`; 264 chomp($infodb_file_path); 265 $infodb_file_path =~ s%\\%\\\\%g; 266 } 128 267 return $infodb_file_path; 129 268 } … … 131 270 132 271 133 ## @function supportsDatestamp(void) => boolean272 ## @function supportsDatestamp(void) => integer 134 273 # 135 274 sub supportsDatestamp 136 275 { 137 276 my $self = shift(@_); 138 return 0;139 } 140 ## supportsDatestamp(void) => boolean##277 return $self->{'supports_datestamp'}; 278 } 279 ## supportsDatestamp(void) => integer ## 141 280 142 281 … … 146 285 { 147 286 my $self = shift(@_); 148 return 0; 149 } 150 ## supportsMerge(void) => boolean ## 151 152 153 ## @function supportsRSS(void) => boolean 287 return $self->{'supports_merge'}; 288 } 289 ## supportsMerge(void) => integer ## 290 291 292 ## @function supportsPersistentConnection(void) => integer 293 # 294 sub supportsPersistentConnection 295 { 296 my $self = shift(@_); 297 return $self->{'supports_persistentconnection'}; 298 } 299 ## supportsPersistentConnection(void) => integer ## 300 301 302 ## @function supportsRSS(void) => integer 154 303 # 155 304 sub supportsRSS 156 305 { 157 306 my $self = shift(@_); 158 return 0;159 } 160 ## supportsRSS(void) => boolean##307 return $self->{'supports_rss'}; 308 } 309 ## supportsRSS(void) => integer ## 161 310 162 311 -
gs2-extensions/tdb/trunk/perllib/DBDrivers/GDBM.pm
r30342 r30347 29 29 use strict; 30 30 31 BEGIN 32 { 33 if (!defined $ENV{'GSDLHOME'} || !defined $ENV{'GSDLOS'}) { 34 die("Error! Environment not prepared. Have you sourced setup.bash?\n"); 35 } 36 } 37 31 38 # Libraries 32 39 use util; … … 47 54 $self->{'keyread_executable'} = 'gdbmkeys'; 48 55 $self->{'write_executable'} = 'txt2db'; 56 # Optional Support 49 57 $self->{'supports_set'} = 1; 50 58 bless($self, $class); … … 59 67 60 68 # Handled by BaseDBDriver 61 # sub get_infodb_file_path(string, string) 69 # sub get_infodb_file_path(string, string) => string 62 70 63 71 # Handled by 70HyphenFormat 72 # sub open_infodb_write_handle(string, string?) => filehandle 64 73 # sub close_infodb_write_handle(filehandle) => void 65 74 # sub delete_infodb_entry(filehandle, string) => void … … 72 81 # sub write_infodb_rawentry(filehandle, string, string) => void 73 82 74 75 ## @function open_infodb_write_handle(string, string*) => filehandle76 #77 # Handles legacy use of optional 'append' argument where '-append' is required78 #79 sub open_infodb_write_handle80 {81 my $self = shift(@_);82 my $infodb_file_path = shift(@_);83 my $opt_append = shift(@_);84 my $infodb_file_handle;85 if (defined $opt_append) {86 if ($opt_append eq 'append') {87 $opt_append = '-append';88 }89 $infodb_file_handle = $self->SUPER::open_infodb_write_handle($infodb_file_path, $opt_append);90 }91 else92 {93 $infodb_file_handle = $self->SUPER::open_infodb_write_handle($infodb_file_path);94 }95 return $infodb_file_handle;96 }97 ## open_infodb_write_handle(string, string*) => filehandle ##98 99 83 1; -
gs2-extensions/tdb/trunk/perllib/DBDrivers/GDBMTXTGZ.pm
r30344 r30347 77 77 # other 78 78 # 79 # All this function does now is turn the optional 'append'argument into the80 # appropriate operator for either appending to or clobbering gzip file.79 # Now only responsible for transforming the optional append argument into the 80 # correct redirection operand (either > for clobber or >> for append) 81 81 # 82 82 sub open_infodb_write_handle … … 98 98 ## open_infodb_write_handle(string) => filehandle ## 99 99 100 101 100 ## @function set_infodb_entry(string, string, hashmap) 102 101 # -
gs2-extensions/tdb/trunk/perllib/DBDrivers/JDBM.pm
r30338 r30347 33 33 use FileUtils; 34 34 # - OO inheritence 35 use parent 'DBDrivers:: BaseDBDriver';35 use parent 'DBDrivers::70HyphenFormat'; 36 36 37 37 sub BEGIN … … 48 48 { 49 49 my $class = shift(@_); 50 my $self = DBDrivers:: BaseDBDriver->new();50 my $self = DBDrivers::70HyphenFormat->new(@_); 51 51 $self->{'default_file_extension'} = 'jdb'; 52 53 # Executables need a little extra work since we are using Java 54 # - we need to build up the classpath continue the Jar libraries to use 55 my $jdbmwrap_jar = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, 'bin', 'java', 'JDBMWrapper.jar'); 56 my $jdbm_jar = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, 'lib', 'java', 'jdbm.jar'); 57 my $classpath = &util::pathname_cat($jdbmwrap_jar,$jdbm_jar); 58 # Massage paths for Cygwin. Away to run a java program, using a binary that 59 # is native to Windows, so need Windows directory and path separators 60 if ($^O eq "cygwin") { 61 $classpath = `cygpath -wp "$classpath"`; 62 chomp($classpath); 63 $classpath =~ s%\\%\\\\%g; 64 } 65 $self->{'executable_path'} = ''; 66 $self->{'read_executable'} = 'java -cp "' . $classpath . '" Jdb2Txt'; 67 $self->{'keyread_executable'} = 'java -cp "' . $classpath . '" JdbKeys'; 68 $self->{'write_executable'} = 'java -cp "' . $classpath . '" Txt2Jdb'; 69 # Support 70 $self->{'supports_set'} = 1; 71 52 72 bless($self, $class); 53 73 return $self; … … 68 88 # sub get_infodb_file_path {} 69 89 70 71 72 sub open_infodb_write_handle 73 { 74 my $self = shift(@_); 75 my $infodb_file_path = shift(@_); 76 my $opt_append = shift(@_); 77 if (!defined $opt_append) { 78 $opt_append = ''; 79 } 80 $self->_debugPrint('("' . $infodb_file_path . '","' . $opt_append . '")'); 81 82 my $jdbmwrap_jar = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"bin","java", "JDBMWrapper.jar"); 83 my $jdbm_jar = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"lib","java", "jdbm.jar"); 84 85 my $classpath = &util::pathname_cat($jdbmwrap_jar,$jdbm_jar); 86 87 if ($^O eq "cygwin") { 88 # Away to run a java program, using a binary that is native to Windows, so need 89 # Windows directory and path separators 90 91 $classpath = `cygpath -wp "$classpath"`; 92 chomp($classpath); 93 $classpath =~ s%\\%\\\\%g; 94 } 95 96 my $infodb_file_handle = undef; 97 my $txt2jdb_cmd = "java -cp \"$classpath\" Txt2Jdb"; 98 99 if ($opt_append eq "append") { 100 $txt2jdb_cmd .= " -append"; 101 print STDERR "Append operation to $infodb_file_path\n"; 102 } 103 else { 104 print STDERR "Create database $infodb_file_path\n"; 105 } 106 107 # Lop off file extension, as JDBM does not expect this to be present 108 $infodb_file_path =~ s/\.jdb$//; 109 110 if ($^O eq "cygwin") { 111 $infodb_file_path = `cygpath -w "$infodb_file_path"`; 112 chomp($infodb_file_path); 113 $infodb_file_path =~ s%\\%\\\\%g; 114 } 115 116 $txt2jdb_cmd .= " \"$infodb_file_path\""; 117 118 if (!open($infodb_file_handle, "| $txt2jdb_cmd")) 119 { 120 print STDERR "Error: Failed to open pipe to $txt2jdb_cmd"; 121 print STDERR " $!\n"; 122 return undef; 123 } 124 125 binmode($infodb_file_handle,":utf8"); 126 return $infodb_file_handle; 127 } 128 129 130 131 sub close_infodb_write_handle 132 { 133 my $infodb_handle = shift(@_); 134 135 close($infodb_handle); 136 } 137 138 139 sub read_infodb_file 140 { 141 my $infodb_file_path = shift(@_); 142 my $infodb_map = shift(@_); 143 144 my $jdbmwrap_jar = &util::filename_cat($ENV{'GSDLHOME'},"bin","java", "JDBMWrapper.jar"); 145 my $jdbm_jar = &util::filename_cat($ENV{'GSDLHOME'},"lib","java", "jdbm.jar"); 146 147 my $classpath = &util::pathname_cat($jdbmwrap_jar,$jdbm_jar); 148 149 if ($^O eq "cygwin") { 150 # Away to run a java program, using a binary that is native to Windows, so need 151 # Windows directory and path separators 152 153 $classpath = `cygpath -wp "$classpath"`; 154 chomp($classpath); 155 $classpath =~ s%\\%\\\\%g; 156 157 $infodb_file_path = `cygpath -w "$infodb_file_path"`; 158 chomp($infodb_file_path); 159 $infodb_file_path =~ s%\\%\\\\%g; 160 } 161 162 my $jdb2txt_cmd = "java -cp \"$classpath\" Jdb2Txt"; 163 164 open (PIPEIN, "$jdb2txt_cmd \"$infodb_file_path\" |") || die "couldn't open pipe from db2txt \$infodb_file_path\"\n"; 165 binmode(PIPEIN,":utf8"); 166 my $infodb_line = ""; 167 my $infodb_key = ""; 168 my $infodb_value = ""; 169 while (defined ($infodb_line = <PIPEIN>)) 170 { 171 $infodb_line =~ s/(\r\n)+$//; # more general than chomp 172 173 if ($infodb_line =~ /^\[([^\]]+)\]$/) 174 { 175 $infodb_key = $1; 176 } 177 elsif ($infodb_line =~ /^-{70}$/) 178 { 179 $infodb_map->{$infodb_key} = $infodb_value; 180 $infodb_key = ""; 181 $infodb_value = ""; 182 } 183 else 184 { 185 $infodb_value .= $infodb_line; 186 } 187 } 188 189 close (PIPEIN); 190 } 191 192 sub read_infodb_keys 193 { 194 my $infodb_file_path = shift(@_); 195 my $infodb_map = shift(@_); 196 197 my $jdbmwrap_jar = &util::filename_cat($ENV{'GSDLHOME'},"bin","java", "JDBMWrapper.jar"); 198 my $jdbm_jar = &util::filename_cat($ENV{'GSDLHOME'},"lib","java", "jdbm.jar"); 199 200 my $classpath = &util::pathname_cat($jdbmwrap_jar,$jdbm_jar); 201 202 my $jdbkeys_cmd = "java -cp \"$classpath\" JdbKeys"; 203 204 open (PIPEIN, "$jdbkeys_cmd \"$infodb_file_path\" |") || die "couldn't open pipe from jdbmkeys \$infodb_file_path\"\n"; 205 binmode(PIPEIN,":utf8"); 206 my $infodb_line = ""; 207 my $infodb_key = ""; 208 my $infodb_value = ""; 209 while (defined ($infodb_line = <PIPEIN>)) 210 { 211 # chomp $infodb_line; # remove end of line 212 $infodb_line =~ s/(\r\n)+$//; # more general than chomp 213 214 $infodb_map->{$infodb_line} = 1; 215 } 216 217 close (PIPEIN); 218 } 219 220 221 222 sub write_infodb_entry 223 { 224 225 my $infodb_handle = shift(@_); 226 my $infodb_key = shift(@_); 227 my $infodb_map = shift(@_); 228 229 print $infodb_handle "[$infodb_key]\n"; 230 foreach my $infodb_value_key (keys(%$infodb_map)) 231 { 232 foreach my $infodb_value (@{$infodb_map->{$infodb_value_key}}) 233 { 234 if ($infodb_value =~ /-{70,}/) 235 { 236 # if value contains 70 or more hyphens in a row we need to escape them 237 # to prevent txt2db from treating them as a separator 238 $infodb_value =~ s/-/&\#045;/gi; 239 } 240 print $infodb_handle "<$infodb_value_key>" . $infodb_value . "\n"; 241 } 242 } 243 print $infodb_handle '-' x 70, "\n"; 244 } 245 246 247 sub write_infodb_rawentry 248 { 249 250 my $infodb_handle = shift(@_); 251 my $infodb_key = shift(@_); 252 my $infodb_val = shift(@_); 253 254 print $infodb_handle "[$infodb_key]\n"; 255 print $infodb_handle "$infodb_val\n"; 256 print $infodb_handle '-' x 70, "\n"; 257 } 258 259 sub set_infodb_entry 260 { 261 my $infodb_file_path = shift(@_); 262 my $infodb_key = shift(@_); 263 my $infodb_map = shift(@_); 264 265 # HTML escape anything that is not part of the "contains" metadata value 266 foreach my $k (keys %$infodb_map) { 267 my @escaped_v = (); 268 foreach my $v (@{$infodb_map->{$k}}) { 269 if ($k eq "contains") { 270 push(@escaped_v, $v); 271 } 272 else { 273 my $ev = &ghtml::unescape_html($v); 274 push(@escaped_v, $ev); 275 } 276 } 277 $infodb_map->{$k} = \@escaped_v; 278 } 279 280 # Generate the record string 281 my $serialized_infodb_map = &dbutil::convert_infodb_hash_to_string($infodb_map); 282 ### print STDERR "**** ser dr\n$serialized_infodb_map\n\n\n"; 283 284 # Store it into JDBM using 'Txt2Jdb .... -append' which despite its name 285 # actually replaces the record if it already exists 286 287 my $jdbmwrap_jar = &util::filename_cat($ENV{'GSDLHOME'},"bin","java", "JDBMWrapper.jar"); 288 my $jdbm_jar = &util::filename_cat($ENV{'GSDLHOME'},"lib","java", "jdbm.jar"); 289 290 my $classpath = &util::pathname_cat($jdbmwrap_jar,$jdbm_jar); 291 292 # Lop off file extension, as JDBM does not expect this to be present 293 $infodb_file_path =~ s/\.jdb$//; 294 295 if ($^O eq "cygwin") { 296 # Away to run a java program, using a binary that is native to Windows, so need 297 # Windows directory and path separators 298 299 $classpath = `cygpath -wp "$classpath"`; 300 chomp($classpath); 301 $classpath =~ s%\\%\\\\%g; 302 303 $infodb_file_path = `cygpath -w "$infodb_file_path"`; 304 chomp($infodb_file_path); 305 $infodb_file_path =~ s%\\%\\\\%g; 306 } 307 308 my $cmd = "java -cp \"$classpath\" Txt2Jdb -append \"$infodb_file_path\""; 309 310 my $status = undef; 311 if(!open(GOUT, "| $cmd")) 312 { 313 print STDERR "Error: jdbm::set_infodb_entry() failed to open pipe to: $cmd\n"; 314 print STDERR " $!\n"; 315 $status = -1; 316 } 317 else { 318 binmode(GOUT,":utf8"); 319 320 print GOUT "[$infodb_key]\n"; 321 print GOUT "$serialized_infodb_map\n"; 322 323 close(GOUT); 324 $status = 0; # as in exit status of cmd OK 325 } 326 327 return $status; 328 } 329 330 331 332 333 sub delete_infodb_entry 334 { 335 my $infodb_handle = shift(@_); 336 my $infodb_key = shift(@_); 337 338 # A minus at the end of a key (after the ]) signifies 'delete' 339 print $infodb_handle "[$infodb_key]-\n"; 340 341 # The 70 minus signs are also needed, to help make the parsing by db2txt simple 342 print $infodb_handle '-' x 70, "\n"; 343 } 90 # Handles by 70HyphenFormat 91 # sub open_infodb_write_handle(string, string?) => filehandle 92 # sub close_infodb_write_handle(filehandle) => void 93 # sub read_infodb_file(string, hashmap) => void 94 # sub read_infodb_keys(string, hashmap) => void 95 # sub write_infodb_entry(filehandle, string, hashmap) => void 96 # sub write_infodb_rawentry(filehandle, string, string) => void 97 # sub set_infodb_entry(filehandle, string, string) => void 98 # sub delete_infodb_entry(filehandle, string) => void 344 99 345 100 1; -
gs2-extensions/tdb/trunk/perllib/DBDrivers/Readme.txt
r30331 r30347 1 1 ===== DBDriver ===== 2 3 Note that there are a couple of Drivers that could be further separated to 4 have even better OO, but I started to get bogged down in multiple inheritence 5 problems so I left them as is for now. For instance, separating PipedExecutable 6 support from the 70HyphenFormat driver would increase flexibility, but then it 7 becomes tricky to say which should inherit from which (in a single inheritence) 8 or what order methods should be resolved (in multiple inheritence). 2 9 3 10 ==== Inheritence Overview ==== 4 11 5 * BaseDBDriver - superclass of all drivers. Some shared utility methods. 6 * PipedDrivers - drivers that write and read their data via pipes to external executables. Data is in simple Greenstone archive form (i.e. key/value pairs and separated by seventy hyphens) 12 * BaseDBDriver - superclass of all drivers. Some shared utility methods 13 including support for persistent connections (ala TDB). 14 Thus this is a candidate for separating out the the 15 PersistentConnectionsDriver. 16 * 70HyphenFormat - drivers that write and read their data via pipes to 17 external executables. Data is in simple Greenstone 18 archive form (i.e. key/value pairs and separated by 19 seventy hyphens) - this is a candidate for further 20 separating out a PipedExecutableDriver. 7 21 * GDBM - makes use of GDBM utils (txt2db, db2txt etc) 8 22 * GDBMTXTGZ - makes use of gzip (for later use with GDBM) -
gs2-extensions/tdb/trunk/perllib/DBDrivers/TDB.pm
r30338 r30347 53 53 my $class = shift(@_); 54 54 55 my $self = DBDrivers::GDBM->new( );55 my $self = DBDrivers::GDBM->new(@_); 56 56 57 57 # Default TDB file extension … … 59 59 # Should the TDB used a specific affinity? 60 60 $self->{'forced_affinity'} = -1; # zero upwards indicates the affinity 61 # Keep track of all opened file handles62 $self->{'handle_pool'} = {};63 61 # Ask TDB executables to display debugging information? 64 $self->{'tdb_debug'} = 0; # 1 to enable 62 $self->{'tdb_debug'} = 1; # 1 to enable 63 64 # note: file separator agnostic 65 $self->{'executable_path'} = $ENV{GEXTTDBEDIT_INSTALLED} . '/bin/'; 66 $self->{'read_executable'} = 'tdb2txt'; 67 $self->{'keyread_executable'} = 'tdbkeys'; 68 $self->{'write_executable'} = 'txt2tdb'; 69 70 # Optional Support 71 $self->{'supports_persistentconnection'} = 1; 72 $self->{'supports_set'} = 1; 65 73 66 74 bless($self, $class); … … 96 104 # ----------------------------------------------------------------------------- 97 105 106 # Handled by BaseDBDriver 107 # sub debugPrint(string) => void 108 # sub debugPrintFunctionHeader(*) => void 109 # sub get_infodb_file_path(string, string) => string 98 110 99 ## @function _get_tdb_executable(string) 100 # 101 sub _get_tdb_executable 102 { 103 my $self = shift(@_); 104 my $program = shift(@_); 105 if (!defined $ENV{GEXTTDBEDIT_INSTALLED} || !-d $ENV{GEXTTDBEDIT_INSTALLED}) 106 { 107 die('Fatal Error! Path to TDB binaries not found. Have you sourced setup.bash?'); 108 } 109 my $program_exe = &util::filename_cat($ENV{GEXTTDBEDIT_INSTALLED} . '/bin/' . $program . &util::get_os_exe()); 110 if (!-x $program_exe) 111 { 112 die('Fatal Error! File doesn\'t exist or isn\'t executable: ' . $program_exe); 113 } 114 return $program_exe; 115 } 116 ## _get_tdb_executable(string) => string ## 117 118 119 # Handled by BaseDBDriver 120 # sub get_infodb_file_path(string, string) 121 122 # With infodb_handle already set up, these functions work the same as parent version 123 # sub delete_infodb_entry {} 124 # sub write_infodb_entry {} 125 # sub write_infodb_rawentry {} 111 # Handled by 70HyphenFormat 112 # sub read_infodb_entry(string, string) => hashmap 113 # sub read_infodb_file(string, hashmap) => void 114 # sub read_infodb_keys(string, hashmap) => void 115 # sub read_infodb_rawentry(string, string) => string 116 # sub set_infodb_entry(string, string, hashmap) => integer 117 # sub write_infodb_entry(filehandle, string, hashmap) => void 118 # sub write_infodb_rawentry(filehandle, string, string) => void 126 119 127 120 … … 144 137 sub close_infodb_write_handle { 145 138 my $self = shift(@_); 139 $self->debugPrintFunctionHeader(@_); 146 140 my $infodb_handle = shift(@_); 147 141 my $actually_close = shift(@_); # Undefined most of the time 148 142 if (defined($actually_close)) { 149 $self->_debugPrint('(<infodb_handle>,"' . $actually_close . '")');150 143 # We'll need the file path so we can locate and remove the entry in the 151 144 # handle pool … … 156 149 # we can search for the appropriate file extension that should be there 157 150 # for valid paths. 158 my $pattern = '\.' . $self->{'default_file_extension'} . ' $';151 my $pattern = '\.' . $self->{'default_file_extension'} . '(\s\[APPEND\])?$'; 159 152 if ($actually_close =~ /$pattern/) { 160 153 $infodb_file_path = $actually_close; … … 173 166 } 174 167 if (defined($infodb_file_path)) { 168 $self->debugPrint('Closing connection: ' . $infodb_file_path); 175 169 delete($self->{'handle_pool'}->{$infodb_file_path}); 176 170 } … … 181 175 $self->SUPER::close_infodb_write_handle($infodb_handle); 182 176 } 177 else { 178 $self->debugPrint('Connection persists for later use.'); 179 } 183 180 } 184 181 ## close_infodb_write_handle(filehandle) => void ## 182 183 # sub delete_infodb_entry {} 185 184 186 185 … … 190 189 { 191 190 my $self = shift(@_); 192 my $infodb_file_path = shift(@_); 193 my $opt_append = shift(@_); 194 195 my $txt2tdb_exe = $self->_get_tdb_executable('txt2tdb'); 196 197 my $cmd = '"' . $txt2tdb_exe . '"'; 198 if ((defined $opt_append) && ($opt_append eq "append")) { 199 $cmd .= ' -append'; 191 if ($self->{'tdb_debug'}) { 192 push(@_, '-debug'); 200 193 } 201 $cmd .= ' "' . $infodb_file_path . '"'; 202 # Optional flags 203 if ($self->{'forced_affinity'} >= 0) { 204 $cmd = 'taskset -c 5 ' . $cmd; 205 } 206 if ($self->{'debug'}) { 207 $cmd .= ' -debug'; 208 } 209 210 # we're going to pipe the key value pairs, in the appropriate format, from 211 # within the buildproc, so we create a piped handle here 212 my $infodb_file_handle = undef; 213 # if the connection is already open, simply return it. 214 if (defined $self->{'handle_pool'}->{$infodb_file_path}) { 215 $infodb_file_handle = $self->{'handle_pool'}->{$infodb_file_path}; 216 } 217 else { 218 $self->_debugPrint('(' . $infodb_file_path . ')'); 219 if(!open($infodb_file_handle, "| $cmd")) { 220 print STDERR "Error: Failed to open pipe to $cmd\n"; 221 print STDERR " $!\n"; 222 return undef; 223 } 224 binmode($infodb_file_handle,":utf8"); 225 # Remember to store the newly created connection in the pool so we can 226 # re-use for subsequent calls. 227 $self->{'handle_pool'}->{$infodb_file_path} = $infodb_file_handle; 228 } 229 return $infodb_file_handle; 194 my $handle = $self->SUPER::open_infodb_write_handle(@_); 195 return $handle; 230 196 } 231 197 ## open_infodb_write_handle(string, string) => filehandle ## 232 198 233 234 ## @function read_infodb_file235 #236 sub read_infodb_file237 {238 my $self = shift(@_);239 my $infodb_file_path = shift(@_);240 my $infodb_map = shift(@_);241 242 $self->_debugPrint('(' . $infodb_file_path . ', <hashmap>)');243 244 my $tdb2txt_exe = $self->_get_tdb_executable('tdb2txt');245 246 if (!open (PIPEIN, '"' . $tdb2txt_exe . '" "' . $infodb_file_path . '" |')) {247 print STDERR 'Error: Failed to open pipe to ' . $tdb2txt_exe . "\n";248 print STDERR " $!\n";249 return undef;250 }251 252 binmode(PIPEIN,":utf8");253 254 my $infodb_line = "";255 my $infodb_key = "";256 my $infodb_value = "";257 while (defined ($infodb_line = <PIPEIN>)) {258 if ($infodb_line =~ /^\[([^\]]+)\]$/) {259 $infodb_key = $1;260 }261 elsif ($infodb_line =~ /^-{70}$/) {262 $infodb_map->{$infodb_key} = $infodb_value;263 $infodb_key = "";264 $infodb_value = "";265 }266 else {267 $infodb_value .= $infodb_line;268 }269 }270 close (PIPEIN);271 }272 ## read_infodb_file(string, hashmap) => void ##273 274 275 ## @function read_infodb_keys(string, hashmap)276 #277 sub read_infodb_keys278 {279 my $self = shift(@_);280 my $infodb_file_path = shift(@_);281 my $infodb_map = shift(@_);282 283 $self->_debugPrint('(' . $infodb_file_path . ', <hashmap>)');284 285 my $tdbkeys_exe = $self->_get_tdb_executable('tdbkeys');286 287 if (!open (PIPEIN, '"' . $tdbkeys_exe . '" "' . $infodb_file_path . '" |')) {288 die("Error! Couldn't open pipe from read_infodb_keys: $infodb_file_path\n$!\n");289 }290 291 binmode(PIPEIN,":utf8");292 293 my $infodb_line = "";294 my $infodb_key = "";295 my $infodb_value = "";296 while (defined ($infodb_line = <PIPEIN>)) {297 # remove end of line298 chomp $infodb_line;299 $infodb_map->{$infodb_line} = 1;300 }301 302 close (PIPEIN);303 }304 ## read_infodb_keys(string, hashmap) => void ##305 306 307 ## @function set_infodb_entry(string, string, hashmap)308 #309 sub set_infodb_entry310 {311 my $self = shift(@_);312 my $infodb_file_path = shift(@_);313 my $infodb_key = shift(@_);314 my $infodb_map = shift(@_);315 316 $self->_debugPrint('(' . $infodb_file_path . ', ' . $infodb_key . ', <hashmap>)');317 318 # Protect metadata values that go inside quotes for tdbset319 foreach my $k (keys %$infodb_map) {320 my @escaped_v = ();321 foreach my $v (@{$infodb_map->{$k}}) {322 if ($k eq "contains") {323 # protect quotes in ".2;".3 etc324 $v =~ s/\"/\\\"/g;325 push(@escaped_v, $v);326 }327 else {328 my $ev = &ghtml::unescape_html($v);329 $ev =~ s/\"/\\\"/g;330 push(@escaped_v, $ev);331 }332 }333 $infodb_map->{$k} = \@escaped_v;334 }335 336 # Generate the record string337 my $serialized_infodb_map = $self->_convert_infodb_hash_to_string($infodb_map);338 339 # Store it into GDBM340 my $tdbset_exe = $self->_get_tdb_executable('tdbset');341 my $cmd = '"' . $tdbset_exe . '" "' . $infodb_file_path . '" "' . $infodb_key . '" "' . $serialized_infodb_map . '"';342 my $status = system($cmd);343 344 return $status;345 }346 ## set_infodb_entry(string, string, hashmap) => integer ##347 348 199 1; -
gs2-extensions/tdb/trunk/perllib/dbutil.pm
r30340 r30347 37 37 } 38 38 # Are we running standalone? In which case the INC won't be correct 39 #if (!caller) { 40 # Ensure the INC includes the path to FileUtils.pm 41 unshift(@INC, $ENV{'GSDLHOME'} . '/perllib'); 42 43 #} 44 require DBDrivers::GDBM; 45 my $driver = DBDrivers::GDBM->new(1); 39 my $perllib_path = $ENV{'GSDLHOME'} . '/perllib'; 40 my $all_inc = join(':', @INC); 41 if ($all_inc !~ /$perllib_path/) { 42 unshift(@INC, $perllib_path); 43 } 46 44 } 47 45 … … 240 238 'tea' => ['a drink with jam and bread'], 241 239 'doh' => ['which brings us back to']}; 240 $test_count = 0; 241 $pass_count = 0; 242 $skip_count = 0; 242 243 print "===== DBUtils Testing Suite =====\n"; 243 244 print "For each driver specified, run a battery of tests\n"; … … 259 260 &_addPathsToINC(); 260 261 foreach my $driver_name (@drivers) { 261 print "* Testing: " . $driver_name . "\n"; 262 my $t1 = [gettimeofday()]; 263 print "=== Testing: " . $driver_name . " ===\n"; 262 264 my $driver = _loadDBDriver($driver_name); 263 265 my $db_path = $driver->get_infodb_file_path('test','/tmp/'); … … 274 276 &_printTest('writing raw entry', 1); 275 277 # 3. Close handle 276 $driver->close_infodb_handle($db_handle); 277 &_printTest('closing handle', (tell($db_handle) < 1)); 278 $driver->close_infodb_write_handle($db_handle); 279 if ($driver->supportsPersistentConnection()) { 280 $test_count += 1; 281 $skip_count += 1; 282 print " - Skipping test as persistent drivers delay 'close'.\n"; 283 } 284 else { 285 &_printTest('closing handle', (tell($db_handle) < 1)); 286 } 278 287 # 4a. Read entry 279 288 my $data3 = $driver->read_infodb_entry($db_path, 'Alpha'); … … 302 311 my $db_handle2 = $driver->open_infodb_write_handle($db_path, 'append'); 303 312 $driver->delete_infodb_entry($db_handle2, 'Alpha'); 304 $driver->close_infodb_ handle($db_handle2);313 $driver->close_infodb_write_handle($db_handle2); 305 314 my $keys2 = {}; 306 315 $driver->read_infodb_keys($db_path, $keys2); … … 308 317 # 8. Remove test db 309 318 #unlink($db_path); 319 my $t2 = [gettimeofday()]; 320 my $elapsed1 = tv_interval($t1, $t2); 321 print " - Testing took " . $elapsed1 . " seconds\n"; 310 322 } 311 323 print "===== Results =====\n"; … … 320 332 print "Warning! No drivers specified - expected as arguments to call\n"; 321 333 } 322 my $t 1= [gettimeofday()];323 my $elapsed = tv_interval($t0, $t1);324 print "===== Complete in " . $elapsed . " seconds =====\n";334 my $t3 = [gettimeofday()]; 335 my $elapsed2 = tv_interval($t0, $t3); 336 print "===== Complete in " . $elapsed2 . " seconds =====\n"; 325 337 print "\n"; 326 338 exit(0);
Note:
See TracChangeset
for help on using the changeset viewer.