Mercurial > urweb

comparison src/cjr_print.sml @ 870:7fa9a37a34b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Move all DBMS initialization to #init
author Adam Chlipala <adamc@hcoop.net>
date Tue, 30 Jun 2009 15:45:10 -0400
parents 64ba57fa20bf
children 9654bce27cff
comparison
equal deleted inserted replaced
869:64ba57fa20bf 870:7fa9a37a34b3
1835 string ");"], 1835 string ");"],
1836 newline, 1836 newline,
1837 string "}"] 1837 string "}"]
1838 end 1838 end
1839 1839
1840 val prepped = ref ([] : (string * int) list)
1841
1842 fun p_decl env (dAll as (d, _) : decl) = 1840 fun p_decl env (dAll as (d, _) : decl) =
1843 case d of 1841 case d of
1844 DStruct (n, xts) => 1842 DStruct (n, xts) =>
1845 let 1843 let
1846 val env = E.declBinds env dAll 1844 val env = E.declBinds env dAll
1988 space, 1986 space,
1989 string s, 1987 string s,
1990 space, 1988 space,
1991 string " */", 1989 string " */",
1992 newline] 1990 newline]
1993 | DDatabase {name, expunge, initialize} => 1991 | DDatabase _ => box []
1994 box [string "static void uw_db_validate(uw_context);", 1992 | DPreparedStatements _ => box []
1995 newline,
1996 string "static void uw_db_prepare(uw_context);",
1997 newline,
1998 newline,
1999
2000 #init (Settings.currentDbms ()) (name, !prepped),
2001
2002 string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
2003 newline,
2004 box [p_enamed env expunge,
2005 string "(ctx, cli);",
2006 newline],
2007 string "}",
2008 newline,
2009 newline,
2010
2011 string "void uw_initializer(uw_context ctx) {",
2012 newline,
2013 box [p_enamed env initialize,
2014 string "(ctx, uw_unit_v);",
2015 newline],
2016 string "}",
2017 newline]
2018
2019 | DPreparedStatements ss =>
2020 (prepped := ss;
2021 box [])
2022 1993
2023 | DJavaScript s => box [string "static char jslib[] = \"", 1994 | DJavaScript s => box [string "static char jslib[] = \"",
2024 string (String.toString s), 1995 string (String.toString s),
2025 string "\";"] 1996 string "\";"]
2026 | DCookie s => box [string "/*", 1997 | DCookie s => box [string "/*",
2603 ] 2574 ]
2604 end 2575 end
2605 2576
2606 val pds' = map p_page ps 2577 val pds' = map p_page ps
2607 2578
2608 val tables = List.mapPartial (fn (DTable (s, xts, _, _), _) => SOME (s, xts) 2579 val hasDb = ref false
2609 | _ => NONE) ds 2580 val tables = ref []
2610 val sequences = List.mapPartial (fn (DSequence s, _) => SOME s 2581 val sequences = ref []
2611 | _ => NONE) ds 2582 val dbstring = ref ""
2612 2583 val expunge = ref 0
2613 val validate = 2584 val initialize = ref 0
2614 if #persistent (Settings.currentProtocol ()) then 2585 val prepped = ref []
2615 box [string "static void uw_db_validate(uw_context ctx) {", 2586
2616 newline, 2587 val () = app (fn d =>
2617 string "PGconn *conn = uw_get_db(ctx);", 2588 case #1 d of
2618 newline, 2589 DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
2619 string "PGresult *res;", 2590 dbstring := x;
2620 newline, 2591 expunge := y;
2621 newline, 2592 initialize := z)
2622 p_list_sep newline 2593 | DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
2623 (fn (s, xts) => 2594 (x, sql_type_in env t)) xts) :: !tables
2624 let 2595 | DSequence s => sequences := s :: !sequences
2625 val sl = CharVector.map Char.toLower s 2596 | DPreparedStatements ss => prepped := ss
2626 2597 | _ => ()) ds
2627 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" 2598
2628 ^ sl ^ "'" 2599 val hasDb = !hasDb
2629
2630 val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
2631 sl,
2632 "') AND (",
2633 String.concatWith " OR "
2634 (map (fn (x, t) =>
2635 String.concat ["(attname = 'uw_",
2636 CharVector.map
2637 Char.toLower (ident x),
2638 "' AND atttypid = (SELECT oid FROM pg_type",
2639 " WHERE typname = '",
2640 p_sqltype_base' env t,
2641 "') AND attnotnull = ",
2642 if is_not_null t then
2643 "TRUE"
2644 else
2645 "FALSE",
2646 ")"]) xts),
2647 ")"]
2648
2649 val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
2650 sl,
2651 "') AND attname LIKE 'uw_%'"]
2652 in
2653 box [string "res = PQexec(conn, \"",
2654 string q,
2655 string "\");",
2656 newline,
2657 newline,
2658 string "if (res == NULL) {",
2659 newline,
2660 box [string "PQfinish(conn);",
2661 newline,
2662 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
2663 newline],
2664 string "}",
2665 newline,
2666 newline,
2667 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
2668 newline,
2669 box [string "char msg[1024];",
2670 newline,
2671 string "strncpy(msg, PQerrorMessage(conn), 1024);",
2672 newline,
2673 string "msg[1023] = 0;",
2674 newline,
2675 string "PQclear(res);",
2676 newline,
2677 string "PQfinish(conn);",
2678 newline,
2679 string "uw_error(ctx, FATAL, \"Query failed:\\n",
2680 string q,
2681 string "\\n%s\", msg);",
2682 newline],
2683 string "}",
2684 newline,
2685 newline,
2686 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
2687 newline,
2688 box [string "PQclear(res);",
2689 newline,
2690 string "PQfinish(conn);",
2691 newline,
2692 string "uw_error(ctx, FATAL, \"Table '",
2693 string s,
2694 string "' does not exist.\");",
2695 newline],
2696 string "}",
2697 newline,
2698 newline,
2699 string "PQclear(res);",
2700 newline,
2701
2702 string "res = PQexec(conn, \"",
2703 string q',
2704 string "\");",
2705 newline,
2706 newline,
2707 string "if (res == NULL) {",
2708 newline,
2709 box [string "PQfinish(conn);",
2710 newline,
2711 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
2712 newline],
2713 string "}",
2714 newline,
2715 newline,
2716 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
2717 newline,
2718 box [string "char msg[1024];",
2719 newline,
2720 string "strncpy(msg, PQerrorMessage(conn), 1024);",
2721 newline,
2722 string "msg[1023] = 0;",
2723 newline,
2724 string "PQclear(res);",
2725 newline,
2726 string "PQfinish(conn);",
2727 newline,
2728 string "uw_error(ctx, FATAL, \"Query failed:\\n",
2729 string q',
2730 string "\\n%s\", msg);",
2731 newline],
2732 string "}",
2733 newline,
2734 newline,
2735 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
2736 string (Int.toString (length xts)),
2737 string "\")) {",
2738 newline,
2739 box [string "PQclear(res);",
2740 newline,
2741 string "PQfinish(conn);",
2742 newline,
2743 string "uw_error(ctx, FATAL, \"Table '",
2744 string s,
2745 string "' has the wrong column types.\");",
2746 newline],
2747 string "}",
2748 newline,
2749 newline,
2750 string "PQclear(res);",
2751 newline,
2752 newline,
2753
2754 string "res = PQexec(conn, \"",
2755 string q'',
2756 string "\");",
2757 newline,
2758 newline,
2759 string "if (res == NULL) {",
2760 newline,
2761 box [string "PQfinish(conn);",
2762 newline,
2763 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
2764 newline],
2765 string "}",
2766 newline,
2767 newline,
2768 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
2769 newline,
2770 box [string "char msg[1024];",
2771 newline,
2772 string "strncpy(msg, PQerrorMessage(conn), 1024);",
2773 newline,
2774 string "msg[1023] = 0;",
2775 newline,
2776 string "PQclear(res);",
2777 newline,
2778 string "PQfinish(conn);",
2779 newline,
2780 string "uw_error(ctx, FATAL, \"Query failed:\\n",
2781 string q'',
2782 string "\\n%s\", msg);",
2783 newline],
2784 string "}",
2785 newline,
2786 newline,
2787 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
2788 string (Int.toString (length xts)),
2789 string "\")) {",
2790 newline,
2791 box [string "PQclear(res);",
2792 newline,
2793 string "PQfinish(conn);",
2794 newline,
2795 string "uw_error(ctx, FATAL, \"Table '",
2796 string s,
2797 string "' has extra columns.\");",
2798 newline],
2799 string "}",
2800 newline,
2801 newline,
2802 string "PQclear(res);",
2803 newline]
2804 end) tables,
2805
2806 p_list_sep newline
2807 (fn s =>
2808 let
2809 val sl = CharVector.map Char.toLower s
2810
2811 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
2812 ^ sl ^ "' AND relkind = 'S'"
2813 in
2814 box [string "res = PQexec(conn, \"",
2815 string q,
2816 string "\");",
2817 newline,
2818 newline,
2819 string "if (res == NULL) {",
2820 newline,
2821 box [string "PQfinish(conn);",
2822 newline,
2823 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
2824 newline],
2825 string "}",
2826 newline,
2827 newline,
2828 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
2829 newline,
2830 box [string "char msg[1024];",
2831 newline,
2832 string "strncpy(msg, PQerrorMessage(conn), 1024);",
2833 newline,
2834 string "msg[1023] = 0;",
2835 newline,
2836 string "PQclear(res);",
2837 newline,
2838 string "PQfinish(conn);",
2839 newline,
2840 string "uw_error(ctx, FATAL, \"Query failed:\\n",
2841 string q,
2842 string "\\n%s\", msg);",
2843 newline],
2844 string "}",
2845 newline,
2846 newline,
2847 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
2848 newline,
2849 box [string "PQclear(res);",
2850 newline,
2851 string "PQfinish(conn);",
2852 newline,
2853 string "uw_error(ctx, FATAL, \"Sequence '",
2854 string s,
2855 string "' does not exist.\");",
2856 newline],
2857 string "}",
2858 newline,
2859 newline,
2860 string "PQclear(res);",
2861 newline]
2862 end) sequences,
2863
2864 string "}"]
2865 else
2866 string "static void uw_db_validate(uw_context ctx) { }"
2867
2868 val hasDb = List.exists (fn (DDatabase _, _) => true | _ => false) ds
2869 2600
2870 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds 2601 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
2871 2602
2872 val cookieCode = foldl (fn (cookie, acc) => 2603 val cookieCode = foldl (fn (cookie, acc) =>
2873 SOME (case acc of 2604 SOME (case acc of
2918 if hasDb then 2649 if hasDb then
2919 box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), 2650 box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
2920 newline] 2651 newline]
2921 else 2652 else
2922 box [], 2653 box [],
2923 newline,
2924 p_list_sep (box []) (fn s => box [string "#include \"", 2654 p_list_sep (box []) (fn s => box [string "#include \"",
2925 string s, 2655 string s,
2926 string "\"", 2656 string "\"",
2927 newline]) (Settings.getHeaders ()), 2657 newline]) (Settings.getHeaders ()),
2928 string "#include \"", 2658 string "#include \"",
2929 string (OS.Path.joinDirFile {dir = Config.includ, 2659 string (OS.Path.joinDirFile {dir = Config.includ,
2930 file = "urweb.h"}), 2660 file = "urweb.h"}),
2931 string "\"", 2661 string "\"",
2662 newline,
2663 newline,
2664
2665 if hasDb then
2666 #init (Settings.currentDbms ()) {dbstring = !dbstring,
2667 prepared = !prepped,
2668 tables = !tables,
2669 sequences = !sequences}
2670 else
2671 box [string "void uw_db_init(uw_context ctx) { };",
2672 newline,
2673 string "int uw_db_begin(uw_context ctx) { return 0; };",
2674 newline,
2675 string "int uw_db_commit(uw_context ctx) { return 0; };",
2676 newline,
2677 string "int uw_db_rollback(uw_context ctx) { return 0; };"],
2932 newline, 2678 newline,
2933 newline, 2679 newline,
2934 2680
2935 string "const char *uw_url_prefix = \"", 2681 string "const char *uw_url_prefix = \"",
2936 string (Settings.getUrlPrefix ()), 2682 string (Settings.getUrlPrefix ()),
3006 string "uw_error(ctx, FATAL, \"Unknown page\");", 2752 string "uw_error(ctx, FATAL, \"Unknown page\");",
3007 newline, 2753 newline,
3008 string "}", 2754 string "}",
3009 newline, 2755 newline,
3010 newline, 2756 newline,
2757
3011 if hasDb then 2758 if hasDb then
3012 validate 2759 box [string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
2760 newline,
2761 box [p_enamed env (!expunge),
2762 string "(ctx, cli);",
2763 newline],
2764 string "}",
2765 newline,
2766 newline,
2767
2768 string "void uw_initializer(uw_context ctx) {",
2769 newline,
2770 box [p_enamed env (!initialize),
2771 string "(ctx, uw_unit_v);",
2772 newline],
2773 string "}",
2774 newline]
3013 else 2775 else
3014 box [], 2776 box [string "void uw_expunger(uw_context ctx, uw_Basis_client cli) { };",
3015 newline,
3016 if List.exists (fn (DDatabase _, _) => true | _ => false) ds then
3017 box []
3018 else
3019 box [newline,
3020 string "void uw_db_init(uw_context ctx) { };",
3021 newline,
3022 string "int uw_db_begin(uw_context ctx) { return 0; };",
3023 newline,
3024 string "int uw_db_commit(uw_context ctx) { return 0; };",
3025 newline,
3026 string "int uw_db_rollback(uw_context ctx) { return 0; };",
3027 newline,
3028 string "void uw_expunger(uw_context ctx, uw_Basis_client cli) { };",
3029 newline, 2777 newline,
3030 string "void uw_initializer(uw_context ctx) { };", 2778 string "void uw_initializer(uw_context ctx) { };",
3031 newline]] 2779 newline]]
3032 end 2780 end
3033 2781