Mercurial > urweb

comparison src/cjr_print.sml @ 867:e7f80d78075b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Moved query code into Settings
author Adam Chlipala <adamc@hcoop.net>
date Sun, 28 Jun 2009 16:03:00 -0400
parents 03e7f111fe99
children 06497beb265b
comparison
equal deleted inserted replaced
866:03e7f111fe99 867:e7f80d78075b
468 (box [string "PQgetlength(res, i, ", 468 (box [string "PQgetlength(res, i, ",
469 string (Int.toString i), 469 string (Int.toString i),
470 string ")"]), 470 string ")"]),
471 string ")"] 471 string ")"]
472 472
473 datatype sql_type = 473 datatype sql_type = datatype Settings.sql_type
474 Int 474 val isBlob = Settings.isBlob
475 | Float
476 | String
477 | Bool
478 | Time
479 | Blob
480 | Channel
481 | Client
482 | Nullable of sql_type
483
484 fun isBlob Blob = true
485 | isBlob (Nullable t) = isBlob t
486 | isBlob _ = false
487 475
488 fun isFile (t : typ) = 476 fun isFile (t : typ) =
489 case #1 t of 477 case #1 t of
490 TFfi ("Basis", "file") => true 478 TFfi ("Basis", "file") => true
491 | _ => false 479 | _ => false
1248 space) 1236 space)
1249 in 1237 in
1250 urlify' IS.empty 0 t 1238 urlify' IS.empty 0 t
1251 end 1239 end
1252 1240
1241 fun sql_type_in env (tAll as (t, loc)) =
1242 case t of
1243 TFfi ("Basis", "int") => Int
1244 | TFfi ("Basis", "float") => Float
1245 | TFfi ("Basis", "string") => String
1246 | TFfi ("Basis", "bool") => Bool
1247 | TFfi ("Basis", "time") => Time
1248 | TFfi ("Basis", "blob") => Blob
1249 | TFfi ("Basis", "channel") => Channel
1250 | TFfi ("Basis", "client") => Client
1251 | TOption t' => Nullable (sql_type_in env t')
1252 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
1253 Print.eprefaces' [("Type", p_typ env tAll)];
1254 Int)
1255
1253 fun p_exp' par env (e, loc) = 1256 fun p_exp' par env (e, loc) =
1254 case e of 1257 case e of
1255 EPrim p => Prim.p_t_GCC p 1258 EPrim p => Prim.p_t_GCC p
1256 | ERel n => p_rel env n 1259 | ERel n => p_rel env n
1257 | ENamed n => p_enamed env n 1260 | ENamed n => p_enamed env n
1568 val outputs = exps @ tables 1571 val outputs = exps @ tables
1569 val outputs = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) outputs 1572 val outputs = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) outputs
1570 1573
1571 val wontLeakStrings = notLeaky env true state 1574 val wontLeakStrings = notLeaky env true state
1572 val wontLeakAnything = notLeaky env false state 1575 val wontLeakAnything = notLeaky env false state
1576
1577 val inputs =
1578 case prepared of
1579 NONE => []
1580 | SOME _ => getPargs query
1581
1582 fun doCols p_getcol =
1583 box [string "struct __uws_",
1584 string (Int.toString rnum),
1585 string " __uwr_r_",
1586 string (Int.toString (E.countERels env)),
1587 string ";",
1588 newline,
1589 p_typ env state,
1590 space,
1591 string "__uwr_acc_",
1592 string (Int.toString (E.countERels env + 1)),
1593 space,
1594 string "=",
1595 space,
1596 string "acc;",
1597 newline,
1598 newline,
1599 p_list_sepi (box []) (fn i =>
1600 fn (proj, t) =>
1601 box [string "__uwr_r_",
1602 string (Int.toString (E.countERels env)),
1603 string ".",
1604 string proj,
1605 space,
1606 string "=",
1607 space,
1608 p_getcol {wontLeakStrings = wontLeakStrings,
1609 col = i,
1610 typ = sql_type_in env t},
1611 string ";",
1612 newline]) outputs,
1613 newline,
1614 newline,
1615
1616 string "acc",
1617 space,
1618 string "=",
1619 space,
1620 p_exp (E.pushERel
1621 (E.pushERel env "r" (TRecord rnum, loc))
1622 "acc" state)
1623 body,
1624 string ";",
1625 newline]
1573 in 1626 in
1574 box [if wontLeakAnything then 1627 box [if wontLeakAnything then
1575 string "(uw_begin_region(ctx), " 1628 string "(uw_begin_region(ctx), "
1576 else 1629 else
1577 box [], 1630 box [],
1578 string "({", 1631 string "({",
1579 newline,
1580 string "PGconn *conn = uw_get_db(ctx);",
1581 newline, 1632 newline,
1582 p_typ env state, 1633 p_typ env state,
1583 space, 1634 space,
1584 string "acc", 1635 string "acc",
1585 space, 1636 space,
1586 string "=", 1637 string "=",
1587 space, 1638 space,
1588 p_exp env initial, 1639 p_exp env initial,
1589 string ";", 1640 string ";",
1590 newline, 1641 newline,
1591 string "int n, i, dummy = (uw_begin_region(ctx), 0);", 1642 string "int dummy = (uw_begin_region(ctx), 0);",
1592 newline, 1643 newline,
1593 1644
1594 case prepared of 1645 case prepared of
1595 NONE => box [string "char *query = ", 1646 NONE =>
1596 p_exp env query, 1647 box [string "char *query = ",
1597 string ";", 1648 p_exp env query,
1598 newline] 1649 string ";",
1599 | SOME _ => 1650 newline,
1600 let 1651 newline,
1601 val ets = getPargs query 1652
1602 in 1653 #query (Settings.currentDbms ())
1603 box [p_list_sepi newline 1654 {loc = loc,
1604 (fn i => fn (e, t) => 1655 numCols = length outputs,
1605 box [p_sql_type t, 1656 doCols = doCols}]
1606 space, 1657 | SOME (id, query) =>
1607 string "arg", 1658 box [p_list_sepi newline
1608 string (Int.toString (i + 1)), 1659 (fn i => fn (e, t) =>
1609 space, 1660 box [p_sql_type t,
1610 string "=", 1661 space,
1611 space, 1662 string "arg",
1612 p_exp env e, 1663 string (Int.toString (i + 1)),
1613 string ";"]) 1664 space,
1614 ets, 1665 string "=",
1615 newline, 1666 space,
1616 newline, 1667 p_exp env e,
1617 1668 string ";"])
1618 string "const int paramFormats[] = { ", 1669 inputs,
1619 p_list_sep (box [string ",", space]) 1670 newline,
1620 (fn (_, t) => if isBlob t then string "1" else string "0") ets, 1671 newline,
1621 string " };", 1672
1622 newline, 1673 #queryPrepared (Settings.currentDbms ())
1623 string "const int paramLengths[] = { ", 1674 {loc = loc,
1624 p_list_sepi (box [string ",", space]) 1675 id = id,
1625 (fn i => fn (_, Blob) => string ("arg" ^ Int.toString (i + 1) ^ ".size") 1676 query = query,
1626 | (_, Nullable Blob) => string ("arg" ^ Int.toString (i + 1) 1677 inputs = map #2 inputs,
1627 ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0") 1678 numCols = length outputs,
1628 | _ => string "0") ets, 1679 doCols = doCols}],
1629 string " };", 1680 newline,
1630 newline, 1681
1631 string "const char *paramValues[] = { ",
1632 p_list_sepi (box [string ",", space])
1633 (fn i => fn (_, t) => p_ensql t (box [string "arg",
1634 string (Int.toString (i + 1))]))
1635 ets,
1636 string " };",
1637 newline,
1638 newline]
1639 end,
1640
1641 string "PGresult *res = ",
1642 case prepared of
1643 NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
1644 | SOME (n, s) =>
1645 if #persistent (Settings.currentProtocol ()) then
1646 box [string "PQexecPrepared(conn, \"uw",
1647 string (Int.toString n),
1648 string "\", ",
1649 string (Int.toString (length (getPargs query))),
1650 string ", paramValues, paramLengths, paramFormats, 0);"]
1651 else
1652 box [string "PQexecParams(conn, \"",
1653 string (String.toString s),
1654 string "\", ",
1655 string (Int.toString (length (getPargs query))),
1656 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
1657 newline,
1658 newline,
1659
1660 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
1661 newline,
1662 newline,
1663
1664 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
1665 newline,
1666 box [string "PQclear(res);",
1667 newline,
1668 string "uw_error(ctx, FATAL, \"",
1669 string (ErrorMsg.spanToString loc),
1670 string ": Query failed:\\n%s\\n%s\", ",
1671 case prepared of
1672 NONE => string "query"
1673 | SOME _ => p_exp env query,
1674 string ", PQerrorMessage(conn));",
1675 newline],
1676 string "}",
1677 newline,
1678 newline,
1679
1680 string "if (PQnfields(res) != ",
1681 string (Int.toString (length outputs)),
1682 string ") {",
1683 newline,
1684 box [string "int nf = PQnfields(res);",
1685 newline,
1686 string "PQclear(res);",
1687 newline,
1688 string "uw_error(ctx, FATAL, \"",
1689 string (ErrorMsg.spanToString loc),
1690 string ": Query returned %d columns instead of ",
1691 string (Int.toString (length outputs)),
1692 string ":\\n%s\\n%s\", ",
1693 case prepared of
1694 NONE => string "query"
1695 | SOME _ => p_exp env query,
1696 string ", nf, PQerrorMessage(conn));",
1697 newline],
1698 string "}",
1699 newline,
1700 newline,
1701
1702 string "uw_end_region(ctx);",
1703 newline,
1704 string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);",
1705 newline,
1706 string "n = PQntuples(res);",
1707 newline,
1708 string "for (i = 0; i < n; ++i) {",
1709 newline,
1710 box [string "struct",
1711 space,
1712 string "__uws_",
1713 string (Int.toString rnum),
1714 space,
1715 string "__uwr_r_",
1716 string (Int.toString (E.countERels env)),
1717 string ";",
1718 newline,
1719 p_typ env state,
1720 space,
1721 string "__uwr_acc_",
1722 string (Int.toString (E.countERels env + 1)),
1723 space,
1724 string "=",
1725 space,
1726 string "acc;",
1727 newline,
1728 newline,
1729
1730 p_list_sepi (box []) (fn i =>
1731 fn (proj, t) =>
1732 box [string "__uwr_r_",
1733 string (Int.toString (E.countERels env)),
1734 string ".",
1735 string proj,
1736 space,
1737 string "=",
1738 space,
1739 p_getcol wontLeakStrings env t i,
1740 string ";",
1741 newline]) outputs,
1742
1743 newline,
1744 newline,
1745
1746 string "acc",
1747 space,
1748 string "=",
1749 space,
1750 p_exp (E.pushERel
1751 (E.pushERel env "r" (TRecord rnum, loc))
1752 "acc" state)
1753 body,
1754 string ";",
1755 newline],
1756 string "}",
1757 newline,
1758 newline,
1759 string "uw_pop_cleanup(ctx);",
1760 newline,
1761 if wontLeakAnything then 1682 if wontLeakAnything then
1762 box [string "uw_end_region(ctx);", 1683 box [string "uw_end_region(ctx);",
1763 newline] 1684 newline]
1764 else 1685 else
1765 box [], 1686 box [],