comparison vext.sml @ 1761:cd10346cc810

Update Vext
author Chris Cannam
date Tue, 23 Jan 2018 12:54:58 +0000
parents 42d57c382e56
children 762ef5d2722a
comparison
equal deleted inserted replaced
1760:89a6d56803fd 1761:cd10346cc810
7 (* 7 (*
8 Vext 8 Vext
9 9
10 A simple manager for third-party source code dependencies 10 A simple manager for third-party source code dependencies
11 11
12 Copyright 2017 Chris Cannam, Particular Programs Ltd, 12 Copyright 2018 Chris Cannam, Particular Programs Ltd,
13 and Queen Mary, University of London 13 and Queen Mary, University of London
14 14
15 Permission is hereby granted, free of charge, to any person 15 Permission is hereby granted, free of charge, to any person
16 obtaining a copy of this software and associated documentation 16 obtaining a copy of this software and associated documentation
17 files (the "Software"), to deal in the Software without 17 files (the "Software"), to deal in the Software without
36 shall not be used in advertising or otherwise to promote the sale, 36 shall not be used in advertising or otherwise to promote the sale,
37 use or other dealings in this Software without prior written 37 use or other dealings in this Software without prior written
38 authorization. 38 authorization.
39 *) 39 *)
40 40
41 val vext_version = "0.9.92" 41 val vext_version = "0.9.94"
42 42
43 43
44 datatype vcs = 44 datatype vcs =
45 HG | 45 HG |
46 GIT | 46 GIT |
307 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_") 307 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
308 (explode arg) 308 (explode arg)
309 then arg 309 then arg
310 else "\"" ^ arg ^ "\"" 310 else "\"" ^ arg ^ "\""
311 fun check arg = 311 fun check arg =
312 let val valid = explode " /#:;?,._-{}@=" 312 let val valid = explode " /#:;?,._-{}@=+"
313 in 313 in
314 app (fn c => 314 app (fn c =>
315 if isAlphaNum c orelse 315 if isAlphaNum c orelse
316 List.exists (fn v => v = c) valid 316 List.exists (fn v => v = c) valid orelse
317 c > chr 127
317 then () 318 then ()
318 else raise Fail ("Invalid character '" ^ 319 else raise Fail ("Invalid character '" ^
319 (Char.toString c) ^ 320 (Char.toString c) ^
320 "' in command list")) 321 "' in command list"))
321 (explode arg); 322 (explode arg);
582 V.id_of context libname 583 V.id_of context libname
583 584
584 end 585 end
585 586
586 (* Simple Standard ML JSON parser 587 (* Simple Standard ML JSON parser
587 ==============================
588
589 https://bitbucket.org/cannam/sml-simplejson 588 https://bitbucket.org/cannam/sml-simplejson
590 589 Copyright 2017 Chris Cannam. BSD licence.
591 An RFC-compliant JSON parser in one SML file with no dependency
592 on anything outside the Basis library. Also includes a simple
593 serialiser.
594
595 Tested with MLton, Poly/ML, and SML/NJ compilers.
596
597 Parser notes:
598
599 * Complies with RFC 7159, The JavaScript Object Notation (JSON)
600 Data Interchange Format
601
602 * Passes all of the JSONTestSuite parser accept/reject tests that
603 exist at the time of writing, as listed in "Parsing JSON is a
604 Minefield" (http://seriot.ch/parsing_json.php)
605
606 * Two-pass parser using naive exploded strings, therefore not
607 particularly fast and not suitable for large input files
608
609 * Only supports UTF-8 input, not UTF-16 or UTF-32. Doesn't check
610 that JSON strings are valid UTF-8 -- the caller must do that --
611 but does handle \u escapes
612
613 * Converts all numbers to type "real". If that is a 64-bit IEEE
614 float type (common but not guaranteed in SML) then we're pretty
615 standard for a JSON parser
616
617 Copyright 2017 Chris Cannam.
618 Parts based on the JSON parser in the Ponyo library by Phil Eaton. 590 Parts based on the JSON parser in the Ponyo library by Phil Eaton.
619
620 Permission is hereby granted, free of charge, to any person
621 obtaining a copy of this software and associated documentation
622 files (the "Software"), to deal in the Software without
623 restriction, including without limitation the rights to use, copy,
624 modify, merge, publish, distribute, sublicense, and/or sell copies
625 of the Software, and to permit persons to whom the Software is
626 furnished to do so, subject to the following conditions:
627
628 The above copyright notice and this permission notice shall be
629 included in all copies or substantial portions of the Software.
630
631 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
632 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
633 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
634 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
635 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
636 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
637 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
638
639 Except as contained in this notice, the names of Chris Cannam and
640 Particular Programs Ltd shall not be used in advertising or
641 otherwise to promote the sale, use or other dealings in this
642 Software without prior written authorization.
643 *) 591 *)
644 592
645 signature JSON = sig 593 signature JSON = sig
646 594
647 datatype json = OBJECT of (string * json) list 595 datatype json = OBJECT of (string * json) list
1533 fun copy_url_for context libname = 1481 fun copy_url_for context libname =
1534 OK (FileBits.file_url (FileBits.libpath context libname)) 1482 OK (FileBits.file_url (FileBits.libpath context libname))
1535 1483
1536 end 1484 end
1537 1485
1486 (* SubXml - A parser for a subset of XML
1487 https://bitbucket.org/cannam/sml-simplexml
1488 Copyright 2018 Chris Cannam. BSD licence.
1489 *)
1490
1491 signature SUBXML = sig
1492
1493 datatype node = ELEMENT of { name : string, children : node list }
1494 | ATTRIBUTE of { name : string, value : string }
1495 | TEXT of string
1496 | CDATA of string
1497 | COMMENT of string
1498
1499 datatype document = DOCUMENT of { name : string, children : node list }
1500
1501 datatype 'a result = OK of 'a
1502 | ERROR of string
1503
1504 val parse : string -> document result
1505 val serialise : document -> string
1506
1507 end
1508
1509 structure SubXml :> SUBXML = struct
1510
1511 datatype node = ELEMENT of { name : string, children : node list }
1512 | ATTRIBUTE of { name : string, value : string }
1513 | TEXT of string
1514 | CDATA of string
1515 | COMMENT of string
1516
1517 datatype document = DOCUMENT of { name : string, children : node list }
1518
1519 datatype 'a result = OK of 'a
1520 | ERROR of string
1521
1522 structure T = struct
1523 datatype token = ANGLE_L
1524 | ANGLE_R
1525 | ANGLE_SLASH_L
1526 | SLASH_ANGLE_R
1527 | EQUAL
1528 | NAME of string
1529 | TEXT of string
1530 | CDATA of string
1531 | COMMENT of string
1532
1533 fun name t =
1534 case t of ANGLE_L => "<"
1535 | ANGLE_R => ">"
1536 | ANGLE_SLASH_L => "</"
1537 | SLASH_ANGLE_R => "/>"
1538 | EQUAL => "="
1539 | NAME s => "name \"" ^ s ^ "\""
1540 | TEXT s => "text"
1541 | CDATA _ => "CDATA section"
1542 | COMMENT _ => "comment"
1543 end
1544
1545 structure Lex :> sig
1546 val lex : string -> T.token list result
1547 end = struct
1548
1549 fun error pos text =
1550 ERROR (text ^ " at character position " ^ Int.toString (pos-1))
1551 fun tokenError pos token =
1552 error pos ("Unexpected token '" ^ Char.toString token ^ "'")
1553
1554 val nameEnd = explode " \t\n\r\"'</>!=?"
1555
1556 fun quoted quote pos acc cc =
1557 let fun quoted' pos text [] =
1558 error pos "Document ends during quoted string"
1559 | quoted' pos text (x::xs) =
1560 if x = quote
1561 then OK (rev text, xs, pos+1)
1562 else quoted' (pos+1) (x::text) xs
1563 in
1564 case quoted' pos [] cc of
1565 ERROR e => ERROR e
1566 | OK (text, rest, newpos) =>
1567 inside newpos (T.TEXT (implode text) :: acc) rest
1568 end
1569
1570 and name first pos acc cc =
1571 let fun name' pos text [] =
1572 error pos "Document ends during name"
1573 | name' pos text (x::xs) =
1574 if List.find (fn c => c = x) nameEnd <> NONE
1575 then OK (rev text, (x::xs), pos)
1576 else name' (pos+1) (x::text) xs
1577 in
1578 case name' (pos-1) [] (first::cc) of
1579 ERROR e => ERROR e
1580 | OK ([], [], pos) => error pos "Document ends before name"
1581 | OK ([], (x::xs), pos) => tokenError pos x
1582 | OK (text, rest, pos) =>
1583 inside pos (T.NAME (implode text) :: acc) rest
1584 end
1585
1586 and comment pos acc cc =
1587 let fun comment' pos text cc =
1588 case cc of
1589 #"-" :: #"-" :: #">" :: xs => OK (rev text, xs, pos+3)
1590 | x :: xs => comment' (pos+1) (x::text) xs
1591 | [] => error pos "Document ends during comment"
1592 in
1593 case comment' pos [] cc of
1594 ERROR e => ERROR e
1595 | OK (text, rest, pos) =>
1596 outside pos (T.COMMENT (implode text) :: acc) rest
1597 end
1598
1599 and instruction pos acc cc =
1600 case cc of
1601 #"?" :: #">" :: xs => outside (pos+2) acc xs
1602 | #">" :: _ => tokenError pos #">"
1603 | x :: xs => instruction (pos+1) acc xs
1604 | [] => error pos "Document ends during processing instruction"
1605
1606 and cdata pos acc cc =
1607 let fun cdata' pos text cc =
1608 case cc of
1609 #"]" :: #"]" :: #">" :: xs => OK (rev text, xs, pos+3)
1610 | x :: xs => cdata' (pos+1) (x::text) xs
1611 | [] => error pos "Document ends during CDATA section"
1612 in
1613 case cdata' pos [] cc of
1614 ERROR e => ERROR e
1615 | OK (text, rest, pos) =>
1616 outside pos (T.CDATA (implode text) :: acc) rest
1617 end
1618
1619 and doctype pos acc cc =
1620 case cc of
1621 #">" :: xs => outside (pos+1) acc xs
1622 | x :: xs => doctype (pos+1) acc xs
1623 | [] => error pos "Document ends during DOCTYPE"
1624
1625 and declaration pos acc cc =
1626 case cc of
1627 #"-" :: #"-" :: xs =>
1628 comment (pos+2) acc xs
1629 | #"[" :: #"C" :: #"D" :: #"A" :: #"T" :: #"A" :: #"[" :: xs =>
1630 cdata (pos+7) acc xs
1631 | #"D" :: #"O" :: #"C" :: #"T" :: #"Y" :: #"P" :: #"E" :: xs =>
1632 doctype (pos+7) acc xs
1633 | [] => error pos "Document ends during declaration"
1634 | _ => error pos "Unsupported declaration type"
1635
1636 and left pos acc cc =
1637 case cc of
1638 #"/" :: xs => inside (pos+1) (T.ANGLE_SLASH_L :: acc) xs
1639 | #"!" :: xs => declaration (pos+1) acc xs
1640 | #"?" :: xs => instruction (pos+1) acc xs
1641 | xs => inside pos (T.ANGLE_L :: acc) xs
1642
1643 and slash pos acc cc =
1644 case cc of
1645 #">" :: xs => outside (pos+1) (T.SLASH_ANGLE_R :: acc) xs
1646 | x :: _ => tokenError pos x
1647 | [] => error pos "Document ends before element closed"
1648
1649 and close pos acc xs = outside pos (T.ANGLE_R :: acc) xs
1650
1651 and equal pos acc xs = inside pos (T.EQUAL :: acc) xs
1652
1653 and outside pos acc [] = OK acc
1654 | outside pos acc cc =
1655 let fun textOf text = T.TEXT (implode (rev text))
1656 fun outside' pos [] acc [] = OK acc
1657 | outside' pos text acc [] = OK (textOf text :: acc)
1658 | outside' pos text acc (x::xs) =
1659 case x of
1660 #"<" => if text = []
1661 then left (pos+1) acc xs
1662 else left (pos+1) (textOf text :: acc) xs
1663 | x => outside' (pos+1) (x::text) acc xs
1664 in
1665 outside' pos [] acc cc
1666 end
1667
1668 and inside pos acc [] = error pos "Document ends within tag"
1669 | inside pos acc (#"<"::_) = tokenError pos #"<"
1670 | inside pos acc (x::xs) =
1671 (case x of
1672 #" " => inside | #"\t" => inside
1673 | #"\n" => inside | #"\r" => inside
1674 | #"\"" => quoted x | #"'" => quoted x
1675 | #"/" => slash | #">" => close | #"=" => equal
1676 | x => name x) (pos+1) acc xs
1677
1678 fun lex str =
1679 case outside 1 [] (explode str) of
1680 ERROR e => ERROR e
1681 | OK tokens => OK (rev tokens)
1682 end
1683
1684 structure Parse :> sig
1685 val parse : string -> document result
1686 end = struct
1687
1688 fun show [] = "end of input"
1689 | show (tok :: _) = T.name tok
1690
1691 fun error toks text = ERROR (text ^ " before " ^ show toks)
1692
1693 fun attribute elt name toks =
1694 case toks of
1695 T.EQUAL :: T.TEXT value :: xs =>
1696 namedElement {
1697 name = #name elt,
1698 children = ATTRIBUTE { name = name, value = value } ::
1699 #children elt
1700 } xs
1701 | T.EQUAL :: xs => error xs "Expected attribute value"
1702 | toks => error toks "Expected attribute assignment"
1703
1704 and content elt toks =
1705 case toks of
1706 T.ANGLE_SLASH_L :: T.NAME n :: T.ANGLE_R :: xs =>
1707 if n = #name elt
1708 then OK (elt, xs)
1709 else ERROR ("Closing tag </" ^ n ^ "> " ^
1710 "does not match opening <" ^ #name elt ^ ">")
1711 | T.TEXT text :: xs =>
1712 content {
1713 name = #name elt,
1714 children = TEXT text :: #children elt
1715 } xs
1716 | T.CDATA text :: xs =>
1717 content {
1718 name = #name elt,
1719 children = CDATA text :: #children elt
1720 } xs
1721 | T.COMMENT text :: xs =>
1722 content {
1723 name = #name elt,
1724 children = COMMENT text :: #children elt
1725 } xs
1726 | T.ANGLE_L :: xs =>
1727 (case element xs of
1728 ERROR e => ERROR e
1729 | OK (child, xs) =>
1730 content {
1731 name = #name elt,
1732 children = ELEMENT child :: #children elt
1733 } xs)
1734 | tok :: xs =>
1735 error xs ("Unexpected token " ^ T.name tok)
1736 | [] =>
1737 ERROR ("Document ends within element \"" ^ #name elt ^ "\"")
1738
1739 and namedElement elt toks =
1740 case toks of
1741 T.SLASH_ANGLE_R :: xs => OK (elt, xs)
1742 | T.NAME name :: xs => attribute elt name xs
1743 | T.ANGLE_R :: xs => content elt xs
1744 | x :: xs => error xs ("Unexpected token " ^ T.name x)
1745 | [] => ERROR "Document ends within opening tag"
1746
1747 and element toks =
1748 case toks of
1749 T.NAME name :: xs =>
1750 (case namedElement { name = name, children = [] } xs of
1751 ERROR e => ERROR e
1752 | OK ({ name, children }, xs) =>
1753 OK ({ name = name, children = rev children }, xs))
1754 | toks => error toks "Expected element name"
1755
1756 and document [] = ERROR "Empty document"
1757 | document (tok :: xs) =
1758 case tok of
1759 T.TEXT _ => document xs
1760 | T.COMMENT _ => document xs
1761 | T.ANGLE_L =>
1762 (case element xs of
1763 ERROR e => ERROR e
1764 | OK (elt, []) => OK (DOCUMENT elt)
1765 | OK (elt, (T.TEXT _ :: xs)) => OK (DOCUMENT elt)
1766 | OK (elt, xs) => error xs "Extra data after document")
1767 | _ => error xs ("Unexpected token " ^ T.name tok)
1768
1769 fun parse str =
1770 case Lex.lex str of
1771 ERROR e => ERROR e
1772 | OK tokens => document tokens
1773 end
1774
1775 structure Serialise :> sig
1776 val serialise : document -> string
1777 end = struct
1778
1779 fun attributes nodes =
1780 String.concatWith
1781 " "
1782 (map node (List.filter
1783 (fn ATTRIBUTE _ => true | _ => false)
1784 nodes))
1785
1786 and nonAttributes nodes =
1787 String.concat
1788 (map node (List.filter
1789 (fn ATTRIBUTE _ => false | _ => true)
1790 nodes))
1791
1792 and node n =
1793 case n of
1794 TEXT string =>
1795 string
1796 | CDATA string =>
1797 "<![CDATA[" ^ string ^ "]]>"
1798 | COMMENT string =>
1799 "<!-- " ^ string ^ "-->"
1800 | ATTRIBUTE { name, value } =>
1801 name ^ "=" ^ "\"" ^ value ^ "\"" (*!!!*)
1802 | ELEMENT { name, children } =>
1803 "<" ^ name ^
1804 (case (attributes children) of
1805 "" => ""
1806 | s => " " ^ s) ^
1807 (case (nonAttributes children) of
1808 "" => "/>"
1809 | s => ">" ^ s ^ "</" ^ name ^ ">")
1810
1811 fun serialise (DOCUMENT { name, children }) =
1812 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ^
1813 node (ELEMENT { name = name, children = children })
1814 end
1815
1816 val parse = Parse.parse
1817 val serialise = Serialise.serialise
1818
1819 end
1820
1821
1538 structure SvnControl :> VCS_CONTROL = struct 1822 structure SvnControl :> VCS_CONTROL = struct
1539 1823
1540 fun svn_command context libname args = 1824 fun svn_command context libname args =
1541 FileBits.command context libname ("svn" :: args) 1825 FileBits.command context libname ("svn" :: args)
1542 1826
1556 case String.tokens (fn c => c = #":") line of 1840 case String.tokens (fn c => c = #":") line of
1557 [] => ("", "") 1841 [] => ("", "")
1558 | first::rest => 1842 | first::rest =>
1559 (first, strip_leading_ws (String.concatWith ":" rest)) 1843 (first, strip_leading_ws (String.concatWith ":" rest))
1560 end 1844 end
1561 1845
1562 fun svn_info_item context libname key = 1846 structure X = SubXml
1563 (* SVN 1.9 has info --show-item which is what we need, but at 1847
1564 this point we still have 1.8 on the CI boxes so we might as 1848 fun svn_info context libname route =
1565 well aim to support it *) 1849 (* SVN 1.9 has info --show-item which is just what we need,
1566 case svn_command_lines context libname ["info"] of 1850 but at this point we still have 1.8 on the CI boxes so we
1567 ERROR e => ERROR e 1851 might as well aim to support it. For that we really have to
1568 | OK lines => 1852 use the XML output format, since the default info output is
1569 case List.find (fn (k, v) => k = key) (map split_line_pair lines) of 1853 localised. This is the only thing our mini-XML parser is
1570 NONE => ERROR ("Key \"" ^ key ^ "\" not found in output") 1854 used for though, so it would be good to trim it at some
1571 | SOME (_, v) => OK v 1855 point *)
1856 let fun find elt [] = OK elt
1857 | find { children, ... } (first :: rest) =
1858 case List.find (fn (X.ELEMENT { name, ... }) => name = first
1859 | _ => false)
1860 children of
1861 NONE => ERROR ("No element \"" ^ first ^ "\" in SVN XML")
1862 | SOME (X.ELEMENT e) => find e rest
1863 | SOME _ => ERROR "Internal error"
1864 in
1865 case svn_command_output context libname ["info", "--xml"] of
1866 ERROR e => ERROR e
1867 | OK xml =>
1868 case X.parse xml of
1869 X.ERROR e => ERROR e
1870 | X.OK (X.DOCUMENT doc) => find doc route
1871 end
1572 1872
1573 fun exists context libname = 1873 fun exists context libname =
1574 OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn")) 1874 OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn"))
1575 handle _ => OK false 1875 handle _ => OK false
1576 1876
1577 fun remote_for context (libname, source) = 1877 fun remote_for context (libname, source) =
1578 Provider.remote_url context SVN source libname 1878 Provider.remote_url context SVN source libname
1579 1879
1880 (* Remote the checkout came from, not necessarily the one we want *)
1881 fun actual_remote_for context libname =
1882 case svn_info context libname ["entry", "url"] of
1883 ERROR e => ERROR e
1884 | OK { children, ... } =>
1885 case List.find (fn (X.TEXT _) => true | _ => false) children of
1886 NONE => ERROR "No content for URL in SVN info XML"
1887 | SOME (X.TEXT url) => OK url
1888 | SOME _ => ERROR "Internal error"
1889
1580 fun id_of context libname = 1890 fun id_of context libname =
1581 svn_info_item context libname "Revision" (*!!! check: does svn localise this? should we ensure C locale? *) 1891 case svn_info context libname ["entry"] of
1892 ERROR e => ERROR e
1893 | OK { children, ... } =>
1894 case List.find
1895 (fn (X.ATTRIBUTE { name = "revision", ... }) => true
1896 | _ => false)
1897 children of
1898 NONE => ERROR "No revision for entry in SVN info XML"
1899 | SOME (X.ATTRIBUTE { value, ... }) => OK value
1900 | SOME _ => ERROR "Internal error"
1582 1901
1583 fun is_at context (libname, id_or_tag) = 1902 fun is_at context (libname, id_or_tag) =
1584 case id_of context libname of 1903 case id_of context libname of
1585 ERROR e => ERROR e 1904 ERROR e => ERROR e
1586 | OK id => OK (id = id_or_tag) 1905 | OK id => OK (id = id_or_tag)
1587 1906
1588 fun is_on_branch context (libname, b) = 1907 fun is_on_branch context (libname, b) =
1589 OK (b = DEFAULT_BRANCH) 1908 OK (b = DEFAULT_BRANCH)
1909
1910 fun check_remote context (libname, source) =
1911 case (remote_for context (libname, source),
1912 actual_remote_for context libname) of
1913 (_, ERROR e) => ERROR e
1914 | (url, OK actual) =>
1915 if actual = url
1916 then OK ()
1917 else svn_command context libname ["relocate", url]
1590 1918
1591 fun is_newest context (libname, source, branch) = 1919 fun is_newest context (libname, source, branch) =
1592 case svn_command_lines context libname ["status", "--show-updates"] of 1920 case check_remote context (libname, source) of
1593 ERROR e => ERROR e 1921 ERROR e => ERROR e
1594 | OK lines => 1922 | OK () =>
1595 case rev lines of 1923 case svn_command_lines context libname
1596 [] => ERROR "No result returned for server status" 1924 ["status", "--show-updates"] of
1597 | last_line::_ => 1925 ERROR e => ERROR e
1598 case rev (String.tokens (fn c => c = #" ") last_line) of 1926 | OK lines =>
1599 [] => ERROR "No revision field found in server status" 1927 case rev lines of
1600 | server_id::_ => is_at context (libname, server_id) 1928 [] => ERROR "No result returned for server status"
1929 | last_line::_ =>
1930 case rev (String.tokens (fn c => c = #" ") last_line) of
1931 [] => ERROR "No revision field found in server status"
1932 | server_id::_ => is_at context (libname, server_id)
1601 1933
1602 fun is_newest_locally context (libname, branch) = 1934 fun is_newest_locally context (libname, branch) =
1603 OK true (* no local history *) 1935 OK true (* no local history *)
1604 1936
1605 fun is_modified_locally context libname = 1937 fun is_modified_locally context libname =
1625 ERROR e => ERROR e 1957 ERROR e => ERROR e
1626 | _ => svn_command context "" ["checkout", url, libname] 1958 | _ => svn_command context "" ["checkout", url, libname]
1627 end 1959 end
1628 1960
1629 fun update context (libname, source, branch) = 1961 fun update context (libname, source, branch) =
1630 case svn_command context libname 1962 case check_remote context (libname, source) of
1631 ["update", "--accept", "postpone"] of
1632 ERROR e => ERROR e 1963 ERROR e => ERROR e
1633 | _ => OK () 1964 | OK () =>
1965 case svn_command context libname
1966 ["update", "--accept", "postpone"] of
1967 ERROR e => ERROR e
1968 | _ => OK ()
1634 1969
1635 fun update_to context (libname, _, "") = 1970 fun update_to context (libname, _, "") =
1636 ERROR "Non-empty id (tag or revision id) required for update_to" 1971 ERROR "Non-empty id (tag or revision id) required for update_to"
1637 | update_to context (libname, source, id) = 1972 | update_to context (libname, source, id) =
1638 case svn_command context libname 1973 case check_remote context (libname, source) of
1639 ["update", "-r", id, "--accept", "postpone"] of
1640 ERROR e => ERROR e 1974 ERROR e => ERROR e
1641 | OK _ => OK () 1975 | OK () =>
1976 case svn_command context libname
1977 ["update", "-r", id, "--accept", "postpone"] of
1978 ERROR e => ERROR e
1979 | OK _ => OK ()
1642 1980
1643 fun copy_url_for context libname = 1981 fun copy_url_for context libname =
1644 svn_info_item context libname "URL" 1982 actual_remote_for context libname
1645 1983
1646 end 1984 end
1647 1985
1648 structure AnyLibControl :> LIB_CONTROL = struct 1986 structure AnyLibControl :> LIB_CONTROL = struct
1649 1987