web/htdocs/details/edit.mc

   1 <%args>
   2 $op
   3 $id => undef ### should be extracted using utf8param()
   4 $update => undef
   5 </%args>
   6 <%doc>
   7 Since this form is used in many different situations, some care is
   8 merited in considering the possibilities:
   9
  10 Situation                                       Op      ID      Update
  11 ----------------------------------------------------------------------
  12 Blank form for adding a new target              new
  13 New target rejected, changes required           new             X
  14 New target accepted and added                   new             X
  15 ---------------------------------------------------------------------
  16 Existing target to be edited                    edit    X
  17 Edit rejected, changes required                 edit    X       X
  18 Target successfully updated                     edit    X       X
  19 ----------------------------------------------------------------------
  20 Existing target to be copied                    copy    X
  21 New target rejected, changes required           copy    X       X
  22 New target accepted and added                   copy    X       X
  23 ----------------------------------------------------------------------
  24
  25 Submissions, whether of new targets, edits or copies, may be rejected
  26 due either to missing mandatory fields or host/name/port that form a
  27 duplicate ID.
  28 </%doc>
  29 <%perl>
  30 # Sanity checking
  31 die "op = new but id defined" if $op eq "new" && defined $id;
  32 die "op != new but id undefined" if $op ne "new" && !defined $id;
  33
  34 my $db = ZOOM::IRSpy::connect_to_registry();
  35 my $conn = new ZOOM::Connection($db, 0,
  36                                 user => "admin", password => "fruitbat",
  37                                 elementSetName => "zeerex");
  38
  39 my $protocol = utf8paramTrim($r, "protocol");
  40 my $host = utf8paramTrim($r, "host");
  41 my $port = utf8paramTrim($r, "port");
  42 my $dbname = utf8paramTrim($r, "dbname");
  43 my $title = utf8paramTrim($r, "title");
  44
  45 if ((!defined $port || $port eq "") &&
  46     (defined $protocol && $protocol ne "")) {
  47     # Port-guessing based on defaults for each protocol
  48     $port = $protocol eq "Z39.50" ? 210 : 80;
  49     warn "guessed port $port";
  50     &utf8param($r, port => $port);
  51 }
  52
  53 my $newid;
  54 if (defined $protocol && $protocol ne "" &&
  55     defined $host && $host ne "" &&
  56     defined $port && $port ne "" &&
  57     defined $title && $title ne "" &&
  58     defined $dbname && $dbname ne "") {
  59     $newid = irspy_make_identifier($protocol, $host, $port, $dbname);
  60 }
  61
  62 my $rec = '<explain xmlns="http://explain.z3950.org/dtd/2.0/"/>';
  63
  64 if (!defined $id) {
  65     if (!$update) {
  66         # About to enter data for a new record
  67         # Nothing to do at this stage
  68     } elsif (!defined $newid) {
  69         # Tried to create new record but data is insufficient
  70         print qq[<p class="error">
  71                 Please specify name, protocol, host, port and database name.</p>\n];
  72         undef $update;
  73     } elsif ($host !~ /^[\w-]+\.[\w.-]*\w$/i) {
  74         print qq[<p class="error">
  75                 This host name is not valid.</p>\n];
  76         undef $update;
  77         sleep 25;
  78     } elsif ($port !~ /^\d*$/i) {
  79         print qq[<p class="error">
  80                 This port number is not valid.</p>\n];
  81         undef $update;
  82         sleep 25;
  83     } else {
  84         # Creating new record, all necessary data is present.  Check
  85         # that the new record is not a duplicate of an existing one.
  86         my $rs = $conn->search(new ZOOM::Query::CQL(cql_target($newid)));
  87         if ($rs->size() > 0) {
  88             my $qnewid = xml_encode(uri_escape_utf8($newid));
  89             print qq[<p class="error">
  90                 There is already
  91                 <a href='?op=edit&amp;id=$newid'>a record</a>
  92                 for this protocol, host, port and database name.
  93                 </p>\n];
  94             undef $update;
  95         }
  96     }
  97 } else {
  98     # assert(defined $id);
  99     # Copying or editing an existing record: fetch it for editing
 100     my $query = cql_target($id);
 101     my $rs = $conn->search(new ZOOM::Query::CQL($query));
 102     if ($rs->size() > 0) {
 103         $rec = $rs->record(0);
 104     } else {
 105         ### Is this an error?  I don't think the UI will ever provoke it
 106         print qq[<p class="error">(New ID specified.)</p>\n];
 107         $id = undef;
 108     }
 109 }
 110
 111 my $xc = irspy_xpath_context($rec);
 112 my @fields =
 113     (
 114      [ title        => 0, "Name", "e:databaseInfo/e:title",
 115        qw() ],
 116      [ country      => $m->comp("country-list.mc"),
 117        "Country", "i:status/i:country" ],
 118      [ protocol     => [ qw(Z39.50 SRW SRU) ],
 119        "Protocol", "e:serverInfo/\@protocol" ],
 120      [ host         => 0, "Host", "e:serverInfo/e:host" ],
 121      [ port         => 0, "Port", "e:serverInfo/e:port" ],
 122      [ dbname       => 0, "Database Name", "e:serverInfo/e:database",
 123        qw(e:host e:port) ],
 124      [ udb          => 0, "Access Name (Unique DB)", "e:databaseInfo/i:udb", qw(e:host e:port e:database) ],
 125      [ type         => $m->comp("libtype-list.mc"),
 126        "Type of Library", "i:status/i:libraryType" ],
 127      [ username     => 0, "Username (if needed)", "e:serverInfo/e:authentication/e:user",
 128        qw() ],
 129      [ password     => 0, "Password (if needed)", "e:serverInfo/e:authentication/e:password",
 130        qw(e:user) ],
 131      [ proxy        => 0, "Proxy (if needed)", "e:serverInfo/e:authentication/e:proxy",
 132        qw(e:password) ],
 133      [ description  => 5, "Description", "e:databaseInfo/e:description",
 134        qw(e:title) ],
 135      [ author       => 0, "Author", "e:databaseInfo/e:author",
 136        qw(e:title e:description) ],
 137      [ hosturl       => 0, "URL to Hosting Organisation", "i:status/i:hostURL" ],
 138      [ contact      => 0, "Contact", "e:databaseInfo/e:contact",
 139        qw(e:title e:description) ],
 140      [ extent       => 3, "Extent", "e:databaseInfo/e:extent",
 141        qw(e:title e:description) ],
 142      [ history      => 5, "History", "e:databaseInfo/e:history",
 143        qw(e:title e:description) ],
 144      [ language     => [
 145 # This list was produced by feeding
 146 #       http://www.loc.gov/standards/iso639-2/ISO-639-2_values_8bits.txt
 147 # through the filter
 148 #       awk -F'|' '$3 {print$4}'
 149 # and shortening some of the longer names by hand
 150                         "",
 151                         "English",
 152                         "Afar",
 153                         "Abkhazian",
 154                         "Afrikaans",
 155                         "Akan",
 156                         "Albanian",
 157                         "Amharic",
 158                         "Arabic",
 159                         "Aragonese",
 160                         "Armenian",
 161                         "Assamese",
 162                         "Avaric",
 163                         "Avestan",
 164                         "Aymara",
 165                         "Azerbaijani",
 166                         "Bashkir",
 167                         "Bambara",
 168                         "Basque",
 169                         "Belarusian",
 170                         "Bengali",
 171                         "Bihari",
 172                         "Bislama",
 173                         "Bosnian",
 174                         "Breton",
 175                         "Bulgarian",
 176                         "Burmese",
 177                         "Catalan; Valencian",
 178                         "Chamorro",
 179                         "Chechen",
 180                         "Chinese",
 181                         "Church Slavic; Old Slavonic",
 182                         "Chuvash",
 183                         "Cornish",
 184                         "Corsican",
 185                         "Cree",
 186                         "Czech",
 187                         "Danish",
 188                         "Divehi; Dhivehi; Maldivian",
 189                         "Dutch; Flemish",
 190                         "Dzongkha",
 191                         "Esperanto",
 192                         "Estonian",
 193                         "Ewe",
 194                         "Faroese",
 195                         "Fijian",
 196                         "Finnish",
 197                         "French",
 198                         "Western Frisian",
 199                         "Fulah",
 200                         "Georgian",
 201                         "German",
 202                         "Gaelic; Scottish Gaelic",
 203                         "Irish",
 204                         "Galician",
 205                         "Manx",
 206                         "Greek, Modern (1453-)",
 207                         "Guarani",
 208                         "Gujarati",
 209                         "Haitian; Haitian Creole",
 210                         "Hausa",
 211                         "Hebrew",
 212                         "Herero",
 213                         "Hindi",
 214                         "Hiri Motu",
 215                         "Hungarian",
 216                         "Igbo",
 217                         "Icelandic",
 218                         "Ido",
 219                         "Sichuan Yi",
 220                         "Inuktitut",
 221                         "Interlingue",
 222                         "Interlingua",
 223                         "Indonesian",
 224                         "Inupiaq",
 225                         "Italian",
 226                         "Javanese",
 227                         "Japanese",
 228                         "Kalaallisut; Greenlandic",
 229                         "Kannada",
 230                         "Kashmiri",
 231                         "Kanuri",
 232                         "Kazakh",
 233                         "Khmer",
 234                         "Kikuyu; Gikuyu",
 235                         "Kinyarwanda",
 236                         "Kirghiz",
 237                         "Komi",
 238                         "Kongo",
 239                         "Korean",
 240                         "Kuanyama; Kwanyama",
 241                         "Kurdish",
 242                         "Lao",
 243                         "Latin",
 244                         "Latvian",
 245                         "Limburgan; Limburger; Limburgish",
 246                         "Lingala",
 247                         "Lithuanian",
 248                         "Luxembourgish; Letzeburgesch",
 249                         "Luba-Katanga",
 250                         "Ganda",
 251                         "Macedonian",
 252                         "Marshallese",
 253                         "Malayalam",
 254                         "Maori",
 255                         "Marathi",
 256                         "Malay",
 257                         "Malagasy",
 258                         "Maltese",
 259                         "Moldavian",
 260                         "Mongolian",
 261                         "Nauru",
 262                         "Navajo; Navaho",
 263                         "Ndebele, South; South Ndebele",
 264                         "Ndebele, North; North Ndebele",
 265                         "Ndonga",
 266                         "Nepali",
 267                         "Norwegian Nynorsk",
 268                         "Norwegian Bokmål",
 269                         "Norwegian",
 270                         "Chichewa; Chewa; Nyanja",
 271                         "Occitan (post 1500); Provençal",
 272                         "Ojibwa",
 273                         "Oriya",
 274                         "Oromo",
 275                         "Ossetian; Ossetic",
 276                         "Panjabi; Punjabi",
 277                         "Persian",
 278                         "Pali",
 279                         "Polish",
 280                         "Portuguese",
 281                         "Pushto",
 282                         "Quechua",
 283                         "Raeto-Romance",
 284                         "Romanian",
 285                         "Rundi",
 286                         "Russian",
 287                         "Sango",
 288                         "Sanskrit",
 289                         "Serbian",
 290                         "Croatian",
 291                         "Sinhala; Sinhalese",
 292                         "Slovak",
 293                         "Slovenian",
 294                         "Northern Sami",
 295                         "Samoan",
 296                         "Shona",
 297                         "Sindhi",
 298                         "Somali",
 299                         "Sotho, Southern",
 300                         "Spanish; Castilian",
 301                         "Sardinian",
 302                         "Swati",
 303                         "Sundanese",
 304                         "Swahili",
 305                         "Swedish",
 306                         "Tahitian",
 307                         "Tamil",
 308                         "Tatar",
 309                         "Telugu",
 310                         "Tajik",
 311                         "Tagalog",
 312                         "Thai",
 313                         "Tibetan",
 314                         "Tigrinya",
 315                         "Tonga (Tonga Islands)",
 316                         "Tswana",
 317                         "Tsonga",
 318                         "Turkmen",
 319                         "Turkish",
 320                         "Twi",
 321                         "Uighur; Uyghur",
 322                         "Ukrainian",
 323                         "Urdu",
 324                         "Uzbek",
 325                         "Venda",
 326                         "Vietnamese",
 327                         "Volapük",
 328                         "Welsh",
 329                         "Walloon",
 330                         "Wolof",
 331                         "Xhosa",
 332                         "Yiddish",
 333                         "Yoruba",
 334                         "Zhuang; Chuang",
 335                         "Zulu",
 336                         ],
 337        "Language of Records", "e:databaseInfo/e:langUsage",
 338        qw(e:title e:description) ],
 339      [ restrictions => 2, "Restrictions", "e:databaseInfo/e:restrictions",
 340        qw(e:title e:description) ],
 341      [ subjects     => 2, "Subjects", "e:databaseInfo/e:subjects",
 342        qw(e:title e:description) ],
 343      [ disabled     => [ qw(0 1) ],
 344        "Target Test Disabled", "i:status/i:disabled" ],
 345      );
 346
 347 # Update record with submitted data
 348 my %fieldsByKey = map { ( $_->[0], $_) } @fields;
 349 my %data;
 350 foreach my $key (&utf8param($r)) {
 351     next if grep { $key eq $_ } qw(op id update);
 352     $data{$key} = trimField( utf8param($r, $key) );
 353 }
 354 my @changedFields = modify_xml_document($xc, \%fieldsByKey, \%data);
 355 if ($update && @changedFields) {
 356     my @x = modify_xml_document($xc, { dateModified =>
 357                                            [ dateModified => 0,
 358                                              "Data/time modified",
 359                                              "e:metaInfo/e:dateModified" ] },
 360                                 { dateModified => isodate(time()) });
 361     die "Didn't set dateModified!" if !@x;
 362     ZOOM::IRSpy::_rewrite_zeerex_record($conn, $xc->getContextNode(),
 363                                         $op eq "edit" ? $id : undef);
 364 }
 365
 366 </%perl>
 367  <h2><% xml_encode($xc->find("e:databaseInfo/e:title"), "[Untitled]") %></h2>
 368 % if ($update && @changedFields) {
 369 %     my $nchanges = @changedFields;
 370  <p style="font-weight: bold">
 371   The record has been <% $op ne "edit" ? "created" : "updated" %>.<br/>
 372   Changed <% $nchanges %> field<% $nchanges == 1 ? "" : "s" %>:
 373   <% join(", ", map { xml_encode($_->[2]) } @changedFields) %>.
 374  </p>
 375 % return if $op eq "new";
 376 % }
 377  <p>
 378   Although anyone is allowed to add a new target, please note that
 379   <b>you will not be able to edit the newly added target unless you
 380   have administrator privileges</b>.  So please be sure that the
 381   details are correct before submitting them.
 382  </p>
 383  <form method="get" action="">
 384   <table class="fullrecord" border="1" cellspacing="0" cellpadding="5" width="100%">
 385 <%perl>
 386 foreach my $ref (@fields) {
 387     my($name, $nlines, $caption, $xpath, @addAfter) = @$ref;
 388 </%perl>
 389    <tr>
 390     <th><% $caption %></th>
 391     <td>
 392 % my $rawval = $xc->findvalue($xpath);
 393 % my $val = xml_encode($rawval, "");
 394 % if (ref $nlines) {
 395      <select name="<% $name %>" size="1">
 396 %     foreach my $option (@$nlines) {
 397       <option value="<% xml_encode($option) %>"<%
 398         ($rawval eq $option ? ' selected="selected"' : "")
 399         %>><% xml_encode($option) %></option>
 400 %     }
 401      </select>
 402 % } elsif ($nlines) {
 403      <textarea name="<% $name %>" rows="<% $nlines %>" cols="51"><% $val %></textarea>
 404 % } else {
 405      <input name="<% $name %>" type="text" size="60" value="<% $val %>"/>
 406 % }
 407     </td>
 408     <td>
 409      <& /help/link.mc, help => "edit/$name" &>
 410     </td>
 411    </tr>
 412 %   }
 413    <tr>
 414     <td align="right" colspan="2">
 415      <input type="submit" name="update" value="Update"/>
 416 % $op = "edit" if $op eq "new" && defined $update;
 417      <input type="hidden" name="op" value="<% xml_encode($op) %>"/>
 418 % $id = $newid if defined $newid;
 419 % if (defined $id) {
 420      <input type="hidden" name="id" value="<% xml_encode($id) %>"/>
 421 % }
 422     </td>
 423    </tr>
 424   </table>
 425  </form>
 426 <%perl>
 427     if (@changedFields && 0) {
 428         my $x = $xc->getContextNode()->toString();
 429         $x = xml_encode($x);
 430         #$x =~ s/$/<br\/>/gm;
 431         print "<pre>$x</pre>\n";
 432     }
 433 </%perl>