Mercurial > urweb

comparison src/mysql.sml @ 873:41971801b62d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
MySQL query gets up to C linking
author Adam Chlipala <adamc@hcoop.net>
date Sun, 12 Jul 2009 13:16:05 -0400
parents 9654bce27cff
children 3c7b48040dcf
comparison
equal deleted inserted replaced
872:9654bce27cff 873:41971801b62d
28 structure MySQL :> MYSQL = struct 28 structure MySQL :> MYSQL = struct
29 29
30 open Settings 30 open Settings
31 open Print.PD 31 open Print.PD
32 open Print 32 open Print
33
34 fun p_sql_type t =
35 case t of
36 Int => "bigint"
37 | Float => "double"
38 | String => "longtext"
39 | Bool => "bool"
40 | Time => "timestamp"
41 | Blob => "longblob"
42 | Channel => "bigint"
43 | Client => "int"
44 | Nullable t => p_sql_type t
45
46 fun p_buffer_type t =
47 case t of
48 Int => "MYSQL_TYPE_LONGLONG"
49 | Float => "MYSQL_TYPE_DOUBLE"
50 | String => "MYSQL_TYPE_STRING"
51 | Bool => "MYSQL_TYPE_LONG"
52 | Time => "MYSQL_TYPE_TIME"
53 | Blob => "MYSQL_TYPE_BLOB"
54 | Channel => "MYSQL_TYPE_LONGLONG"
55 | Client => "MYSQL_TYPE_LONG"
56 | Nullable t => p_buffer_type t
33 57
34 fun init {dbstring, prepared = ss, tables, views, sequences} = 58 fun init {dbstring, prepared = ss, tables, views, sequences} =
35 let 59 let
36 val host = ref NONE 60 val host = ref NONE
37 val user = ref NONE 61 val user = ref NONE
136 newline, 160 newline,
137 string "msg[1023] = 0;", 161 string "msg[1023] = 0;",
138 newline, 162 newline,
139 uhoh true "Error preparing statement: %s" ["msg"]], 163 uhoh true "Error preparing statement: %s" ["msg"]],
140 string "}", 164 string "}",
165 newline,
166 string "conn->p",
167 string (Int.toString i),
168 string " = stmt;",
141 newline] 169 newline]
142 end) 170 end)
143 ss, 171 ss,
144 172
145 string "}"] 173 string "}"]
251 string "}", 279 string "}",
252 newline, 280 newline,
253 newline] 281 newline]
254 end 282 end
255 283
256 fun query _ = raise Fail "MySQL query" 284 fun p_getcol {wontLeakStrings = _, col = i, typ = t} =
257 fun queryPrepared _ = raise Fail "MySQL queryPrepared" 285 let
258 fun dml _ = raise Fail "MySQL dml" 286 fun getter t =
259 fun dmlPrepared _ = raise Fail "MySQL dmlPrepared" 287 case t of
260 fun nextval _ = raise Fail "MySQL nextval" 288 String => box [string "({",
261 fun nextvalPrepared _ = raise Fail "MySQL nextvalPrepared" 289 newline,
290 string "uw_Basis_string s = uw_malloc(ctx, length",
291 string (Int.toString i),
292 string " + 1);",
293 newline,
294 string "out[",
295 string (Int.toString i),
296 string "].buffer = s;",
297 newline,
298 string "out[",
299 string (Int.toString i),
300 string "].buffer_length = length",
301 string (Int.toString i),
302 string " + 1;",
303 newline,
304 string "mysql_stmt_fetch_column(stmt, &out[",
305 string (Int.toString i),
306 string "], ",
307 string (Int.toString i),
308 string ", 0);",
309 newline,
310 string "s[length",
311 string (Int.toString i),
312 string "] = 0;",
313 newline,
314 string "s;",
315 newline,
316 string "})"]
317 | Blob => box [string "({",
318 newline,
319 string "uw_Basis_blob b = {length",
320 string (Int.toString i),
321 string ", uw_malloc(ctx, length",
322 string (Int.toString i),
323 string ")};",
324 newline,
325 string "out[",
326 string (Int.toString i),
327 string "].buffer = b.data;",
328 newline,
329 string "out[",
330 string (Int.toString i),
331 string "].buffer_length = length",
332 string (Int.toString i),
333 string ";",
334 newline,
335 string "mysql_stmt_fetch_column(stmt, &out[",
336 string (Int.toString i),
337 string "], ",
338 string (Int.toString i),
339 string ", 0);",
340 newline,
341 string "b;",
342 newline,
343 string "})"]
344 | Time => box [string "({",
345 string "MYSQL_TIME *mt = buffer",
346 string (Int.toString i),
347 string ";",
348 newline,
349 newline,
350 string "struct tm t = {mt->second, mt->minute, mt->hour, mt->day, mt->month, mt->year, 0, 0, -1};",
351 newline,
352 string "mktime(&tm);",
353 newline,
354 string "})"]
355 | _ => box [string "buffer",
356 string (Int.toString i)]
357 in
358 case t of
359 Nullable t => box [string "(is_null",
360 string (Int.toString i),
361 string " ? NULL : ",
362 case t of
363 String => getter t
364 | _ => box [string "({",
365 newline,
366 string (p_sql_ctype t),
367 space,
368 string "*tmp = uw_malloc(ctx, sizeof(",
369 string (p_sql_ctype t),
370 string "));",
371 newline,
372 string "*tmp = ",
373 getter t,
374 string ";",
375 newline,
376 string "tmp;",
377 newline,
378 string "})"],
379 string ")"]
380 | _ => box [string "(is_null",
381 string (Int.toString i),
382 string " ? ",
383 box [string "({",
384 string (p_sql_ctype t),
385 space,
386 string "tmp;",
387 newline,
388 string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
389 string (Int.toString i),
390 string "\");",
391 newline,
392 string "tmp;",
393 newline,
394 string "})"],
395 string " : ",
396 getter t,
397 string ")"]
398 end
399
400 fun queryCommon {loc, query, cols, doCols} =
401 box [string "int n, r;",
402 newline,
403 string "MYSQL_BIND out[",
404 string (Int.toString (length cols)),
405 string "];",
406 newline,
407 p_list_sepi (box []) (fn i => fn t =>
408 let
409 fun buffers t =
410 case t of
411 String => box [string "unsigned long length",
412 string (Int.toString i),
413 string ";",
414 newline]
415 | Blob => box [string "unsigned long length",
416 string (Int.toString i),
417 string ";",
418 newline]
419 | _ => box [string (p_sql_ctype t),
420 space,
421 string "buffer",
422 string (Int.toString i),
423 string ";",
424 newline]
425 in
426 box [string "my_bool is_null",
427 string (Int.toString i),
428 string ";",
429 newline,
430 case t of
431 Nullable t => buffers t
432 | _ => buffers t,
433 newline]
434 end) cols,
435 newline,
436
437 string "memset(out, 0, sizeof out);",
438 newline,
439 p_list_sepi (box []) (fn i => fn t =>
440 let
441 fun buffers t =
442 case t of
443 String => box []
444 | Blob => box []
445 | _ => box [string "out[",
446 string (Int.toString i),
447 string "].buffer = &buffer",
448 string (Int.toString i),
449 string ";",
450 newline]
451 in
452 box [string "out[",
453 string (Int.toString i),
454 string "].buffer_type = ",
455 string (p_buffer_type t),
456 string ";",
457 newline,
458 string "out[",
459 string (Int.toString i),
460 string "].is_null = &is_null",
461 string (Int.toString i),
462 string ";",
463 newline,
464
465 case t of
466 Nullable t => buffers t
467 | _ => buffers t,
468 newline]
469 end) cols,
470 newline,
471
472 string "if (mysql_stmt_execute(stmt)) uw_error(ctx, FATAL, \"",
473 string (ErrorMsg.spanToString loc),
474 string ": Error executing query\");",
475 newline,
476 newline,
477
478 string "if (mysql_stmt_store_result(stmt)) uw_error(ctx, FATAL, \"",
479 string (ErrorMsg.spanToString loc),
480 string ": Error storing query result\");",
481 newline,
482 newline,
483
484 string "if (mysql_stmt_bind_result(stmt, out)) uw_error(ctx, FATAL, \"",
485 string (ErrorMsg.spanToString loc),
486 string ": Error binding query result\");",
487 newline,
488 newline,
489
490 string "uw_end_region(ctx);",
491 newline,
492 string "while ((r = mysql_stmt_fetch(stmt)) == 0) {",
493 newline,
494 doCols p_getcol,
495 string "}",
496 newline,
497 newline,
498
499 string "if (r != MYSQL_NO_DATA) uw_error(ctx, FATAL, \"",
500 string (ErrorMsg.spanToString loc),
501 string ": query result fetching failed\");",
502 newline]
503
504 fun query {loc, cols, doCols} =
505 box [string "uw_conn *conn = uw_get_db(ctx);",
506 newline,
507 string "MYSQL_stmt *stmt = mysql_stmt_init(conn->conn);",
508 newline,
509 string "if (stmt == NULL) uw_error(ctx, \"",
510 string (ErrorMsg.spanToString loc),
511 string ": can't allocate temporary prepared statement\");",
512 newline,
513 string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);",
514 newline,
515 string "if (mysql_stmt_prepare(stmt, query, strlen(query))) uw_error(ctx, FATAL, \"",
516 string (ErrorMsg.spanToString loc),
517 string "\");",
518 newline,
519 newline,
520
521 p_list_sepi (box []) (fn i => fn t =>
522 let
523 fun buffers t =
524 case t of
525 String => box []
526 | Blob => box []
527 | _ => box [string "out[",
528 string (Int.toString i),
529 string "].buffer = &buffer",
530 string (Int.toString i),
531 string ";",
532 newline]
533 in
534 box [string "in[",
535 string (Int.toString i),
536 string "].buffer_type = ",
537 string (p_buffer_type t),
538 string ";",
539 newline,
540
541 case t of
542 Nullable t => box [string "in[",
543 string (Int.toString i),
544 string "].is_null = &is_null",
545 string (Int.toString i),
546 string ";",
547 newline,
548 buffers t]
549 | _ => buffers t,
550 newline]
551 end) cols,
552 newline,
553
554 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"},
555
556 string "uw_pop_cleanup(ctx);",
557 newline]
558
559 fun p_ensql t e =
560 case t of
561 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
562 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
563 | String => e
564 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
565 | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"]
566 | Blob => box [e, string ".data"]
567 | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
568 | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
569 | Nullable String => e
570 | Nullable t => box [string "(",
571 e,
572 string " == NULL ? NULL : ",
573 p_ensql t (box [string "(*", e, string ")"]),
574 string ")"]
575
576 fun queryPrepared {loc, id, query, inputs, cols, doCols} =
577 box [string "uw_conn *conn = uw_get_db(ctx);",
578 newline,
579 string "MYSQL_BIND in[",
580 string (Int.toString (length inputs)),
581 string "];",
582 newline,
583 p_list_sepi (box []) (fn i => fn t =>
584 let
585 fun buffers t =
586 case t of
587 String => box [string "unsigned long in_length",
588 string (Int.toString i),
589 string ";",
590 newline]
591 | Blob => box [string "unsigned long in_length",
592 string (Int.toString i),
593 string ";",
594 newline]
595 | Time => box [string (p_sql_ctype t),
596 space,
597 string "in_buffer",
598 string (Int.toString i),
599 string ";",
600 newline]
601 | _ => box []
602 in
603 box [case t of
604 Nullable t => box [string "my_bool in_is_null",
605 string (Int.toString i),
606 string ";",
607 newline,
608 buffers t]
609 | _ => buffers t,
610 newline]
611 end) inputs,
612 string "MYSQL_STMT *stmt = conn->p",
613 string (Int.toString id),
614 string ";",
615 newline,
616 newline,
617
618 string "memset(in, 0, sizeof in);",
619 newline,
620 p_list_sepi (box []) (fn i => fn t =>
621 let
622 fun buffers t =
623 case t of
624 String => box [string "in[",
625 string (Int.toString i),
626 string "].buffer = arg",
627 string (Int.toString (i + 1)),
628 string ";",
629 newline,
630 string "in_length",
631 string (Int.toString i),
632 string "= in[",
633 string (Int.toString i),
634 string "].buffer_length = strlen(arg",
635 string (Int.toString (i + 1)),
636 string ");",
637 newline,
638 string "in[",
639 string (Int.toString i),
640 string "].length = &in_length",
641 string (Int.toString i),
642 string ";",
643 newline]
644 | Blob => box [string "in[",
645 string (Int.toString i),
646 string "].buffer = arg",
647 string (Int.toString (i + 1)),
648 string ".data;",
649 newline,
650 string "in_length",
651 string (Int.toString i),
652 string "= in[",
653 string (Int.toString i),
654 string "].buffer_length = arg",
655 string (Int.toString (i + 1)),
656 string ".size;",
657 newline,
658 string "in[",
659 string (Int.toString i),
660 string "].length = &in_length",
661 string (Int.toString i),
662 string ";",
663 newline]
664 | Time =>
665 let
666 fun oneField dst src =
667 box [string "in_buffer",
668 string (Int.toString i),
669 string ".",
670 string dst,
671 string " = tms.tm_",
672 string src,
673 string ";",
674 newline]
675 in
676 box [string "({",
677 newline,
678 string "struct tm tms;",
679 newline,
680 string "if (localtime_r(&arg",
681 string (Int.toString (i + 1)),
682 string ", &tm) == NULL) uw_error(\"",
683 string (ErrorMsg.spanToString loc),
684 string ": error converting to MySQL time\");",
685 newline,
686 oneField "year" "year",
687 oneField "month" "mon",
688 oneField "day" "mday",
689 oneField "hour" "hour",
690 oneField "minute" "min",
691 oneField "second" "sec",
692 newline,
693 string "in[",
694 string (Int.toString i),
695 string "].buffer = &in_buffer",
696 string (Int.toString i),
697 string ";",
698 newline]
699 end
700
701 | _ => box [string "in[",
702 string (Int.toString i),
703 string "].buffer = &arg",
704 string (Int.toString (i + 1)),
705 string ";",
706 newline]
707 in
708 box [string "in[",
709 string (Int.toString i),
710 string "].buffer_type = ",
711 string (p_buffer_type t),
712 string ";",
713 newline,
714
715 case t of
716 Nullable t => box [string "in[",
717 string (Int.toString i),
718 string "].is_null = &in_is_null",
719 string (Int.toString i),
720 string ";",
721 newline,
722 string "if (arg",
723 string (Int.toString (i + 1)),
724 string " == NULL) {",
725 newline,
726 box [string "in_is_null",
727 string (Int.toString i),
728 string " = 1;",
729 newline],
730 string "} else {",
731 box [case t of
732 String => box []
733 | _ =>
734 box [string (p_sql_ctype t),
735 space,
736 string "arg",
737 string (Int.toString (i + 1)),
738 string " = *arg",
739 string (Int.toString (i + 1)),
740 string ";",
741 newline],
742 string "in_is_null",
743 string (Int.toString i),
744 string " = 0;",
745 newline,
746 buffers t,
747 newline]]
748
749 | _ => buffers t,
750 newline]
751 end) inputs,
752 newline,
753
754 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
755 string (String.toString query),
756 string "\""]}]
757
758 fun dml _ = box []
759 fun dmlPrepared _ = box []
760 fun nextval _ = box []
761 fun nextvalPrepared _ = box []
262 762
263 val () = addDbms {name = "mysql", 763 val () = addDbms {name = "mysql",
264 header = "mysql/mysql.h", 764 header = "mysql/mysql.h",
265 link = "-lmysqlclient", 765 link = "-lmysqlclient",
266 global_init = box [string "void uw_client_init() {", 766 global_init = box [string "void uw_client_init() {",
274 string "}", 774 string "}",
275 newline], 775 newline],
276 string "}", 776 string "}",
277 newline], 777 newline],
278 init = init, 778 init = init,
779 p_sql_type = p_sql_type,
279 query = query, 780 query = query,
280 queryPrepared = queryPrepared, 781 queryPrepared = queryPrepared,
281 dml = dml, 782 dml = dml,
282 dmlPrepared = dmlPrepared, 783 dmlPrepared = dmlPrepared,
283 nextval = nextval, 784 nextval = nextval,