1-- This file is covered by the Internet Software Consortium (ISC) License 2-- Reference: ../../License.txt 3 4package body AdaBase.Statement.Base.PostgreSQL is 5 6 ------------------------ 7 -- reformat_markers -- 8 ------------------------ 9 function reformat_markers (parameterized_sql : String) return String 10 is 11 masked : String := CT.redact_quotes (parameterized_sql); 12 cvslen : Natural := masked'Length; 13 begin 14 for x in masked'Range loop 15 if masked (x) = ASCII.Query then 16 -- Reserve enough for 9999 markers (limit 1600 on PgSQL) 17 -- Trailing whitespace is truncated by the return 18 cvslen := cvslen + 4; 19 end if; 20 end loop; 21 declare 22 canvas : String (1 .. cvslen) := (others => ' '); 23 polaris : Natural := 0; 24 param : Natural := 0; 25 begin 26 for x in masked'Range loop 27 if masked (x) = ASCII.Query then 28 param := param + 1; 29 declare 30 marker : String := ASCII.Dollar & CT.int2str (param); 31 begin 32 for y in marker'Range loop 33 polaris := polaris + 1; 34 canvas (polaris) := marker (y); 35 end loop; 36 end; 37 else 38 polaris := polaris + 1; 39 canvas (polaris) := parameterized_sql (x); 40 end if; 41 end loop; 42 return canvas (1 .. polaris); 43 end; 44 end reformat_markers; 45 46 47 -------------------- 48 -- column_count -- 49 -------------------- 50 overriding 51 function column_count (Stmt : PostgreSQL_statement) return Natural is 52 begin 53 return Stmt.num_columns; 54 end column_count; 55 56 57 ---------------------- 58 -- last_insert_id -- 59 ---------------------- 60 overriding 61 function last_insert_id (Stmt : PostgreSQL_statement) return Trax_ID 62 is 63 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 64 begin 65 if Stmt.insert_return then 66 return Stmt.last_inserted; 67 else 68 return conn.select_last_val; 69 end if; 70 end last_insert_id; 71 72 73 ---------------------- 74 -- last_sql_state -- 75 ---------------------- 76 overriding 77 function last_sql_state (Stmt : PostgreSQL_statement) return SQL_State 78 is 79 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 80 begin 81 return conn.SqlState (Stmt.result_handle); 82 end last_sql_state; 83 84 85 ------------------------ 86 -- last_driver_code -- 87 ------------------------ 88 overriding 89 function last_driver_code (Stmt : PostgreSQL_statement) return Driver_Codes 90 is 91 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 92 begin 93 return conn.driverCode (Stmt.result_handle); 94 end last_driver_code; 95 96 97 --------------------------- 98 -- last_driver_message -- 99 --------------------------- 100 overriding 101 function last_driver_message (Stmt : PostgreSQL_statement) return String 102 is 103 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 104 begin 105 return conn.driverMessage (Stmt.result_handle); 106 end last_driver_message; 107 108 109 -------------------- 110 -- discard_rest -- 111 -------------------- 112 overriding 113 procedure discard_rest (Stmt : out PostgreSQL_statement) 114 is 115 -- When asynchronous command mode becomes supported, this procedure 116 -- would free the pgres object and indicate data exhausted somehow. 117 -- In the standard buffered mode, we can only simulate it. 118 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 119 begin 120 if Stmt.result_arrow < Stmt.size_of_rowset then 121 Stmt.result_arrow := Stmt.size_of_rowset; 122 Stmt.rows_leftover := True; 123 conn.discard_pgresult (Stmt.result_handle); 124 end if; 125 end discard_rest; 126 127 128 ------------------ 129 -- execute #1 -- 130 ------------------ 131 overriding 132 function execute (Stmt : out PostgreSQL_statement) return Boolean 133 is 134 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 135 markers : constant Natural := Natural (Stmt.realmccoy.Length); 136 status_successful : Boolean := True; 137 data_present : Boolean := False; 138 begin 139 if Stmt.type_of_statement = direct_statement then 140 raise INVALID_FOR_DIRECT_QUERY 141 with "The execute command is for prepared statements only"; 142 end if; 143 144 Stmt.result_arrow := 0; 145 Stmt.last_inserted := 0; 146 Stmt.size_of_rowset := 0; 147 Stmt.impacted := 0; 148 Stmt.rows_leftover := False; 149 Stmt.result_present := False; 150 Stmt.successful_execution := False; 151 conn.discard_pgresult (Stmt.result_handle); 152 153 if markers > 0 then 154 -- Check to make sure all prepared markers are bound 155 for sx in Natural range 1 .. markers loop 156 if not Stmt.realmccoy.Element (sx).bound then 157 raise STMT_PREPARATION 158 with "Prep Stmt column" & sx'Img & " unbound"; 159 end if; 160 end loop; 161 162 -- Now bind the actual values to the markers 163 declare 164 canvas : CON.parameter_block (1 .. markers); 165 msg : String := "Exec with" & markers'Img & " bound parameters"; 166 begin 167 for x in canvas'Range loop 168 canvas (x).payload := Stmt.bind_text_value (x); 169 canvas (x).is_null := Stmt.realmccoy.Element (x).null_data; 170 canvas (x).binary := Stmt.realmccoy.Element (x).output_type = 171 ft_chain; 172 end loop; 173 Stmt.log_nominal (statement_execution, msg); 174 175 Stmt.result_handle := conn.execute_prepared_stmt 176 (name => Stmt.show_statement_name, 177 data => canvas); 178 end; 179 180 else 181 -- No binding required, just execute the prepared statement 182 Stmt.log_nominal (category => statement_execution, 183 message => "Exec without bound parameters"); 184 185 Stmt.result_handle := conn.execute_prepared_stmt 186 (name => Stmt.show_statement_name); 187 end if; 188 189 case conn.examine_result (Stmt.result_handle) is 190 when CON.executed => 191 Stmt.successful_execution := True; 192 when CON.returned_data => 193 Stmt.successful_execution := True; 194 Stmt.insert_return := Stmt.insert_prepsql; 195 data_present := True; 196 when CON.failed => 197 Stmt.successful_execution := False; 198 end case; 199 200 if Stmt.successful_execution then 201 if data_present then 202 if Stmt.insert_return then 203 Stmt.last_inserted := conn.returned_id (Stmt.result_handle); 204 else 205 Stmt.size_of_rowset := conn.rows_in_result (Stmt.result_handle); 206 Stmt.result_present := True; 207 end if; 208 end if; 209 Stmt.impacted := conn.rows_impacted (Stmt.result_handle); 210 end if; 211 212 return Stmt.successful_execution; 213 end execute; 214 215 216 ------------------ 217 -- execute #2 -- 218 ------------------ 219 overriding 220 function execute (Stmt : out PostgreSQL_statement; parameters : String; 221 delimiter : Character := '|') return Boolean 222 is 223 function parameters_given return Natural; 224 num_markers : constant Natural := Natural (Stmt.realmccoy.Length); 225 226 function parameters_given return Natural 227 is 228 result : Natural := 1; 229 begin 230 for x in parameters'Range loop 231 if parameters (x) = delimiter then 232 result := result + 1; 233 end if; 234 end loop; 235 return result; 236 end parameters_given; 237 begin 238 if Stmt.type_of_statement = direct_statement then 239 raise INVALID_FOR_DIRECT_QUERY 240 with "The execute command is for prepared statements only"; 241 end if; 242 243 if num_markers /= parameters_given then 244 raise STMT_PREPARATION 245 with "Parameter number mismatch, " & num_markers'Img & 246 " expected, but" & parameters_given'Img & " provided."; 247 end if; 248 249 declare 250 index : Natural := 1; 251 arrow : Natural := parameters'First; 252 scans : Boolean := False; 253 start : Natural := 1; 254 stop : Natural := 0; 255 begin 256 for x in parameters'Range loop 257 if parameters (x) = delimiter then 258 if not scans then 259 Stmt.auto_assign (index, ""); 260 else 261 Stmt.auto_assign (index, parameters (start .. stop)); 262 scans := False; 263 end if; 264 index := index + 1; 265 else 266 stop := x; 267 if not scans then 268 start := x; 269 scans := True; 270 end if; 271 end if; 272 end loop; 273 if not scans then 274 Stmt.auto_assign (index, ""); 275 else 276 Stmt.auto_assign (index, parameters (start .. stop)); 277 end if; 278 end; 279 280 return Stmt.execute; 281 end execute; 282 283 284 --------------------- 285 -- rows_returned -- 286 --------------------- 287 overriding 288 function rows_returned (Stmt : PostgreSQL_statement) return Affected_Rows 289 is 290 begin 291 return Stmt.size_of_rowset; 292 end rows_returned; 293 294 295 ------------------- 296 -- column_name -- 297 ------------------- 298 overriding 299 function column_name (Stmt : PostgreSQL_statement; index : Positive) 300 return String 301 is 302 maxlen : constant Natural := Natural (Stmt.column_info.Length); 303 begin 304 if index > maxlen then 305 raise INVALID_COLUMN_INDEX with "Max index is" & maxlen'Img & 306 " but" & index'Img & " attempted"; 307 end if; 308 return CT.USS (Stmt.column_info.Element (Index => index).field_name); 309 end column_name; 310 311 312 -------------------- 313 -- column_table -- 314 -------------------- 315 overriding 316 function column_table (Stmt : PostgreSQL_statement; index : Positive) 317 return String 318 is 319 maxlen : constant Natural := Natural (Stmt.column_info.Length); 320 begin 321 if index > maxlen then 322 raise INVALID_COLUMN_INDEX with "Max index is" & maxlen'Img & 323 " but" & index'Img & " attempted"; 324 end if; 325 return CT.USS (Stmt.column_info.Element (Index => index).table); 326 end column_table; 327 328 329 -------------------------- 330 -- column_native_type -- 331 -------------------------- 332 overriding 333 function column_native_type (Stmt : PostgreSQL_statement; index : Positive) 334 return field_types 335 is 336 maxlen : constant Natural := Natural (Stmt.column_info.Length); 337 begin 338 if index > maxlen then 339 raise INVALID_COLUMN_INDEX with "Max index is" & maxlen'Img & 340 " but" & index'Img & " attempted"; 341 end if; 342 return Stmt.column_info.Element (Index => index).field_type; 343 end column_native_type; 344 345 346 ------------------ 347 -- fetch_next -- 348 ------------------ 349 overriding 350 function fetch_next (Stmt : out PostgreSQL_statement) return ARS.Datarow is 351 begin 352 if Stmt.result_arrow >= Stmt.size_of_rowset then 353 return ARS.Empty_Datarow; 354 end if; 355 Stmt.result_arrow := Stmt.result_arrow + 1; 356 return Stmt.assemble_datarow (row_number => Stmt.result_arrow); 357 end fetch_next; 358 359 360 ----------------- 361 -- fetch_all -- 362 ----------------- 363 overriding 364 function fetch_all (Stmt : out PostgreSQL_statement) return ARS.Datarow_Set 365 is 366 maxrows : Natural := Natural (Stmt.rows_returned); 367 tmpset : ARS.Datarow_Set (1 .. maxrows + 1); 368 nullset : ARS.Datarow_Set (1 .. 0); 369 index : Natural := 1; 370 row : ARS.Datarow; 371 begin 372 if Stmt.result_arrow >= Stmt.size_of_rowset then 373 return nullset; 374 end if; 375 376 declare 377 remaining_rows : Trax_ID := Stmt.size_of_rowset - Stmt.result_arrow; 378 return_set : ARS.Datarow_Set (1 .. Natural (remaining_rows)); 379 begin 380 for index in return_set'Range loop 381 Stmt.result_arrow := Stmt.result_arrow + 1; 382 return_set (index) := Stmt.assemble_datarow (Stmt.result_arrow); 383 end loop; 384 return return_set; 385 end; 386 end fetch_all; 387 388 389 ------------------- 390 -- fetch_bound -- 391 ------------------- 392 overriding 393 function fetch_bound (Stmt : out PostgreSQL_statement) return Boolean 394 is 395 function null_value (column : Natural) return Boolean; 396 function string_equivalent (column : Natural; binary : Boolean) 397 return String; 398 399 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 400 401 function string_equivalent (column : Natural; binary : Boolean) 402 return String 403 is 404 -- PostgreSQL result set is zero-indexed 405 row_num : constant Natural := Natural (Stmt.result_arrow) - 1; 406 col_num : constant Natural := column - 1; 407 begin 408 if binary then 409 return conn.field_chain (Stmt.result_handle, row_num, col_num, 410 Stmt.con_max_blob); 411 else 412 return conn.field_string (Stmt.result_handle, row_num, col_num); 413 end if; 414 end string_equivalent; 415 416 function null_value (column : Natural) return Boolean 417 is 418 -- PostgreSQL result set is zero-indexed 419 row_num : constant Natural := Natural (Stmt.result_arrow) - 1; 420 col_num : constant Natural := column - 1; 421 begin 422 return conn.field_is_null (Stmt.result_handle, row_num, col_num); 423 end null_value; 424 425 begin 426 if Stmt.result_arrow >= Stmt.size_of_rowset then 427 return False; 428 end if; 429 Stmt.result_arrow := Stmt.result_arrow + 1; 430 431 declare 432 maxlen : constant Natural := Stmt.num_columns; 433 begin 434 for F in 1 .. maxlen loop 435 declare 436 dossier : bindrec renames Stmt.crate.Element (F); 437 colinfo : column_info renames Stmt.column_info.Element (F); 438 Tout : constant field_types := dossier.output_type; 439 Tnative : constant field_types := colinfo.field_type; 440 isnull : constant Boolean := null_value (F); 441 errmsg : constant String := "native type : " & 442 field_types'Image (Tnative) & " binding type : " & 443 field_types'Image (Tout); 444 smallerr : constant String := "Native unsigned type : " & 445 field_types'Image (Tnative) & " is too small for " & 446 field_types'Image (Tout) & " binding type"; 447 ST : constant String := 448 string_equivalent (F, colinfo.binary_format); 449 begin 450 if not dossier.bound then 451 goto continue; 452 end if; 453 454 if isnull or else CT.IsBlank (ST) then 455 set_as_null (dossier); 456 goto continue; 457 end if; 458 459 -- Because PostgreSQL does not support unsigned integer 460 -- types, allow binding NByteX binding to ByteX types, but 461 -- remain strict on other type mismatches. 462 463 case Tout is 464 when ft_nbyte1 => 465 case Tnative is 466 when ft_byte1 | ft_byte2 | ft_byte3 | ft_byte4 | 467 ft_byte8 | ft_nbyte2 | ft_nbyte3 | ft_nbyte4 | 468 ft_nbyte8 => 469 null; -- Fall through (all could fail to convert) 470 when ft_nbyte1 => 471 null; -- guaranteed to convert 472 when others => 473 raise BINDING_TYPE_MISMATCH with errmsg; 474 end case; 475 when ft_nbyte2 => 476 case Tnative is 477 when ft_byte2 | ft_byte3 | ft_byte4 | ft_byte8 | 478 ft_nbyte3 | ft_nbyte4 | ft_nbyte8 => 479 null; -- Fall through (all could fail to convert) 480 when ft_nbyte1 | ft_nbyte2 => 481 null; -- guaranteed to convert 482 when ft_byte1 => 483 raise BINDING_TYPE_MISMATCH with smallerr; 484 when others => 485 raise BINDING_TYPE_MISMATCH with errmsg; 486 end case; 487 when ft_nbyte3 => 488 case Tnative is 489 when ft_byte3 | ft_byte4 | ft_byte8 | ft_nbyte4 | 490 ft_nbyte8 => 491 null; -- Fall through (all could fail to convert) 492 when ft_nbyte1 | ft_nbyte2 | ft_nbyte3 => 493 null; -- guaranteed to convert 494 when ft_byte1 | ft_byte2 => 495 raise BINDING_TYPE_MISMATCH with smallerr; 496 when others => 497 raise BINDING_TYPE_MISMATCH with errmsg; 498 end case; 499 when ft_nbyte4 => 500 case Tnative is 501 when ft_byte4 | ft_byte8 | ft_nbyte8 => 502 null; -- Fall through (all could fail to convert) 503 when ft_nbyte1 | ft_nbyte2 | ft_nbyte3 | ft_nbyte4 => 504 null; -- guaranteed to convert 505 when ft_byte1 | ft_byte2 | ft_byte3 => 506 raise BINDING_TYPE_MISMATCH with smallerr; 507 when others => 508 raise BINDING_TYPE_MISMATCH with errmsg; 509 end case; 510 when ft_nbyte8 => 511 case Tnative is 512 when ft_byte8 => 513 null; -- Fall through (could fail to convert) 514 when ft_nbyte1 | ft_nbyte2 | ft_nbyte3 | ft_nbyte4 | 515 ft_nbyte8 => 516 null; -- guaranteed to convert 517 when ft_byte1 | ft_byte2 | ft_byte3 | ft_byte4 => 518 raise BINDING_TYPE_MISMATCH with smallerr; 519 when others => 520 raise BINDING_TYPE_MISMATCH with errmsg; 521 end case; 522 when ft_byte1 => 523 case Tnative is 524 when ft_byte2 => 525 null; -- smallest poss. type (could fail to conv) 526 when ft_byte1 => 527 null; -- guaranteed to convert but impossible case 528 when others => 529 raise BINDING_TYPE_MISMATCH with errmsg; 530 end case; 531 when ft_byte3 => 532 case Tnative is 533 when ft_byte4 => 534 null; -- smallest poss. type (could fail to conv) 535 when ft_byte1 | ft_byte2 | ft_byte3 => 536 null; -- guaranteed to convert (1/3 imposs.) 537 when others => 538 raise BINDING_TYPE_MISMATCH with errmsg; 539 end case; 540 when ft_real18 => 541 case Tnative is 542 when ft_real9 | ft_real18 => 543 null; -- guaranteed to convert without loss 544 when others => 545 raise BINDING_TYPE_MISMATCH with errmsg; 546 end case; 547 when ft_textual => 548 case Tnative is 549 when ft_settype => 550 null; -- No support for Sets in pgsql, conv->str 551 when ft_textual | ft_widetext | ft_supertext => 552 null; 553 when ft_utf8 => 554 null; -- UTF8 needs contraints, allow textual 555 when others => 556 raise BINDING_TYPE_MISMATCH with errmsg; 557 end case; 558 when ft_settype => 559 case Tnative is 560 when ft_textual | ft_utf8 => 561 null; -- No support for Sets in pgsql, conv->set 562 when ft_settype => 563 null; -- impossible 564 when others => 565 raise BINDING_TYPE_MISMATCH with errmsg; 566 end case; 567 when others => 568 if Tnative /= Tout then 569 raise BINDING_TYPE_MISMATCH with errmsg; 570 end if; 571 end case; 572 573 case Tout is 574 when ft_nbyte0 => dossier.a00.all := (ST = "t"); 575 when ft_nbyte1 => dossier.a01.all := convert (ST); 576 when ft_nbyte2 => dossier.a02.all := convert (ST); 577 when ft_nbyte3 => dossier.a03.all := convert (ST); 578 when ft_nbyte4 => dossier.a04.all := convert (ST); 579 when ft_nbyte8 => dossier.a05.all := convert (ST); 580 when ft_byte1 => dossier.a06.all := convert (ST); 581 when ft_byte2 => dossier.a07.all := convert (ST); 582 when ft_byte3 => dossier.a08.all := convert (ST); 583 when ft_byte4 => dossier.a09.all := convert (ST); 584 when ft_byte8 => dossier.a10.all := convert (ST); 585 when ft_real9 => dossier.a11.all := convert (ST); 586 when ft_real18 => dossier.a12.all := convert (ST); 587 when ft_textual => dossier.a13.all := CT.SUS (ST); 588 when ft_widetext => dossier.a14.all := convert (ST); 589 when ft_supertext => dossier.a15.all := convert (ST); 590 when ft_enumtype => dossier.a18.all := ARC.convert (ST); 591 when ft_utf8 => dossier.a21.all := ST; 592 when ft_geometry => 593 dossier.a22.all := 594 WKB.Translate_WKB (postgis_to_WKB (ST)); 595 when ft_timestamp => 596 begin 597 dossier.a16.all := ARC.convert (ST); 598 exception 599 when AR.CONVERSION_FAILED => 600 dossier.a16.all := AR.PARAM_IS_TIMESTAMP; 601 end; 602 when ft_chain => 603 declare 604 FL : Natural := dossier.a17.all'Length; 605 DVLEN : Natural := ST'Length; 606 begin 607 if DVLEN > FL then 608 raise BINDING_SIZE_MISMATCH with "native size : " & 609 DVLEN'Img & " greater than binding size : " & 610 FL'Img; 611 end if; 612 dossier.a17.all := ARC.convert (ST, FL); 613 end; 614 when ft_settype => 615 declare 616 FL : Natural := dossier.a19.all'Length; 617 items : constant Natural := CT.num_set_items (ST); 618 begin 619 if items > FL then 620 raise BINDING_SIZE_MISMATCH with 621 "native size : " & items'Img & 622 " greater than binding size : " & FL'Img; 623 end if; 624 dossier.a19.all := ARC.convert (ST, FL); 625 end; 626 when ft_bits => 627 declare 628 FL : Natural := dossier.a20.all'Length; 629 DVLEN : Natural := ST'Length; 630 begin 631 if DVLEN > FL then 632 raise BINDING_SIZE_MISMATCH with "native size : " & 633 DVLEN'Img & " greater than binding size : " & 634 FL'Img; 635 end if; 636 dossier.a20.all := ARC.convert (ST, FL); 637 end; 638 end case; 639 end; 640 <<continue>> 641 end loop; 642 end; 643 644 if Stmt.result_arrow = Stmt.size_of_rowset then 645 conn.discard_pgresult (Stmt.result_handle); 646 end if; 647 return True; 648 end fetch_bound; 649 650 651 ---------------------- 652 -- fetch_next_set -- 653 ---------------------- 654 overriding 655 procedure fetch_next_set (Stmt : out PostgreSQL_statement; 656 data_present : out Boolean; 657 data_fetched : out Boolean) 658 is 659 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 660 next_call : constant String := Stmt.pop_result_set_reference; 661 SQL : constant String := "FETCH ALL IN " & 662 ASCII.Quotation & next_call & ASCII.Quotation; 663 begin 664 data_fetched := False; 665 data_present := False; 666 if CT.IsBlank (next_call) then 667 return; 668 end if; 669 670 -- Clear existing results 671 conn.discard_pgresult (Stmt.result_handle); 672 Stmt.column_info.Clear; 673 Stmt.alpha_markers.Clear; 674 Stmt.headings_map.Clear; 675 Stmt.crate.Clear; 676 Stmt.realmccoy.Clear; 677 Stmt.result_present := False; 678 Stmt.rows_leftover := False; 679 Stmt.insert_return := False; 680 Stmt.impacted := 0; 681 Stmt.assign_counter := 0; 682 Stmt.size_of_rowset := 0; 683 Stmt.num_columns := 0; 684 Stmt.result_arrow := 0; 685 Stmt.last_inserted := 0; 686 687 -- execute next query 688 if conn.direct_stmt_exec (Stmt.result_handle, SQL) then 689 Stmt.log_nominal (category => miscellaneous, 690 message => "Stored procs next set: " & SQL); 691 692 case conn.examine_result (Stmt.result_handle) is 693 when CON.executed => 694 data_present := True; 695 Stmt.successful_execution := True; 696 when CON.returned_data => 697 data_present := True; 698 data_fetched := True; 699 Stmt.successful_execution := True; 700 Stmt.insert_return := Stmt.insert_prepsql; 701 when CON.failed => 702 Stmt.successful_execution := False; 703 end case; 704 705 if not Stmt.insert_return then 706 Stmt.size_of_rowset := conn.rows_in_result (Stmt.result_handle); 707 end if; 708 709 if Stmt.insert_return then 710 Stmt.last_inserted := conn.returned_id (Stmt.result_handle); 711 end if; 712 713 Stmt.scan_column_information (Stmt.result_handle); 714 else 715 Stmt.log_problem 716 (category => miscellaneous, 717 message => "Stored procs: Failed fetch next rowset " & next_call); 718 end if; 719 end fetch_next_set; 720 721 722 ------------------ 723 -- initialize -- 724 ------------------ 725 overriding 726 procedure initialize (Object : in out PostgreSQL_statement) 727 is 728 use type CON.PostgreSQL_Connection_Access; 729 conn : CON.PostgreSQL_Connection_Access renames Object.pgsql_conn; 730 logcat : Log_Category; 731 params : Natural; 732 stmt_name : String := Object.show_statement_name; 733 hold_result : aliased BND.PGresult_Access; 734 begin 735 736 if conn = null then 737 return; 738 end if; 739 740 logger_access := Object.log_handler; 741 Object.dialect := driver_postgresql; 742 Object.connection := ACB.Base_Connection_Access (conn); 743 Object.insert_prepsql := False; 744 745 -------------------------------- 746 -- Set SQL and log category -- 747 -------------------------------- 748 case Object.type_of_statement is 749 when direct_statement => 750 Object.sql_final := new String'(CT.trim_sql 751 (Object.initial_sql.all)); 752 logcat := statement_execution; 753 when prepared_statement => 754 Object.sql_final := 755 new String'(reformat_markers (Object.transform_sql 756 (Object.initial_sql.all))); 757 logcat := statement_preparation; 758 end case; 759 760 -------------------------------------------------------- 761 -- Detect INSERT commands (for INSERT .. RETURNING) -- 762 -------------------------------------------------------- 763 declare 764 sql : String := Object.initial_sql.all; 765 begin 766 if sql'Length > 12 and then 767 ACH.To_Upper (sql (sql'First .. sql'First + 6)) = "INSERT " 768 then 769 Object.insert_prepsql := True; 770 end if; 771 end; 772 773 if Object.type_of_statement = prepared_statement then 774 ----------------------------------- 775 -- Prepared Statement handling -- 776 ----------------------------------- 777 if conn.prepare_statement (stmt => Object.prepared_stmt, 778 name => stmt_name, 779 sql => Object.sql_final.all) 780 then 781 Object.stmt_allocated := True; 782 Object.log_nominal (category => logcat, 783 message => stmt_name & " - " & 784 Object.sql_final.all); 785 else 786 Object.log_problem (statement_preparation, 787 conn.driverMessage (Object.prepared_stmt)); 788 Object.log_problem 789 (category => statement_preparation, 790 message => "Failed to prepare SQL query: '" & 791 Object.sql_final.all & "'", 792 break => True); 793 return; 794 end if; 795 796 --------------------------------------- 797 -- Get column metadata (prep stmt) -- 798 --------------------------------------- 799 if conn.prepare_metadata (meta => hold_result, 800 name => stmt_name) 801 then 802 Object.scan_column_information (hold_result); 803 params := conn.markers_found (hold_result); 804 conn.discard_pgresult (hold_result); 805 else 806 conn.discard_pgresult (hold_result); 807 Object.log_problem (statement_preparation, 808 conn.driverMessage (hold_result)); 809 Object.log_problem 810 (category => statement_preparation, 811 message => "Failed to acquire prep statement metadata (" & 812 stmt_name & ")", 813 break => True); 814 return; 815 end if; 816 817 ------------------------------------------------------ 818 -- Check that we have as many markers as expected -- 819 ------------------------------------------------------ 820 declare 821 errmsg : String := "marker mismatch," & 822 Object.realmccoy.Length'Img & " expected but" & 823 params'Img & " found by PostgreSQL"; 824 begin 825 if params /= Natural (Object.realmccoy.Length) then 826 Object.log_problem 827 (category => statement_preparation, 828 message => errmsg, 829 break => True); 830 return; 831 end if; 832 end; 833 834 else 835 --------------------------------- 836 -- Direct statement handling -- 837 --------------------------------- 838 if conn.direct_stmt_exec (stmt => Object.result_handle, 839 sql => Object.sql_final.all) 840 then 841 Object.log_nominal (category => logcat, 842 message => Object.sql_final.all); 843 844 case conn.examine_result (Object.result_handle) is 845 when CON.executed => 846 Object.successful_execution := True; 847 when CON.returned_data => 848 Object.successful_execution := True; 849 Object.insert_return := Object.insert_prepsql; 850 when CON.failed => 851 Object.successful_execution := False; 852 end case; 853 854 if not Object.insert_return then 855 Object.size_of_rowset := 856 conn.rows_in_result (Object.result_handle); 857 end if; 858 859 if Object.insert_return then 860 Object.last_inserted := conn.returned_id (Object.result_handle); 861 end if; 862 863 Object.scan_column_information (Object.result_handle); 864 Object.push_result_references (calls => Object.next_calls.all); 865 else 866 Object.log_problem 867 (category => statement_execution, 868 message => "Failed to execute a direct SQL query"); 869 return; 870 end if; 871 end if; 872 end initialize; 873 874 875 ------------------------------- 876 -- scan_column_information -- 877 ------------------------------- 878 procedure scan_column_information (Stmt : out PostgreSQL_statement; 879 pgresult : BND.PGresult_Access) 880 is 881 function fn (raw : String) return CT.Text; 882 function sn (raw : String) return String; 883 function fn (raw : String) return CT.Text is 884 begin 885 return CT.SUS (sn (raw)); 886 end fn; 887 function sn (raw : String) return String is 888 begin 889 case Stmt.con_case_mode is 890 when upper_case => 891 return ACH.To_Upper (raw); 892 when lower_case => 893 return ACH.To_Lower (raw); 894 when natural_case => 895 return raw; 896 end case; 897 end sn; 898 899 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 900 begin 901 Stmt.num_columns := conn.fields_count (pgresult); 902 for index in Natural range 0 .. Stmt.num_columns - 1 loop 903 declare 904 info : column_info; 905 brec : bindrec; 906 name : String := conn.field_name (pgresult, index); 907 table : String := conn.field_table (pgresult, index); 908 begin 909 brec.v00 := False; -- placeholder 910 info.field_name := fn (name); 911 info.table := fn (table); 912 info.field_type := conn.field_type (pgresult, index); 913 info.binary_format := info.field_type = ft_chain; 914 Stmt.column_info.Append (New_Item => info); 915 -- The following pre-populates for bind support 916 Stmt.crate.Append (New_Item => brec); 917 Stmt.headings_map.Insert (Key => sn (name), 918 New_Item => Stmt.crate.Last_Index); 919 end; 920 end loop; 921 end scan_column_information; 922 923 924 ------------------- 925 -- log_problem -- 926 ------------------- 927 procedure log_problem 928 (statement : PostgreSQL_statement; 929 category : Log_Category; 930 message : String; 931 pull_codes : Boolean := False; 932 break : Boolean := False) 933 is 934 error_msg : CT.Text := CT.blank; 935 error_code : Driver_Codes := 0; 936 sqlstate : SQL_State := stateless; 937 begin 938 if pull_codes then 939 error_msg := CT.SUS (statement.last_driver_message); 940 error_code := statement.last_driver_code; 941 sqlstate := statement.last_sql_state; 942 end if; 943 944 logger_access.all.log_problem 945 (driver => statement.dialect, 946 category => category, 947 message => CT.SUS ("PROBLEM: " & message), 948 error_msg => error_msg, 949 error_code => error_code, 950 sqlstate => sqlstate, 951 break => break); 952 end log_problem; 953 954 955 -------------- 956 -- Adjust -- 957 -------------- 958 overriding 959 procedure Adjust (Object : in out PostgreSQL_statement) is 960 begin 961 -- The stmt object goes through this evolution: 962 -- A) created in private_prepare() 963 -- B) copied to new object in prepare(), A) destroyed 964 -- C) copied to new object in program, B) destroyed 965 -- We don't want to take any action until C) is destroyed, so add a 966 -- reference counter upon each assignment. When finalize sees a 967 -- value of "2", it knows it is the program-level statement and then 968 -- it can release memory releases, but not before! 969 Object.assign_counter := Object.assign_counter + 1; 970 971 -- Since the finalization is looking for a specific reference 972 -- counter, any further assignments would fail finalization, so 973 -- just prohibit them outright. 974 if Object.assign_counter > 2 then 975 raise STMT_PREPARATION 976 with "Statement objects cannot be re-assigned."; 977 end if; 978 end Adjust; 979 980 981 ---------------- 982 -- finalize -- 983 ---------------- 984 overriding 985 procedure finalize (Object : in out PostgreSQL_statement) 986 is 987 conn : CON.PostgreSQL_Connection_Access renames Object.pgsql_conn; 988 name : constant String := Object.show_statement_name; 989 begin 990 if Object.assign_counter /= 2 then 991 return; 992 end if; 993 994 conn.discard_pgresult (Object.result_handle); 995 996 if Object.stmt_allocated then 997 if conn.autoCommit then 998 if not conn.destroy_statement (name) then 999 Object.log_problem 1000 (category => statement_preparation, 1001 message => "Deallocating statement resources: " & name, 1002 pull_codes => True); 1003 end if; 1004 else 1005 -- If we deallocate a prepared statement in the middle of a 1006 -- transaction, the transaction is marked aborted, so we have 1007 -- to postpone the deallocation until commit or rollback. 1008 -- Morever, the connector needs to handle it so we don't have 1009 -- to create variations of driver.commit and driver.rollback 1010 conn.destroy_later (Object.identifier); 1011 end if; 1012 conn.discard_pgresult (Object.prepared_stmt); 1013 end if; 1014 1015 if Object.sql_final /= null then 1016 free_sql (Object.sql_final); 1017 end if; 1018 end finalize; 1019 1020 1021 ------------------------ 1022 -- assemble_datarow -- 1023 ------------------------ 1024 function assemble_datarow (Stmt : out PostgreSQL_statement; 1025 row_number : Trax_ID) return ARS.Datarow 1026 is 1027 function null_value (column : Natural) return Boolean; 1028 function string_equivalent (column : Natural; binary : Boolean) 1029 return String; 1030 result : ARS.Datarow; 1031 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 1032 maxlen : constant Natural := Natural (Stmt.column_info.Length); 1033 1034 function string_equivalent (column : Natural; binary : Boolean) 1035 return String 1036 is 1037 -- PostgreSQL result set is zero-indexed 1038 row_num : constant Natural := Natural (row_number) - 1; 1039 col_num : constant Natural := column - 1; 1040 begin 1041 if binary then 1042 return conn.field_chain (Stmt.result_handle, row_num, col_num, 1043 Stmt.con_max_blob); 1044 else 1045 return conn.field_string (Stmt.result_handle, row_num, col_num); 1046 end if; 1047 end string_equivalent; 1048 1049 function null_value (column : Natural) return Boolean 1050 is 1051 -- PostgreSQL result set is zero-indexed 1052 row_num : constant Natural := Natural (row_number) - 1; 1053 col_num : constant Natural := column - 1; 1054 begin 1055 return conn.field_is_null (Stmt.result_handle, row_num, col_num); 1056 end null_value; 1057 1058 begin 1059 for F in 1 .. maxlen loop 1060 declare 1061 colinfo : column_info renames Stmt.column_info.Element (F); 1062 field : ARF.Std_Field; 1063 dvariant : ARF.Variant; 1064 last_one : constant Boolean := (F = maxlen); 1065 isnull : constant Boolean := null_value (F); 1066 heading : constant String := CT.USS (colinfo.field_name); 1067 ST : constant String := 1068 string_equivalent (F, colinfo.binary_format); 1069 begin 1070 if isnull then 1071 field := ARF.spawn_null_field (colinfo.field_type); 1072 else 1073 case colinfo.field_type is 1074 when ft_nbyte0 => 1075 dvariant := (datatype => ft_nbyte0, v00 => ST = "t"); 1076 when ft_nbyte1 => 1077 dvariant := (datatype => ft_nbyte1, v01 => convert (ST)); 1078 when ft_nbyte2 => 1079 dvariant := (datatype => ft_nbyte2, v02 => convert (ST)); 1080 when ft_nbyte3 => 1081 dvariant := (datatype => ft_nbyte3, v03 => convert (ST)); 1082 when ft_nbyte4 => 1083 dvariant := (datatype => ft_nbyte4, v04 => convert (ST)); 1084 when ft_nbyte8 => 1085 dvariant := (datatype => ft_nbyte8, v05 => convert (ST)); 1086 when ft_byte1 => 1087 dvariant := (datatype => ft_byte1, v06 => convert (ST)); 1088 when ft_byte2 => 1089 dvariant := (datatype => ft_byte2, v07 => convert (ST)); 1090 when ft_byte3 => 1091 dvariant := (datatype => ft_byte3, v08 => convert (ST)); 1092 when ft_byte4 => 1093 dvariant := (datatype => ft_byte4, v09 => convert (ST)); 1094 when ft_byte8 => 1095 dvariant := (datatype => ft_byte8, v10 => convert (ST)); 1096 when ft_real9 => 1097 dvariant := (datatype => ft_real9, v11 => convert (ST)); 1098 when ft_real18 => 1099 dvariant := (datatype => ft_real18, v12 => convert (ST)); 1100 when ft_textual => 1101 dvariant := (datatype => ft_textual, v13 => CT.SUS (ST)); 1102 when ft_widetext => 1103 dvariant := (datatype => ft_widetext, v14 => convert (ST)); 1104 when ft_supertext => 1105 dvariant := (datatype => ft_supertext, v15 => convert (ST)); 1106 when ft_utf8 => 1107 dvariant := (datatype => ft_utf8, v21 => CT.SUS (ST)); 1108 when ft_geometry => 1109 dvariant := (datatype => ft_geometry, 1110 v22 => CT.SUS (postgis_to_WKB (ST))); 1111 when ft_timestamp => 1112 begin 1113 dvariant := (datatype => ft_timestamp, 1114 v16 => ARC.convert (ST)); 1115 exception 1116 when AR.CONVERSION_FAILED => 1117 dvariant := (datatype => ft_textual, 1118 v13 => CT.SUS (ST)); 1119 end; 1120 when ft_enumtype => 1121 dvariant := (datatype => ft_enumtype, 1122 V18 => ARC.convert (CT.SUS (ST))); 1123 when ft_chain => null; 1124 when ft_settype => null; 1125 when ft_bits => null; 1126 end case; 1127 case colinfo.field_type is 1128 when ft_chain => 1129 field := ARF.spawn_field (binob => ARC.convert (ST)); 1130 when ft_bits => 1131 field := ARF.spawn_bits_field (ST); 1132 when ft_settype => 1133 field := ARF.spawn_field (enumset => ST); 1134 when others => 1135 field := ARF.spawn_field (data => dvariant, 1136 null_data => isnull); 1137 end case; 1138 end if; 1139 1140 result.push (heading => heading, 1141 field => field, 1142 last_field => last_one); 1143 end; 1144 end loop; 1145 if Stmt.result_arrow = Stmt.size_of_rowset then 1146 conn.discard_pgresult (Stmt.result_handle); 1147 end if; 1148 return result; 1149 end assemble_datarow; 1150 1151 1152 --------------------------- 1153 -- show_statement_name -- 1154 --------------------------- 1155 function show_statement_name (Stmt : PostgreSQL_statement) return String is 1156 begin 1157 -- This is not documented, but the name has to be all lower case. 1158 -- This nugget was responsible for hours of tracking down 1159 -- prepared statement deallocation errors. 1160 return "adabase_" & CT.trim (Stmt.identifier'Img); 1161 end show_statement_name; 1162 1163 1164 ----------------------- 1165 -- bind_text_value -- 1166 ----------------------- 1167 function bind_text_value (Stmt : PostgreSQL_statement; marker : Positive) 1168 return AR.Textual 1169 is 1170 zone : bindrec renames Stmt.realmccoy.Element (marker); 1171 vartype : constant field_types := zone.output_type; 1172 1173 use type AR.NByte0_Access; 1174 use type AR.NByte1_Access; 1175 use type AR.NByte2_Access; 1176 use type AR.NByte3_Access; 1177 use type AR.NByte4_Access; 1178 use type AR.NByte8_Access; 1179 use type AR.Byte1_Access; 1180 use type AR.Byte2_Access; 1181 use type AR.Byte3_Access; 1182 use type AR.Byte4_Access; 1183 use type AR.Byte8_Access; 1184 use type AR.Real9_Access; 1185 use type AR.Real18_Access; 1186 use type AR.Str1_Access; 1187 use type AR.Str2_Access; 1188 use type AR.Str4_Access; 1189 use type AR.Time_Access; 1190 use type AR.Enum_Access; 1191 use type AR.Chain_Access; 1192 use type AR.Settype_Access; 1193 use type AR.Bits_Access; 1194 use type AR.S_UTF8_Access; 1195 use type AR.Geometry_Access; 1196 1197 hold : AR.Textual; 1198 begin 1199 case vartype is 1200 when ft_nbyte0 => 1201 if zone.a00 = null then 1202 hold := ARC.convert (zone.v00); 1203 else 1204 hold := ARC.convert (zone.a00.all); 1205 end if; 1206 when ft_nbyte1 => 1207 if zone.a01 = null then 1208 hold := ARC.convert (zone.v01); 1209 else 1210 hold := ARC.convert (zone.a01.all); 1211 end if; 1212 when ft_nbyte2 => 1213 if zone.a02 = null then 1214 hold := ARC.convert (zone.v02); 1215 else 1216 hold := ARC.convert (zone.a02.all); 1217 end if; 1218 when ft_nbyte3 => 1219 if zone.a03 = null then 1220 hold := ARC.convert (zone.v03); 1221 else 1222 hold := ARC.convert (zone.a03.all); 1223 end if; 1224 when ft_nbyte4 => 1225 if zone.a04 = null then 1226 hold := ARC.convert (zone.v04); 1227 else 1228 hold := ARC.convert (zone.a04.all); 1229 end if; 1230 when ft_nbyte8 => 1231 if zone.a05 = null then 1232 hold := ARC.convert (zone.v05); 1233 else 1234 hold := ARC.convert (zone.a05.all); 1235 end if; 1236 when ft_byte1 => 1237 if zone.a06 = null then 1238 hold := ARC.convert (zone.v06); 1239 else 1240 hold := ARC.convert (zone.a06.all); 1241 end if; 1242 when ft_byte2 => 1243 if zone.a07 = null then 1244 hold := ARC.convert (zone.v07); 1245 else 1246 hold := ARC.convert (zone.a07.all); 1247 end if; 1248 when ft_byte3 => 1249 if zone.a08 = null then 1250 hold := ARC.convert (zone.v08); 1251 else 1252 hold := ARC.convert (zone.a08.all); 1253 end if; 1254 when ft_byte4 => 1255 if zone.a09 = null then 1256 hold := ARC.convert (zone.v09); 1257 else 1258 hold := ARC.convert (zone.a09.all); 1259 end if; 1260 when ft_byte8 => 1261 if zone.a10 = null then 1262 hold := ARC.convert (zone.v10); 1263 else 1264 hold := ARC.convert (zone.a10.all); 1265 end if; 1266 when ft_real9 => 1267 if zone.a11 = null then 1268 hold := ARC.convert (zone.v11); 1269 else 1270 hold := ARC.convert (zone.a11.all); 1271 end if; 1272 when ft_real18 => 1273 if zone.a12 = null then 1274 hold := ARC.convert (zone.v12); 1275 else 1276 hold := ARC.convert (zone.a12.all); 1277 end if; 1278 when ft_textual => 1279 if zone.a13 = null then 1280 hold := zone.v13; 1281 else 1282 hold := zone.a13.all; 1283 end if; 1284 when ft_widetext => 1285 if zone.a14 = null then 1286 hold := ARC.convert (zone.v14); 1287 else 1288 hold := ARC.convert (zone.a14.all); 1289 end if; 1290 when ft_supertext => 1291 if zone.a15 = null then 1292 hold := ARC.convert (zone.v15); 1293 else 1294 hold := ARC.convert (zone.a15.all); 1295 end if; 1296 when ft_timestamp => 1297 if zone.a16 = null then 1298 hold := ARC.convert (zone.v16); 1299 else 1300 hold := ARC.convert (zone.a16.all); 1301 end if; 1302 when ft_chain => 1303 if zone.a17 = null then 1304 hold := zone.v17; 1305 else 1306 hold := ARC.convert (zone.a17.all); 1307 end if; 1308 when ft_enumtype => 1309 if zone.a18 = null then 1310 hold := ARC.convert (zone.v18); 1311 else 1312 hold := ARC.convert (zone.a18.all); 1313 end if; 1314 when ft_settype => 1315 if zone.a19 = null then 1316 hold := zone.v19; 1317 else 1318 hold := ARC.convert (zone.a19.all); 1319 end if; 1320 when ft_bits => 1321 if zone.a20 = null then 1322 hold := zone.v20; 1323 else 1324 hold := ARC.convert (zone.a20.all); 1325 end if; 1326 when ft_utf8 => 1327 if zone.a21 = null then 1328 hold := zone.v21; 1329 else 1330 hold := CT.SUS (zone.a21.all); 1331 end if; 1332 when ft_geometry => 1333 if zone.a22 = null then 1334 hold := CT.SUS (WKB.produce_WKT (zone.v22)); 1335 else 1336 hold := CT.SUS (Spatial_Data.Well_Known_Text (zone.a22.all)); 1337 end if; 1338 end case; 1339 return hold; 1340 end bind_text_value; 1341 1342 1343 --------------------------- 1344 -- returned_refcursors -- 1345 --------------------------- 1346 function returned_refcursors (Stmt : PostgreSQL_statement) 1347 return Boolean 1348 is 1349 conn : CON.PostgreSQL_Connection_Access renames Stmt.pgsql_conn; 1350 begin 1351 return Stmt.size_of_rowset > 0 and then 1352 conn.holds_refcursor (Stmt.result_handle, 0); 1353 end returned_refcursors; 1354 1355 1356 -------------------------------- 1357 -- pop_result_set_reference -- 1358 -------------------------------- 1359 function pop_result_set_reference (Stmt : out PostgreSQL_statement) 1360 return String 1361 is 1362 begin 1363 if Stmt.refcursors.Is_Empty then 1364 return ""; 1365 end if; 1366 declare 1367 answer : String := CT.USS (Stmt.refcursors.First_Element.payload); 1368 begin 1369 Stmt.refcursors.Delete_First; 1370 return answer; 1371 end; 1372 end pop_result_set_reference; 1373 1374 1375 ------------------------------ 1376 -- push_result_references -- 1377 ------------------------------ 1378 procedure push_result_references (Stmt : out PostgreSQL_statement; 1379 calls : String) 1380 is 1381 items : Natural; 1382 base : Natural; 1383 begin 1384 if CT.IsBlank (calls) then 1385 return; 1386 end if; 1387 items := CT.num_set_items (calls); 1388 if items = 1 then 1389 Stmt.refcursors.Append ((payload => CT.SUS (calls))); 1390 else 1391 base := calls'First; 1392 for x in Natural range 1 .. items - 1 loop 1393 for y in Natural range base .. calls'Last loop 1394 if calls (y) = ',' then 1395 declare 1396 len : Natural := y - base; 1397 Str : String (1 .. len) := calls (base .. y - 1); 1398 begin 1399 Stmt.refcursors.Append ((payload => CT.SUS (Str))); 1400 base := y + 1; 1401 end; 1402 exit; 1403 end if; 1404 end loop; 1405 end loop; 1406 declare 1407 len : Natural := calls'Last + 1 - base; 1408 Str : String (1 .. len) := calls (base .. calls'Last); 1409 begin 1410 Stmt.refcursors.Append ((payload => CT.SUS (Str))); 1411 end; 1412 end if; 1413 end push_result_references; 1414 1415 1416 ---------------------- 1417 -- postgis_to_WKB -- 1418 ---------------------- 1419 function postgis_to_WKB (postgis : String) return String 1420 is 1421 subtype hex_type is String (1 .. 2); 1422 function hex2char (hex : hex_type) return Character; 1423 -- Postgis is a string of hexidecimal values (e.g. 0 .. F) 1424 -- position 01-02 = endian (1 byte) 1425 -- position 03-04 = WKB type (1 byte, not 4 bytes) 1426 -- position 05-10 - internal, ignore (3 bytes) 1427 -- position 11-18 - SRID, ignore, 4 bytes 1428 -- position 19+ is stock WKB. 1429 -- Must always be evenly numbered (2 digits per byte) 1430 1431 function hex2char (hex : hex_type) return Character 1432 is 1433 sixt : Character renames hex (1); 1434 ones : Character renames hex (2); 1435 zero : Natural := Character'Pos ('0'); 1436 alpha : Natural := Character'Pos ('A'); 1437 val : Natural; 1438 begin 1439 case sixt is 1440 when '0' .. '9' => 1441 val := 16 * (Character'Pos (sixt) - zero); 1442 when 'A' .. 'F' => 1443 val := 16 * (10 + Character'Pos (sixt) - alpha); 1444 when others => 1445 raise POSTGIS_READ_ERROR 1446 with "hex (1) invalid character: " & sixt; 1447 end case; 1448 case ones is 1449 when '0' .. '9' => 1450 val := val + (Character'Pos (ones) - zero); 1451 when 'A' .. 'F' => 1452 val := val + (10 + Character'Pos (ones) - alpha); 1453 when others => 1454 raise POSTGIS_READ_ERROR 1455 with "hex (2) invalid character: " & ones; 1456 end case; 1457 return Character'Val (val); 1458 end hex2char; 1459 1460 output_size : constant Natural := (postgis'Length / 2) - 4; 1461 wkb_string : String (1 .. output_size) := (others => ASCII.NUL); 1462 canvas : String (1 .. postgis'Length) := postgis; 1463 endian_sign : constant hex_type := canvas (1 .. 2); 1464 geom_type : constant hex_type := canvas (3 .. 4); 1465 begin 1466 wkb_string (1) := hex2char (endian_sign); 1467 if Character'Pos (wkb_string (1)) = 1 then 1468 -- little endian 1469 wkb_string (2) := hex2char (geom_type); 1470 else 1471 -- big endian 1472 wkb_string (5) := hex2char (geom_type); 1473 end if; 1474 for chunk in 6 .. output_size loop 1475 wkb_string (chunk) := 1476 hex2char (canvas ((chunk * 2) + 7 .. (chunk * 2) + 8)); 1477 end loop; 1478 return wkb_string; 1479 end postgis_to_WKB; 1480 1481 1482end AdaBase.Statement.Base.PostgreSQL; 1483