1-- This file is covered by the Internet Software Consortium (ISC) License 2-- Reference: ../../License.txt 3 4with Ada.Characters.Handling; 5 6package body AdaBase.Connection.Base.PostgreSQL is 7 8 package ACH renames Ada.Characters.Handling; 9 10 --------------------- 11 -- setCompressed -- 12 --------------------- 13 overriding 14 procedure setCompressed (conn : out PostgreSQL_Connection; compressed : Boolean) 15 is 16 begin 17 raise UNSUPPORTED_BY_PGSQL; 18 end setCompressed; 19 20 21 ------------------ 22 -- compressed -- 23 ------------------ 24 overriding 25 function compressed (conn : PostgreSQL_Connection) return Boolean is 26 begin 27 return False; 28 end compressed; 29 30 31 -------------------- 32 -- setUseBuffer -- 33 -------------------- 34 overriding 35 procedure setUseBuffer (conn : out PostgreSQL_Connection; 36 buffered : Boolean) is 37 begin 38 raise UNSUPPORTED_BY_PGSQL; 39 end setUseBuffer; 40 41 42 ----------------- 43 -- useBuffer -- 44 ----------------- 45 overriding 46 function useBuffer (conn : PostgreSQL_Connection) return Boolean is 47 begin 48 return False; 49 end useBuffer; 50 51 52 -------------------------------- 53 -- driverMessage (interface) -- 54 -------------------------------- 55 overriding 56 function driverMessage (conn : PostgreSQL_Connection) return String 57 is 58 result : BND.ICS.chars_ptr := BND.PQerrorMessage (conn.handle); 59 begin 60 return BND.ICS.Value (result); 61 end driverMessage; 62 63 64 ----------------------- 65 -- driverMessage #2 -- 66 ----------------------- 67 function driverMessage (conn : PostgreSQL_Connection; 68 res : BND.PGresult_Access) return String 69 is 70 result : BND.ICS.chars_ptr := BND.PQresultErrorMessage (res); 71 begin 72 return BND.ICS.Value (result); 73 end driverMessage; 74 75 76 ------------------------------ 77 -- driverCode (interface) -- 78 ------------------------------ 79 overriding 80 function driverCode (conn : PostgreSQL_Connection) return Driver_Codes is 81 begin 82 if conn.cmd_sql_state = stateless or else 83 conn.cmd_sql_state = "00000" 84 then 85 return 0; 86 end if; 87 if conn.cmd_sql_state (1 .. 2) = "01" then 88 return 1; 89 end if; 90 return 2; 91 end driverCode; 92 93 94 --------------------- 95 -- driverCode #2 -- 96 --------------------- 97 function driverCode (conn : PostgreSQL_Connection; 98 res : BND.PGresult_Access) return Driver_Codes 99 is 100 SS : constant SQL_State := conn.SqlState (res); 101 begin 102 if SS = stateless or else SS = "00000" then 103 return 0; 104 end if; 105 if SS (1 .. 2) = "01" then 106 return 1; 107 end if; 108 return 2; 109 end driverCode; 110 111 112 ---------------------------- 113 -- SqlState (interface) -- 114 ---------------------------- 115 overriding 116 function SqlState (conn : PostgreSQL_Connection) return SQL_State is 117 begin 118 return conn.cmd_sql_state; 119 end SqlState; 120 121 122 ------------------- 123 -- SqlState #2 -- 124 ------------------- 125 function SqlState (conn : PostgreSQL_Connection; res : BND.PGresult_Access) 126 return SQL_State 127 is 128 use type BND.ICS.chars_ptr; 129 fieldcode : constant BND.IC.int := BND.PG_DIAG_SQLSTATE; 130 detail : BND.ICS.chars_ptr; 131 begin 132 detail := BND.PQresultErrorField (res, fieldcode); 133 if detail = BND.ICS.Null_Ptr then 134 return stateless; 135 end if; 136 declare 137 SS : String := BND.ICS.Value (detail); 138 begin 139 return SQL_State (SS); 140 end; 141 end SqlState; 142 143 144 ------------------- 145 -- description -- 146 ------------------- 147 overriding 148 function description (conn : PostgreSQL_Connection) return String 149 is 150 begin 151 return conn.info_description; 152 end description; 153 154 155 ------------------------- 156 -- helper_get_row_id -- 157 ------------------------- 158 function returned_id (conn : PostgreSQL_Connection; 159 res : BND.PGresult_Access) return Trax_ID 160 is 161 begin 162 if conn.field_is_null (res, 0, 0) then 163 return 0; 164 end if; 165 166 declare 167 field : constant String := conn.field_string (res, 0, 0); 168 begin 169 return Trax_ID (Integer'Value (field)); 170 exception 171 when others => return 0; 172 end; 173 end returned_id; 174 175 176 ----------------------- 177 -- private_execute -- 178 ----------------------- 179 procedure private_execute (conn : out PostgreSQL_Connection; sql : String) 180 is 181 use type BND.ExecStatusType; 182 pgres : BND.PGresult_Access; 183 query : BND.ICS.chars_ptr := BND.ICS.New_String (Str => sql); 184 success : Boolean; 185 msg : CT.Text; 186 ins_cmd : Boolean := False; 187 begin 188 if sql'Length > 12 and then 189 ACH.To_Upper (sql (sql'First .. sql'First + 6)) = "INSERT " 190 then 191 ins_cmd := True; 192 end if; 193 194 pgres := BND.PQexec (conn => conn.handle, command => query); 195 196 BND.ICS.Free (query); 197 case conn.examine_result (pgres) is 198 when executed => 199 success := True; 200 conn.cmd_insert_return := False; 201 when returned_data => 202 success := True; 203 conn.cmd_insert_return := ins_cmd; 204 when failed => 205 success := False; 206 msg := CT.SUS (conn.driverMessage (pgres)); 207 end case; 208 conn.cmd_sql_state := conn.SqlState (pgres); 209 210 if success then 211 conn.cmd_rows_impact := conn.rows_impacted (pgres); 212 else 213 conn.cmd_rows_impact := 0; 214 end if; 215 216 if conn.cmd_insert_return then 217 conn.insert_return_val := conn.returned_id (pgres); 218 else 219 conn.insert_return_val := 0; 220 end if; 221 222 BND.PQclear (pgres); 223 224 if not success then 225 raise QUERY_FAIL with CT.USS (msg); 226 end if; 227 228 end private_execute; 229 230 231 ---------------------- 232 -- private_select -- 233 ---------------------- 234 function private_select (conn : PostgreSQL_Connection; sql : String) 235 return BND.PGresult_Access 236 is 237 use type BND.ExecStatusType; 238 pgres : BND.PGresult_Access; 239 query : BND.ICS.chars_ptr := BND.ICS.New_String (Str => sql); 240 selcmd : Boolean := True; 241 success : Boolean; 242 msg : CT.Text; 243 begin 244 pgres := BND.PQexec (conn => conn.handle, command => query); 245 246 BND.ICS.Free (query); 247 248 case conn.examine_result (pgres) is 249 when executed => 250 success := False; 251 selcmd := False; 252 when returned_data => 253 success := True; 254 when failed => 255 success := False; 256 msg := CT.SUS (conn.driverMessage (pgres)); 257 end case; 258 259 if not success then 260 if selcmd then 261 raise QUERY_FAIL with CT.USS (msg); 262 else 263 raise QUERY_FAIL with "Not a SELECT query: " & sql; 264 end if; 265 end if; 266 267 return pgres; 268 end private_select; 269 270 271 ---------------------------------------------- 272 -- rows_affected_by_execution (interface) -- 273 ---------------------------------------------- 274 overriding 275 function rows_affected_by_execution (conn : PostgreSQL_Connection) 276 return Affected_Rows is 277 begin 278 return conn.cmd_rows_impact; 279 end rows_affected_by_execution; 280 281 282 ---------------------- 283 -- rows_in_result -- 284 ---------------------- 285 function rows_in_result (conn : PostgreSQL_Connection; 286 res : BND.PGresult_Access) 287 return Affected_Rows 288 is 289 use type BND.IC.int; 290 result : BND.IC.int := BND.PQntuples (res); 291 begin 292 if result < 0 then 293 -- overflowed (e.g. > 2 ** 31 on 32-bit system) 294 return Affected_Rows'Last; 295 end if; 296 return Affected_Rows (result); 297 end rows_in_result; 298 299 300 --------------------- 301 -- rows_impacted -- 302 --------------------- 303 function rows_impacted (conn : PostgreSQL_Connection; 304 res : BND.PGresult_Access) 305 return Affected_Rows 306 is 307 result : BND.ICS.chars_ptr := BND.PQcmdTuples (res); 308 resstr : constant String := BND.ICS.Value (result); 309 begin 310 if CT.IsBlank (resstr) then 311 return 0; 312 end if; 313 begin 314 return Affected_Rows (Integer'Value (resstr)); 315 exception 316 when others => return 0; 317 end; 318 end rows_impacted; 319 320 321 ------------------------- 322 -- begin_transaction -- 323 ------------------------- 324 procedure begin_transaction (conn : out PostgreSQL_Connection) is 325 begin 326 conn.private_execute ("BEGIN"); 327 conn.dummy := True; 328 exception 329 when E : QUERY_FAIL => 330 raise TRAX_BEGIN_FAIL with EX.Exception_Message (E); 331 end begin_transaction; 332 333 334 -------------- 335 -- commit -- 336 -------------- 337 overriding 338 procedure commit (conn : out PostgreSQL_Connection) 339 is 340 procedure deallocate_prep_statement (Position : stmt_vector.Cursor); 341 procedure deallocate_prep_statement (Position : stmt_vector.Cursor) 342 is 343 identifier : constant Trax_ID := stmt_vector.Element (Position); 344 stmt_name : constant String := "AdaBase_" & CT.trim (identifier'Img); 345 begin 346 if conn.destroy_statement (stmt_name) then 347 null; 348 end if; 349 end deallocate_prep_statement; 350 begin 351 begin 352 conn.private_execute ("COMMIT"); 353 conn.stmts_to_destroy.Iterate (deallocate_prep_statement'Access); 354 conn.stmts_to_destroy.Clear; 355 exception 356 when E : QUERY_FAIL => 357 raise COMMIT_FAIL with EX.Exception_Message (E); 358 end; 359 if not conn.autoCommit then 360 conn.begin_transaction; 361 end if; 362 end commit; 363 364 365 ---------------- 366 -- rollback -- 367 ---------------- 368 overriding 369 procedure rollback (conn : out PostgreSQL_Connection) 370 is 371 procedure deallocate_prep_statement (Position : stmt_vector.Cursor); 372 procedure deallocate_prep_statement (Position : stmt_vector.Cursor) 373 is 374 identifier : constant Trax_ID := stmt_vector.Element (Position); 375 stmt_name : constant String := "AdaBase_" & CT.trim (identifier'Img); 376 begin 377 if conn.destroy_statement (stmt_name) then 378 null; 379 end if; 380 end deallocate_prep_statement; 381 begin 382 begin 383 conn.private_execute ("ROLLBACK"); 384 conn.stmts_to_destroy.Iterate (deallocate_prep_statement'Access); 385 conn.stmts_to_destroy.Clear; 386 exception 387 when E : QUERY_FAIL => 388 raise ROLLBACK_FAIL with EX.Exception_Message (E); 389 end; 390 if not conn.autoCommit then 391 conn.begin_transaction; 392 end if; 393 end rollback; 394 395 396 --------------------- 397 -- setAutoCommit -- 398 --------------------- 399 overriding 400 procedure setAutoCommit (conn : out PostgreSQL_Connection; auto : Boolean) 401 is 402 -- PGSQL server has no setting to disable autocommit. Only issuing 403 -- a BEGIN transaction command will inhibit autocommit (and commit/ 404 -- rollback enables it again). Thus autocommit has to be handled at 405 -- the adabase level. A "BEGIN" command is issued immediately after 406 -- connection, COMMIT and ROLLBACK to ensure we're always in a 407 -- transaction when autocommit is off. 408 previous_state : Boolean := conn.prop_auto_commit; 409 begin 410 conn.prop_auto_commit := auto; 411 412 if conn.prop_active then 413 if auto /= previous_state then 414 if conn.within_transaction then 415 if auto then 416 conn.commit; 417 end if; 418 else 419 if not auto then 420 conn.begin_transaction; 421 end if; 422 end if; 423 end if; 424 end if; 425 end setAutoCommit; 426 427 428 ------------------ 429 -- disconnect -- 430 ------------------ 431 overriding 432 procedure disconnect (conn : out PostgreSQL_Connection) 433 is 434 use type BND.PGconn_Access; 435 begin 436 if conn.handle /= null then 437 BND.PQfinish (conn => conn.handle); 438 conn.handle := null; 439 end if; 440 conn.tables.Clear; 441 conn.data_types.Clear; 442 conn.prop_active := False; 443 end disconnect; 444 445 446 -------------------- 447 -- fields_count -- 448 -------------------- 449 function fields_count (conn : PostgreSQL_Connection; 450 res : BND.PGresult_Access) return Natural 451 is 452 result : BND.IC.int := BND.PQnfields (res); 453 begin 454 return Natural (result); 455 end fields_count; 456 457 458 --------------------- 459 -- field_is_null -- 460 --------------------- 461 function field_is_null (conn : PostgreSQL_Connection; 462 res : BND.PGresult_Access; 463 row_number : Natural; 464 column_number : Natural) return Boolean 465 is 466 use type BND.IC.int; 467 rownum : constant BND.IC.int := BND.IC.int (row_number); 468 colnum : constant BND.IC.int := BND.IC.int (column_number); 469 result : constant BND.IC.int := BND.PQgetisnull (res, rownum, colnum); 470 begin 471 return (result = 1); 472 end field_is_null; 473 474 475 -------------------- 476 -- field_length -- 477 -------------------- 478 function field_length (conn : PostgreSQL_Connection; 479 res : BND.PGresult_Access; 480 row_number : Natural; 481 column_number : Natural) return Natural 482 is 483 rownum : constant BND.IC.int := BND.IC.int (row_number); 484 colnum : constant BND.IC.int := BND.IC.int (column_number); 485 result : constant BND.IC.int := BND.PQgetlength (res, rownum, colnum); 486 begin 487 return Natural (result); 488 end field_length; 489 490 491 ------------------------ 492 -- discard_pgresult -- 493 ------------------------ 494 procedure discard_pgresult (conn : PostgreSQL_Connection; 495 res : out BND.PGresult_Access) 496 is 497 use type BND.PGresult_Access; 498 begin 499 if res /= null then 500 BND.PQclear (res); 501 end if; 502 res := null; 503 end discard_pgresult; 504 505 506 ---------------------------- 507 -- field_data_is_binary -- 508 ---------------------------- 509 function field_data_is_binary (conn : PostgreSQL_Connection; 510 res : BND.PGresult_Access; 511 column_number : Natural) return Boolean 512 is 513 use type BND.IC.int; 514 colnum : constant BND.IC.int := BND.IC.int (column_number); 515 result : constant BND.IC.int := BND.PQfformat (res, colnum); 516 begin 517 return (result = 1); 518 end field_data_is_binary; 519 520 521 ---------------- 522 -- finalize -- 523 ---------------- 524 overriding 525 procedure finalize (conn : in out PostgreSQL_Connection) is 526 begin 527 conn.disconnect; 528 end finalize; 529 530 531 --------------------- 532 -- setMultiQuery -- 533 --------------------- 534 overriding 535 procedure setMultiQuery (conn : out PostgreSQL_Connection; 536 multiple : Boolean) 537 is 538 -- Applicable only to driver.execute and implemented manually there 539 -- (in order to use parameter execute rather than pgexec function 540 begin 541 conn.prop_multiquery := multiple; 542 end setMultiQuery; 543 544 545 ------------------ 546 -- multiquery -- 547 ------------------ 548 overriding 549 function multiquery (conn : PostgreSQL_Connection) return Boolean is 550 begin 551 return conn.prop_multiquery; 552 end multiquery; 553 554 555 ------------------------------- 556 -- setTransactionIsolation -- 557 ------------------------------- 558 overriding 559 procedure setTransactionIsolation (conn : out PostgreSQL_Connection; 560 isolation : Trax_Isolation) 561 is 562 use type Trax_Isolation; 563 sql : constant String := 564 "SET SESSION CHARACTERISTICS AS TRANSACTION ISOLATION LEVEL " & 565 ISO_Keywords (isolation); 566 begin 567 if conn.prop_active then 568 conn.private_execute (sql); 569 end if; 570 571 conn.prop_trax_isolation := isolation; 572 exception 573 when QUERY_FAIL => 574 raise TRAXISOL_FAIL with sql; 575 end setTransactionIsolation; 576 577 578 ------------------------------------ 579 -- connection_attempt_succeeded -- 580 ------------------------------------ 581 function connection_attempt_succeeded (conn : PostgreSQL_Connection) 582 return Boolean 583 is 584 use type BND.ConnStatusType; 585 status : constant BND.ConnStatusType := BND.PQstatus (conn.handle); 586 begin 587 return (status = BND.CONNECTION_OK); 588 end connection_attempt_succeeded; 589 590 591 ----------------------- 592 -- convert_version -- 593 ----------------------- 594 function convert_version (pgsql_version : Natural) return CT.Text 595 is 596 six : String (1 .. 6) := (others => '0'); 597 raw : constant String := CT.int2str (pgsql_version); 598 len : constant Natural := raw'Length; 599 begin 600 six (7 - len .. 6) := raw; 601 if six (1) = '0' then 602 return CT.SUS (six (2) & '.' & six (3 .. 4) & '.' & six (5 .. 6)); 603 else 604 return CT.SUS 605 (six (1 .. 2) & '.' & six (3 .. 4) & '.' & six (5 .. 6)); 606 end if; 607 end convert_version; 608 609 610 -------------------------- 611 -- get_server_version -- 612 -------------------------- 613 function get_server_version (conn : PostgreSQL_Connection) return Natural 614 is 615 use type BND.IC.int; 616 version : BND.IC.int := BND.PQserverVersion (conn.handle); 617 begin 618 return Natural (version); 619 end get_server_version; 620 621 622 --------------------------- 623 -- get_library_version -- 624 --------------------------- 625 function get_library_version return Natural 626 is 627 use type BND.IC.int; 628 version : BND.IC.int := BND.PQlibVersion; 629 begin 630 return Natural (version); 631 end get_library_version; 632 633 634 ----------------------- 635 -- get_server_info -- 636 ----------------------- 637 function get_server_info (conn : PostgreSQL_Connection) return CT.Text 638 is 639 use type BND.IC.int; 640 protocol : BND.IC.int := BND.PQprotocolVersion (conn.handle); 641 begin 642 return CT.SUS ("Protocol " & CT.int2str (Integer (protocol)) & ".0"); 643 end get_server_info; 644 645 646 ----------------------- 647 -- is_ipv4_or_ipv6 -- 648 ----------------------- 649 function is_ipv4_or_ipv6 (teststr : String) return Boolean 650 is 651 function is_byte (segment : String) return Boolean; 652 function is_byte (segment : String) return Boolean is 653 begin 654 if segment'Length > 3 then 655 return False; 656 end if; 657 for x in segment'Range loop 658 case segment (x) is 659 when '0' .. '9' => null; 660 when others => return False; 661 end case; 662 end loop; 663 return (Integer'Value (segment) < 256); 664 end is_byte; 665 666 num_dots : constant Natural := CT.count_char (teststr, '.'); 667 dot : constant String := "."; 668 begin 669 if num_dots = 3 then 670 declare 671 P1A : String := CT.part_1 (teststr, dot); 672 P1B : String := CT.part_2 (teststr, dot); 673 begin 674 if is_byte (P1A) then 675 declare 676 P2A : String := CT.part_1 (P1B, dot); 677 P2B : String := CT.part_2 (P1B, dot); 678 begin 679 if is_byte (P2A) then 680 declare 681 P3A : String := CT.part_1 (P2B, dot); 682 P3B : String := CT.part_2 (P2B, dot); 683 begin 684 if is_byte (P3A) and then is_byte (P3B) then 685 return True; 686 end if; 687 end; 688 end if; 689 end; 690 end if; 691 end; 692 end if; 693 for x in teststr'Range loop 694 case teststr (x) is 695 when ':' | '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' => null; 696 when others => return False; 697 end case; 698 end loop; 699 return True; 700 end is_ipv4_or_ipv6; 701 702 703 -------------------------- 704 -- within_transaction -- 705 -------------------------- 706 function within_transaction (conn : PostgreSQL_Connection) return Boolean 707 is 708 use type BND.PGTransactionStatusType; 709 status : BND.PGTransactionStatusType; 710 begin 711 status := BND.PQtransactionStatus (conn.handle); 712 return (status /= BND.PQTRANS_IDLE); 713 end within_transaction; 714 715 716 --------------- 717 -- connect -- 718 --------------- 719 overriding 720 procedure connect (conn : out PostgreSQL_Connection; 721 database : String; 722 username : String := blankstring; 723 password : String := blankstring; 724 hostname : String := blankstring; 725 socket : String := blankstring; 726 port : Posix_Port := portless) 727 is 728 constr : CT.Text := CT.SUS ("dbname=" & database); 729 begin 730 if conn.prop_active then 731 raise NOT_WHILE_CONNECTED; 732 end if; 733 734 if not CT.IsBlank (username) then 735 CT.SU.Append (constr, " user=" & username); 736 end if; 737 if not CT.IsBlank (password) then 738 CT.SU.Append (constr, " password=" & password); 739 end if; 740 if not CT.IsBlank (hostname) then 741 if is_ipv4_or_ipv6 (hostname) then 742 CT.SU.Append (constr, " hostaddr=" & hostname); 743 else 744 CT.SU.Append (constr, " host=" & hostname); 745 end if; 746 else 747 if not CT.IsBlank (socket) then 748 CT.SU.Append (constr, " host=" & socket); 749 end if; 750 end if; 751 if port /= portless then 752 CT.SU.Append (constr, " port=" & CT.int2str (port)); 753 end if; 754 755 declare 756 use type BND.PGconn_Access; 757 conninfo : BND.ICS.chars_ptr := BND.ICS.New_String (CT.USS (constr)); 758 begin 759 conn.tables.Clear; 760 conn.handle := BND.PQconnectdb (conninfo); 761 BND.ICS.Free (conninfo); 762 763 if not conn.connection_attempt_succeeded then 764 raise CONNECT_FAILED; 765 end if; 766 end; 767 768 conn.prop_active := True; 769 conn.info_server_version := convert_version (conn.get_server_version); 770 conn.info_server := conn.get_server_info; 771 772 conn.establish_uniform_encoding; 773 conn.retrieve_uniform_encoding; 774 conn.setTransactionIsolation (conn.prop_trax_isolation); 775 if not conn.prop_auto_commit then 776 conn.begin_transaction; 777 end if; 778 779 -- dump all tables and data types 780 conn.cache_table_names; 781 conn.cache_data_types; 782 783 exception 784 when NOT_WHILE_CONNECTED => 785 raise NOT_WHILE_CONNECTED with 786 "Reconnection attempted during an active connection"; 787 when CONNECT_FAILED => 788 declare 789 msg : String := "connection failure: " & conn.driverMessage; 790 begin 791 conn.disconnect; 792 raise CONNECT_FAILED with msg; 793 end; 794 when rest : others => 795 conn.disconnect; 796 EX.Reraise_Occurrence (rest); 797 end connect; 798 799 800 ------------------ 801 -- Initialize -- 802 ------------------ 803 overriding 804 procedure Initialize (conn : in out PostgreSQL_Connection) is 805 begin 806 conn.info_client_version := convert_version (get_library_version); 807 conn.info_client := conn.info_client_version; 808 end Initialize; 809 810 811 ------------------ 812 -- field_name -- 813 ------------------ 814 function field_name (conn : PostgreSQL_Connection; 815 res : BND.PGresult_Access; 816 column_number : Natural) return String 817 is 818 colnum : constant BND.IC.int := BND.IC.int (column_number); 819 result : BND.ICS.chars_ptr := BND.PQfname (res, colnum); 820 begin 821 return BND.ICS.Value (result); 822 end field_name; 823 824 825 -------------------- 826 -- field_string -- 827 -------------------- 828 function field_string (conn : PostgreSQL_Connection; 829 res : BND.PGresult_Access; 830 row_number : Natural; 831 column_number : Natural) return String 832 is 833 rownum : constant BND.IC.int := BND.IC.int (row_number); 834 colnum : constant BND.IC.int := BND.IC.int (column_number); 835 result : BND.ICS.chars_ptr := BND.PQgetvalue (res, rownum, colnum); 836 begin 837 return BND.ICS.Value (result); 838 end field_string; 839 840 841 -------------------- 842 -- lastInsertID -- 843 -------------------- 844 overriding 845 function lastInsertID (conn : PostgreSQL_Connection) return Trax_ID 846 is 847 -- PostgreSQL has a non-standard extension to INSERT INTO called 848 -- RETURNING that is the most reliably method to get the last insert 849 -- ID on the primary key. We use it (determined in private_execute) 850 -- if RETURNING was part of the INSERT query, otherwise we fall back 851 -- to the less reliable lastval() method. 852 begin 853 if conn.cmd_insert_return then 854 return conn.insert_return_val; 855 else 856 return conn.select_last_val; 857 end if; 858 end lastInsertID; 859 860 861 ----------------------- 862 -- select_last_val -- 863 ----------------------- 864 function select_last_val (conn : PostgreSQL_Connection) return Trax_ID 865 is 866 pgres : BND.PGresult_Access; 867 product : Trax_ID := 0; 868 begin 869 -- private_select can raise exception, but don't catch it 870 -- For lastval(), exceptions should not be thrown so don't mask it 871 pgres := conn.private_select ("SELECT lastval()"); 872 873 if conn.field_is_null (pgres, 0, 0) then 874 BND.PQclear (pgres); 875 return 0; 876 end if; 877 878 declare 879 field : constant String := conn.field_string (pgres, 0, 0); 880 begin 881 product := Trax_ID (Integer'Value (field)); 882 exception 883 when others => null; 884 end; 885 BND.PQclear (pgres); 886 return product; 887 end select_last_val; 888 889 890 --------------- 891 -- execute -- 892 --------------- 893 overriding 894 procedure execute (conn : out PostgreSQL_Connection; sql : String) is 895 begin 896 conn.private_execute (sql => sql); 897 end execute; 898 899 900 ------------------------- 901 -- cache_table_names -- 902 ------------------------- 903 procedure cache_table_names (conn : out PostgreSQL_Connection) 904 is 905 pgres : BND.PGresult_Access; 906 nrows : Affected_Rows; 907 sql : constant String := 908 "SELECT oid, relname FROM pg_class " & 909 "WHERE relkind = 'r' and relname !~ '^(pg|sql)_' " & 910 "ORDER BY oid"; 911 begin 912 pgres := conn.private_select (sql); 913 nrows := conn.rows_in_result (pgres); 914 for x in Natural range 0 .. Natural (nrows) - 1 loop 915 declare 916 s_oid : constant String := conn.field_string (pgres, x, 0); 917 s_table : constant String := conn.field_string (pgres, x, 1); 918 payload : table_cell := (column_1 => CT.SUS (s_table)); 919 begin 920 conn.tables.Insert (Key => Integer'Value (s_oid), 921 New_Item => payload); 922 end; 923 end loop; 924 BND.PQclear (pgres); 925 end cache_table_names; 926 927 928 ------------------- 929 -- field_table -- 930 ------------------- 931 function field_table (conn : PostgreSQL_Connection; 932 res : BND.PGresult_Access; 933 column_number : Natural) return String 934 is 935 use type BND.Oid; 936 colnum : constant BND.IC.int := BND.IC.int (column_number); 937 pg_oid : BND.Oid := BND.PQftable (res, colnum); 938 pg_key : Integer := Integer (pg_oid); 939 begin 940 if pg_oid = BND.InvalidOid then 941 return "INVALID COLUMN"; 942 end if; 943 pg_key := Positive (pg_oid); 944 if conn.tables.Contains (Key => pg_key) then 945 return CT.USS (conn.tables.Element (pg_key).column_1); 946 else 947 return "INVALID OID" & pg_key'Img; 948 end if; 949 end field_table; 950 951 952 ------------------ 953 -- field_type -- 954 ------------------ 955 function field_type (conn : PostgreSQL_Connection; 956 res : BND.PGresult_Access; 957 column_number : Natural) return field_types 958 is 959 colnum : constant BND.IC.int := BND.IC.int (column_number); 960 pg_oid : BND.Oid := BND.PQftype (res, colnum); 961 pg_key : Positive := Positive (pg_oid); 962 begin 963 if conn.data_types.Contains (Key => pg_key) then 964 return conn.data_types.Element (pg_key).data_type; 965 else 966 -- Not in container, fall back to text tupe 967 return ft_textual; 968 end if; 969 end field_type; 970 971 972 ------------------------- 973 -- prepare_statement -- 974 ------------------------- 975 function prepare_statement (conn : PostgreSQL_Connection; 976 stmt : aliased out BND.PGresult_Access; 977 name : String; 978 sql : String) return Boolean 979 is 980 use type BND.ExecStatusType; 981 c_stmt_name : BND.ICS.chars_ptr := BND.ICS.New_String (name); 982 c_query : BND.ICS.chars_ptr := BND.ICS.New_String (sql); 983 begin 984 985 stmt := BND.PQprepare (conn => conn.handle, 986 stmtName => c_stmt_name, 987 query => c_query, 988 nParams => 0, 989 paramTypes => null); 990 BND.ICS.Free (c_stmt_name); 991 BND.ICS.Free (c_query); 992 return (BND.PQresultStatus (stmt) = BND.PGRES_COMMAND_OK); 993 end prepare_statement; 994 995 996 ------------------------ 997 -- prepare_metadata -- 998 ------------------------ 999 function prepare_metadata (conn : PostgreSQL_Connection; 1000 meta : aliased out BND.PGresult_Access; 1001 name : String) return Boolean 1002 is 1003 use type BND.ExecStatusType; 1004 c_stmt_name : BND.ICS.chars_ptr := BND.ICS.New_String (name); 1005 begin 1006 meta := BND.PQdescribePrepared (conn => conn.handle, 1007 stmtName => c_stmt_name); 1008 BND.ICS.Free (c_stmt_name); 1009 return (BND.PQresultStatus (meta) = BND.PGRES_COMMAND_OK); 1010 end prepare_metadata; 1011 1012 1013 ---------------------- 1014 -- examine_result -- 1015 ---------------------- 1016 function examine_result (conn : PostgreSQL_Connection; 1017 res : BND.PGresult_Access) return postexec_status 1018 is 1019 begin 1020 case BND.PQresultStatus (res) is 1021 when BND.PGRES_COMMAND_OK => 1022 return executed; 1023 when BND.PGRES_TUPLES_OK => 1024 return returned_data; 1025 when others => 1026 return failed; 1027 end case; 1028 end examine_result; 1029 1030 1031 ------------------------ 1032 -- direst_stmt_exec -- 1033 ------------------------ 1034 function direct_stmt_exec (conn : out PostgreSQL_Connection; 1035 stmt : aliased out BND.PGresult_Access; 1036 sql : String) return Boolean 1037 is 1038 use type BND.ExecStatusType; 1039 query : BND.ICS.chars_ptr := BND.ICS.New_String (Str => sql); 1040 success : Boolean; 1041 msg : CT.Text; 1042 ins_cmd : Boolean := False; 1043 begin 1044 if sql'Length > 12 and then 1045 ACH.To_Upper (sql (sql'First .. sql'First + 6)) = "INSERT " 1046 then 1047 ins_cmd := True; 1048 end if; 1049 1050 stmt := BND.PQexec (conn => conn.handle, command => query); 1051 1052 BND.ICS.Free (query); 1053 case conn.examine_result (stmt) is 1054 when executed => 1055 success := True; 1056 conn.cmd_insert_return := False; 1057 when returned_data => 1058 success := True; 1059 conn.cmd_insert_return := ins_cmd; 1060 when failed => 1061 success := False; 1062 msg := CT.SUS (conn.driverMessage (stmt)); 1063 end case; 1064 conn.insert_return_val := 0; 1065 conn.cmd_sql_state := conn.SqlState (stmt); 1066 1067 if success then 1068 conn.cmd_rows_impact := conn.rows_impacted (stmt); 1069 else 1070 conn.cmd_rows_impact := 0; 1071 end if; 1072 1073 if conn.cmd_insert_return then 1074 if not conn.field_is_null (stmt, 0, 0) then 1075 declare 1076 field : constant String := conn.field_string (stmt, 0, 0); 1077 begin 1078 conn.insert_return_val := Trax_ID (Integer'Value (field)); 1079 exception 1080 when others => null; 1081 end; 1082 end if; 1083 end if; 1084 return success; 1085 end direct_stmt_exec; 1086 1087 1088 -------------------- 1089 -- piped_tables -- 1090 -------------------- 1091 function piped_tables (conn : PostgreSQL_Connection) return String 1092 is 1093 result : CT.Text := CT.blank; 1094 procedure add (position : table_map.Cursor); 1095 procedure add (position : table_map.Cursor) is 1096 begin 1097 if not CT.IsBlank (result) then 1098 CT.SU.Append (result, '|'); 1099 end if; 1100 CT.SU.Append (result, table_map.Element (position).column_1); 1101 end add; 1102 begin 1103 conn.tables.Iterate (Process => add'Access); 1104 return CT.USS (result); 1105 end piped_tables; 1106 1107 1108 ------------------------- 1109 -- refined_byte_type -- 1110 ------------------------- 1111 function refined_byte_type (byteX : field_types; constraint : String) 1112 return field_types 1113 is 1114 -- This routine is not used! 1115 -- by policy, byteX is ft_byte2, ft_byte3, ft_byte4 or ft_byte8 1116 1117 subtype max_range is Positive range 1 .. 4; 1118 zero_required : constant String := "(VALUE >= 0)"; 1119 max_size : max_range; 1120 begin 1121 if CT.IsBlank (constraint) then 1122 return byteX; 1123 end if; 1124 if not CT.contains (S => constraint, fragment => zero_required) then 1125 return byteX; 1126 end if; 1127 1128 case byteX is 1129 when ft_byte8 => max_size := 4; -- NByte4 1130 when ft_byte4 => max_size := 3; -- NByte3 1131 when ft_byte3 => max_size := 2; -- NByte2 1132 when others => max_size := 1; -- NByte1; 1133 end case; 1134 1135 for x in max_range loop 1136 declare 1137 bits : constant Positive := x * 8; 1138 limit1 : constant Positive := 2 ** bits; 1139 limit2 : constant Positive := limit1 - 1; 1140 check1 : constant String := "(VALUE <" & limit1'Img & ")"; 1141 check2 : constant String := "(VALUE <=" & limit2'Img & ")"; 1142 begin 1143 if x <= max_size then 1144 if CT.contains (S => constraint, fragment => check1) or else 1145 CT.contains (S => constraint, fragment => check2) 1146 then 1147 case x is 1148 when 1 => return ft_nbyte1; 1149 when 2 => return ft_nbyte2; 1150 when 3 => return ft_nbyte3; 1151 when 4 => return ft_nbyte4; 1152 end case; 1153 end if; 1154 end if; 1155 end; 1156 end loop; 1157 return byteX; 1158 end refined_byte_type; 1159 1160 1161 ------------------------- 1162 -- convert_data_type -- 1163 ------------------------- 1164 function convert_data_type (pg_type : String; category : Character; 1165 typelen : Integer; encoded_utf8 : Boolean) 1166 return field_types 1167 is 1168 -- Code Category (typcategory) 1169 -- A Array types 1170 -- B Boolean types 1171 -- C Composite types 1172 -- D Date/time types 1173 -- E Enum types 1174 -- G Geometric types 1175 -- I Network address types 1176 -- N Numeric types 1177 -- P Pseudo-types 1178 -- S String types 1179 -- T Timespan types 1180 -- U User-defined types 1181 -- V Bit-string types 1182 -- X unknown type 1183 1184 desc : constant String := pg_type & " (" & category & ")"; 1185 string_type : field_types := ft_textual; 1186 begin 1187 -- One User-defined type, bytea, is a chain. Check for this one first 1188 -- and treat the reast as strings 1189 1190 if pg_type = "bytea" then 1191 return ft_chain; 1192 end if; 1193 1194 if encoded_utf8 then 1195 string_type := ft_utf8; 1196 end if; 1197 1198 case category is 1199 when 'A' => return ft_textual; -- No support for arrays yet 1200 when 'B' => return ft_nbyte0; 1201 when 'C' => return ft_textual; -- No support for composites yet 1202 when 'D' => return ft_timestamp; 1203 when 'E' => return ft_enumtype; 1204 when 'G' => return ft_textual; -- unsupp native geom, not postgis! 1205 when 'I' => return ft_textual; 1206 when 'N' => null; -- Let numerics fall through 1207 when 'S' => return string_type; 1208 when 'T' => return ft_textual; -- Huge, 4/12/16 bytes 1209 when 'U' => 1210 if pg_type = "geometry" then 1211 -- PostGIS 1212 return ft_geometry; 1213 else 1214 return ft_textual; 1215 end if; 1216 when 'V' => return ft_bits; -- String of 1/0 for now 1217 1218 when 'X' => raise METADATA_FAIL 1219 with "Unknown type encountered: " & desc; 1220 when 'P' => raise METADATA_FAIL 1221 with "Pseudo-type encountered: " & desc; 1222 when others => null; 1223 end case; 1224 1225 -- Pick out standard float/double types from the remaining (numerics) 1226 1227 if pg_type = "real" then 1228 return ft_real9; 1229 elsif pg_type = "float4" then 1230 return ft_real9; 1231 elsif pg_type = "float8" then 1232 return ft_real18; 1233 elsif pg_type = "money" then 1234 return ft_real18; 1235 elsif pg_type = "decimal" then 1236 return ft_real18; 1237 elsif pg_type = "numeric" then 1238 return ft_real18; 1239 elsif pg_type = "double precision" then 1240 return ft_real18; 1241 elsif typelen = -1 then 1242 return ft_real18; 1243 end if; 1244 1245 if typelen = 1 then 1246 return ft_byte1; 1247 elsif typelen = 2 then 1248 return ft_byte2; 1249 elsif typelen = 3 then 1250 return ft_byte3; 1251 elsif typelen = 4 then 1252 return ft_byte4; 1253 elsif typelen = 8 then 1254 return ft_byte8; 1255 else 1256 raise METADATA_FAIL 1257 with "Unknown numeric type encountered: " & desc; 1258 end if; 1259 1260 end convert_data_type; 1261 1262 1263 ------------------------ 1264 -- cache_data_types -- 1265 ------------------------ 1266 procedure cache_data_types (conn : out PostgreSQL_Connection) 1267 is 1268 pgres : BND.PGresult_Access; 1269 nrows : Affected_Rows; 1270 tables : constant String := conn.piped_tables; 1271 sql : constant String := 1272 "SELECT DISTINCT a.atttypid,t.typname,t.typlen,t.typcategory " & 1273 "FROM pg_class c, pg_attribute a, pg_type t " & 1274 "WHERE c.relname ~ '^(" & tables & ")$' " & 1275 "AND a.attnum > 0 AND a.attrelid = c.oid " & 1276 "AND a.atttypid = t.oid " & 1277 "ORDER BY a.atttypid"; 1278 begin 1279 pgres := conn.private_select (sql); 1280 nrows := conn.rows_in_result (pgres); 1281 for x in Natural range 0 .. Natural (nrows) - 1 loop 1282 declare 1283 s_oid : constant String := conn.field_string (pgres, x, 0); 1284 s_name : constant String := conn.field_string (pgres, x, 1); 1285 s_tlen : constant String := conn.field_string (pgres, x, 2); 1286 s_cat : constant String := conn.field_string (pgres, x, 3); 1287 s_cons : constant String := ""; 1288 typcat : constant Character := s_cat (s_cat'First); 1289 typelen : constant Integer := Integer'Value (s_tlen); 1290 payload : data_type_rec := 1291 (data_type => convert_data_type 1292 (s_name, typcat, typelen, conn.encoding_is_utf8)); 1293 begin 1294 conn.data_types.Insert (Key => Integer'Value (s_oid), 1295 New_Item => payload); 1296 end; 1297 end loop; 1298 BND.PQclear (pgres); 1299 end cache_data_types; 1300 1301 1302 -------------------- 1303 -- field_binary -- 1304 -------------------- 1305 function field_binary (conn : PostgreSQL_Connection; 1306 res : BND.PGresult_Access; 1307 row_number : Natural; 1308 column_number : Natural; 1309 max_length : Natural) return String 1310 is 1311 rownum : constant BND.IC.int := BND.IC.int (row_number); 1312 colnum : constant BND.IC.int := BND.IC.int (column_number); 1313 result : BND.ICS.chars_ptr := BND.PQgetvalue (res, rownum, colnum); 1314 len : Natural := conn.field_length (res, row_number, column_number); 1315 begin 1316 declare 1317 bufmax : constant BND.IC.size_t := BND.IC.size_t (max_length); 1318 subtype data_buffer is BND.IC.char_array (1 .. bufmax); 1319 type db_access is access all data_buffer; 1320 buffer : aliased data_buffer; 1321 1322 function db_convert (dba : db_access; size : Natural) return String; 1323 function db_convert (dba : db_access; size : Natural) return String 1324 is 1325 max : Natural := size; 1326 begin 1327 if max > max_length then 1328 max := max_length; 1329 end if; 1330 declare 1331 result : String (1 .. max); 1332 begin 1333 for x in result'Range loop 1334 result (x) := Character (dba.all (BND.IC.size_t (x))); 1335 end loop; 1336 return result; 1337 end; 1338 end db_convert; 1339 begin 1340 return db_convert (buffer'Access, len); 1341 end; 1342 end field_binary; 1343 1344 1345 -------------------- 1346 -- field_chain -- 1347 -------------------- 1348 function field_chain (conn : PostgreSQL_Connection; 1349 res : BND.PGresult_Access; 1350 row_number : Natural; 1351 column_number : Natural; 1352 max_length : Natural) return String 1353 is 1354 -- raw expected in format "/x[hex-byte][hex-byte]...[hex-byte]" 1355 raw : String := conn.field_string (res, row_number, column_number); 1356 maxlen : Natural := raw'Length / 2; 1357 staged : String (1 .. maxlen) := (others => '_'); 1358 arrow : Natural := raw'First; 1359 terminus : Natural := raw'Last; 1360 marker : Natural := 0; 1361 begin 1362 if CT.len (raw) < 4 then 1363 return ""; 1364 end if; 1365 1366 arrow := arrow + 2; -- skip past "/x" 1367 1368 loop 1369 marker := marker + 1; 1370 if arrow + 1 > terminus then 1371 -- format error! Odd length should never happen 1372 -- replace with zero and eject 1373 staged (marker) := Character'Val (0); 1374 exit; 1375 end if; 1376 declare 1377 hex : constant hexbyte := raw (arrow .. arrow + 1); 1378 begin 1379 staged (marker) := convert_hexbyte_to_char (hex); 1380 arrow := arrow + 2; 1381 end; 1382 exit when arrow > terminus; 1383 exit when marker = max_length; 1384 end loop; 1385 return staged (1 .. marker); 1386 end field_chain; 1387 1388 1389 --------------------- 1390 -- markers_found -- 1391 --------------------- 1392 function markers_found (conn : PostgreSQL_Connection; 1393 res : BND.PGresult_Access) return Natural 1394 is 1395 result : constant BND.IC.int := BND.PQnparams (res); 1396 begin 1397 return (Natural (result)); 1398 end markers_found; 1399 1400 1401 ------------------------- 1402 -- destroy_statement -- 1403 ------------------------- 1404 function destroy_statement (conn : out PostgreSQL_Connection; 1405 name : String) return Boolean 1406 is 1407 sql : constant String := "DEALLOCATE " & name; 1408 begin 1409 if conn.prop_active then 1410 conn.private_execute (sql); 1411 end if; 1412 1413 return True; 1414 exception 1415 when QUERY_FAIL => 1416 return False; 1417 end destroy_statement; 1418 1419 1420 -------------------------------- 1421 -- execute_prepared_stmt #1 -- 1422 -------------------------------- 1423 function execute_prepared_stmt (conn : PostgreSQL_Connection; 1424 name : String; 1425 data : parameter_block) 1426 return BND.PGresult_Access 1427 is 1428 subtype param_range is Positive range 1 .. data'Length; 1429 1430 nParams : constant BND.IC.int := BND.IC.int (data'Length); 1431 resultFormat : constant BND.IC.int := 0; -- specify text results 1432 stmtName : BND.ICS.chars_ptr := BND.ICS.New_String (name); 1433 paramValues : BND.Param_Val_Array (param_range); 1434 paramLengths : BND.Param_Int_Array (param_range); 1435 paramFormats : BND.Param_Int_Array (param_range); 1436 need_free : array (param_range) of Boolean; 1437 pgres : BND.PGresult_Access; 1438 datalen : Natural; 1439 begin 1440 for x in paramLengths'Range loop 1441 datalen := CT.len (data (x).payload); 1442 paramLengths (x) := BND.IC.int (datalen); 1443 1444 if data (x).binary then 1445 paramFormats (x) := BND.IC.int (1); 1446 if data (x).is_null then 1447 need_free (x) := False; 1448 paramValues (x).buffer := null; 1449 else 1450 need_free (x) := True; 1451 declare 1452 Str : constant String := CT.USS (data (x).payload); 1453 bsz : BND.IC.size_t := BND.IC.size_t (datalen); 1454 begin 1455 paramValues (x).buffer := new BND.IC.char_array (1 .. bsz); 1456 paramValues (x).buffer.all := BND.IC.To_C (Str, False); 1457 end; 1458 end if; 1459 else 1460 paramFormats (x) := BND.IC.int (0); 1461 if data (x).is_null then 1462 need_free (x) := False; 1463 paramValues (x).buffer := null; 1464 else 1465 declare 1466 use type BND.IC.size_t; 1467 Str : constant String := CT.USS (data (x).payload); 1468 bsz : BND.IC.size_t := BND.IC.size_t (datalen) + 1; 1469 begin 1470 paramValues (x).buffer := new BND.IC.char_array (1 .. bsz); 1471 paramValues (x).buffer.all := BND.IC.To_C (Str, True); 1472 end; 1473 end if; 1474 end if; 1475 end loop; 1476 1477 pgres := BND.PQexecPrepared 1478 (conn => conn.handle, 1479 stmtName => stmtName, 1480 nParams => nParams, 1481 paramValues => paramValues (1)'Unchecked_Access, 1482 paramLengths => paramLengths (1)'Unchecked_Access, 1483 paramFormats => paramFormats (1)'Unchecked_Access, 1484 resultFormat => resultFormat); 1485 1486 BND.ICS.Free (stmtName); 1487 1488 for x in need_free'Range loop 1489 if need_free (x) then 1490 free_binary (paramValues (x).buffer); 1491 end if; 1492 end loop; 1493 1494 -- Let the caller check the state of pgres, just return it as is 1495 return pgres; 1496 end execute_prepared_stmt; 1497 1498 1499 -------------------------------- 1500 -- execute_prepared_stmt #2 -- 1501 -------------------------------- 1502 function execute_prepared_stmt (conn : PostgreSQL_Connection; 1503 name : String) return BND.PGresult_Access 1504 is 1505 resultFormat : constant BND.IC.int := 0; -- specify text results 1506 stmtName : BND.ICS.chars_ptr := BND.ICS.New_String (name); 1507 pgres : BND.PGresult_Access; 1508 begin 1509 pgres := BND.PQexecPrepared 1510 (conn => conn.handle, 1511 stmtName => stmtName, 1512 nParams => 0, 1513 paramValues => null, 1514 paramLengths => null, 1515 paramFormats => null, 1516 resultFormat => resultFormat); 1517 1518 BND.ICS.Free (stmtName); 1519 -- Let the caller check the state of pgres, just return it as is 1520 return pgres; 1521 end execute_prepared_stmt; 1522 1523 1524 --------------------- 1525 -- destroy_later -- 1526 --------------------- 1527 procedure destroy_later (conn : out PostgreSQL_Connection; 1528 identifier : Trax_ID) is 1529 begin 1530 conn.stmts_to_destroy.Append (New_Item => identifier); 1531 end destroy_later; 1532 1533 1534 ----------------------- 1535 -- holds_refcursor -- 1536 ------------------------ 1537 function holds_refcursor (conn : PostgreSQL_Connection; 1538 res : BND.PGresult_Access; 1539 column_number : Natural) return Boolean 1540 is 1541 use type BND.Oid; 1542 colnum : constant BND.IC.int := BND.IC.int (column_number); 1543 pg_oid : BND.Oid := BND.PQftype (res, colnum); 1544 begin 1545 return (pg_oid = BND.PG_TYPE_refcursor); 1546 end holds_refcursor; 1547 1548 1549 ----------------------------- 1550 -- convert_octet_to_char -- 1551 ----------------------------- 1552 function convert_octet_to_char (before : octet) return Character 1553 is 1554 function digit (raw : Character) return Natural; 1555 1556 -- This convert function does no error checking, it expects to receive 1557 -- valid octal numbers. It will no throw an error if illegal 1558 -- characters are found, but rather it will return something value. 1559 1560 function digit (raw : Character) return Natural is 1561 begin 1562 case raw is 1563 when '0' .. '7' => return Character'Pos (raw) - 48; 1564 when others => return 0; 1565 end case; 1566 end digit; 1567 begin 1568 return Character'Val (digit (before (3)) + 1569 digit (before (2)) * 8 + 1570 digit (before (1)) * 64); 1571 end convert_octet_to_char; 1572 1573 1574 ------------------------------- 1575 -- convert_hexbyte_to_char -- 1576 ------------------------------- 1577 function convert_hexbyte_to_char (before : hexbyte) return Character 1578 is 1579 function digit (raw : Character) return Natural; 1580 1581 -- This convert function does no error checking, it expects to receive 1582 -- valid octal numbers. It will no throw an error if illegal 1583 -- characters are found, but rather it will return something value. 1584 1585 function digit (raw : Character) return Natural is 1586 begin 1587 case raw is 1588 when '0' .. '9' => return Character'Pos (raw) - 1589 Character'Pos ('0'); 1590 when 'A' .. 'F' => return Character'Pos (raw) + 10 - 1591 Character'Pos ('A'); 1592 when 'a' .. 'f' => return Character'Pos (raw) + 10 - 1593 Character'Pos ('a'); 1594 when others => return 0; 1595 end case; 1596 end digit; 1597 begin 1598 return Character'Val (digit (before (2)) + 1599 digit (before (1)) * 16); 1600 end convert_hexbyte_to_char; 1601 1602 1603 ---------------------------------- 1604 -- establish_uniform_encoding -- 1605 ---------------------------------- 1606 procedure establish_uniform_encoding (conn : out PostgreSQL_Connection) 1607 is 1608 sql : constant String := "SET CLIENT_ENCODING TO '" & 1609 CT.USS (conn.character_set) & "'"; 1610 begin 1611 if conn.prop_active then 1612 if not CT.IsBlank (conn.character_set) then 1613 execute (conn => conn, sql => sql); 1614 end if; 1615 end if; 1616 exception 1617 when QUERY_FAIL => 1618 raise CHARSET_FAIL with sql; 1619 end establish_uniform_encoding; 1620 1621 1622 ------------------------- 1623 -- set_character_set -- 1624 ------------------------- 1625 overriding 1626 procedure set_character_set (conn : out PostgreSQL_Connection; 1627 charset : String) is 1628 begin 1629 if conn.prop_active then 1630 raise NOT_WHILE_CONNECTED 1631 with "You may only alter the character set prior to connection"; 1632 end if; 1633 conn.character_set := CT.SUS (charset); 1634 end set_character_set; 1635 1636 1637 --------------------- 1638 -- character_set -- 1639 --------------------- 1640 overriding 1641 function character_set (conn : out PostgreSQL_Connection) return String is 1642 begin 1643 if conn.prop_active then 1644 conn.dummy := True; 1645 declare 1646 pgres : BND.PGresult_Access; 1647 begin 1648 -- private_select can raise exception, but don't catch it 1649 pgres := conn.private_select ("SHOW CLIENT_ENCODING"); 1650 if conn.field_is_null (pgres, 0, 0) then 1651 -- This should never happen 1652 BND.PQclear (pgres); 1653 return "UNEXPECTED: encoding not set"; 1654 end if; 1655 declare 1656 field : constant String := conn.field_string (pgres, 0, 0); 1657 begin 1658 BND.PQclear (pgres); 1659 return field; 1660 end; 1661 end; 1662 else 1663 return CT.USS (conn.character_set); 1664 end if; 1665 end character_set; 1666 1667 1668 --------------------------------- 1669 -- retrieve_uniform_encoding -- 1670 --------------------------------- 1671 procedure retrieve_uniform_encoding (conn : out PostgreSQL_Connection) 1672 is 1673 charset : String := character_set (conn => conn); 1674 charsetuc : String := ACH.To_Upper (charset); 1675 begin 1676 conn.encoding_is_utf8 := (charsetuc = "UTF8"); 1677 conn.character_set := CT.SUS (charset); 1678 end retrieve_uniform_encoding; 1679 1680 1681end AdaBase.Connection.Base.PostgreSQL; 1682