OpenACS

gustafn
committed
oacs-5-2:gustafn:20060714011940
on 14 Jul 06
allow threads to be created from connection threads (/www/* files)
openacs-4/.../xotcl-core/tcl/generic-procs.tcl (+49 -33)
54 54
55 55   proc package_id_from_package_key { key } {
56 56     set id [apm_version_id_from_package_key $key]
57 57     set mount_url [site_node::get_children -all -package_key $key -node_id $id]
58 58     array set site_node [site_node::get -url $mount_url]
59 59     return $site_node(package_id)
60 60   }
61 61
62 62   CrClass instproc unknown { obj args } {
63 63     my log "unknown called with $obj $args"
64 64   }
65 65
66 66   CrClass set common_query_atts {
67 67     item_id creation_user creation_date last_modified object_type
68 68     creation_user last_modified
69 69   }
70 70   #if {[apm_version_names_compare [ad_acs_version] 5.2] > -1} {
71 71   #   CrClass lappend common_query_atts object_package_id
72 72   #}
73 73
74     CrClass set common_insert_atts {title description mime_type nls_language text}
  74   CrClass set common_insert_atts {name title description mime_type nls_language text}
75 75
76 76   CrClass instproc object_types {
77 77     {-subtypes_first:boolean false}
78 78   } {
79 79     my instvar object_type_key
80 80     set order_clause [expr {$subtypes_first ? "order by tree_sortkey desc":""}]
81 81     return [db_list get_object_types "
82 82       select object_type from acs_object_types where
83 83       tree_sortkey between :object_type_key and tree_right(:object_type_key)
84 84       $order_clause
85 85     "]
86 86   }
87 87
88 88   CrClass instproc edit_atts {} {
89 89     concat [[self class] set common_insert_atts] [my sql_attribute_names]
90 90   }
91 91
92 92   CrClass instproc object_type_exists {} {
93 93     my instvar object_type
94 94     expr {$object_type eq [db_list select_type {
 
246 246       lappend sql_attribute_names [$att attribute_name]
247 247     }
248 248     set sc [my info superclass]
249 249     if {[$sc exists sql_attribute_names]} {
250 250       # my log "-- inherited attribute_names <[$sc set sql_attribute_names]>"
251 251       foreach n [$sc set sql_attribute_names] {lappend sql_attribute_names $n}
252 252     }
253 253     #my log "-- attribute_names <$sql_attribute_names> [$o info children]"
254 254
255 255     if {![my object_type_exists]} {
256 256       my create_object_type
257 257     }
258 258     my set object_type_key [db_list get_tree_sortkey {
259 259       select tree_sortkey from acs_object_types
260 260       where object_type = :object_type
261 261     }]
262 262     next
263 263   }
264 264  
265 265   CrClass ad_instproc lookup {
266       -title:required
  266     -name:required
267 267     -parent_id:required
268 268   } {
269 269     Check, whether an content item with the given title exists.
270 270     If not, return 0.
271 271
272 272     @return item_id
273 273   } {
274       my instvar table_name
275  
276       if {[db_0or1row entry_exists_select "
277          select n.item_id from cr_items ci, ${table_name}i n
278          where  n.title = :title and   
279          n.[my id_column] = ci.live_revision and ci.parent_id = :parent_id"]} {
  274     if {[db_0or1row entry_exists_select "\
  275        select item_id from cr_items where name = :name and parent_id = :parent_id"]} {
280 276       return $item_id
281 277     }
282 278     return 0
283 279   }
284 280
285 281
286 282   CrClass ad_instproc fetch_object {
287 283     -item_id:required
288 284     {-revision_id 0}
289 285     -object:required
290 286   } {
291 287     Load a content item into the specified object. If revision_id is
292 288     provided, the specified revision is returned, otherwise the live
293 289     revision of the item_id. If the object does not exist, we create it.
294 290
295 291     @return cr item object
296 292   } {
297 293     #my log "-- [self args]"
298 294     if {![::xotcl::Object isobject $object]} {
299 295       # if the object does not yet exist, we have to create it
300 296       my create $object
301 297     }
302 298     my instvar table_name
303 299     $object instvar parent_id
304 300     set raw_atts [concat [[self class] set common_query_atts] [my edit_atts]]
305 301     set atts [list data]
306 302     foreach v $raw_atts {
307 303       catch {$object instvar $v}
308         lappend atts n.$v
  304       lappend atts [expr {$v eq "name" ? "i" : "n"}].$v
309 305     }
310 306     if {$revision_id} {
311         db_1row note_select "
312          select [join $atts ,], i.parent_id from [my set table_name]i n, cr_items i
  307       db_1row note_select "\
  308        select [join $atts ,], i.parent_id from [my set table_name]i n, cr_items i \
313 309        where  n.revision_id = :revision_id and i.item_id = n.item_id"
314 310     } else {
315         db_1row note_select "
316          select [join $atts ,], i.parent_id from cr_items i, [my set table_name]i n
317          where  i.item_id = :item_id
  311       db_1row note_select "\
  312        select [join $atts ,], i.parent_id from cr_items i, [my set table_name]i n \
  313        where  i.item_id = :item_id \
318 314        and    n.[my id_column] = i.live_revision"
319 315     }
320 316     $object set text $data
321 317     $object set item_id $item_id
322 318     $object initialize_loaded_object
323 319     return $object
324 320   }
325 321
326 322
327 323   CrClass ad_instproc instantiate {
328 324     -item_id
329 325     {-revision_id 0}
330 326   } {
331 327     Retrieve either the live revision or a specified revision
332 328     of a content item with all attributes into a newly created object.
333 329     The retrieved attributes are strored in the instance variables in
334 330     class representing the object_type.
335 331
336 332     @param item_id id of the item to be retrieved.
337 333     @param revision_id revision-id of the item to be retrieved.
338 334   } {
339 335     my fetch_object -object ::[expr {$revision_id ? $revision_id : $item_id}] \
340 336         -item_id $item_id -revision_id $revision_id
341 337   }
342 338
343 339   CrClass ad_instproc delete {
344 340     -item_id:required
345 341   } {
346 342     Delete a content item from the content repository.
347 343     @param item_id id of the item to be deleted
348 344   } {
349       db_exec_plsql note_delete {
  345     db_exec_plsql content_item_delete {
350 346       select content_item__delete(:item_id)
351 347     }
352 348   }
353 349
354 350   CrClass ad_instproc instance_select_query {
355 351     {-select_attributes ""}
356 352     {-order_clause ""}
357 353     {-where_clause ""}
358 354     {-with_subtypes:boolean true}
359 355     {-count:boolean false}
360 356     {-folder_id}
361 357     {-page_size 20}
362 358     {-page_number ""}
363 359   } {
364 360     returns the SQL-query to select the CrItems of the specified object_type
365 361     @select_attributes attributes for the sql query to be retrieved, in addion
366 362       to ci.item_id acs_objects.object_type, which are always returned
367 363     @param order_clause clause for ordering the solution set
368 364     @param where_clause clause for restricting the answer set
369 365     @param with_subtypes return subtypes as well
370 366     @param count return the query for counting the solutions
371 367     @param folder_id parent_id
372 368     @return sql query
373 369   } {
374 370     my instvar object_type_key
375 371     if {![info exists folder_id]} {my instvar folder_id}
376 372
377       set attributes [list ci.item_id acs_objects.object_type]
  373     set attributes [list ci.item_id ci.name acs_objects.object_type]
378 374     foreach a $select_attributes {
379 375       if {$a eq "title"} {set a cr.title}
380 376       lappend attributes $a
381 377     }
382 378     set type_selection [expr {$with_subtypes ?
383 379               "acs_object_types.tree_sortkey between \
384 380                '$object_type_key' and tree_right('$object_type_key')" :
385 381               "acs_object_types.tree_sortkey = '$object_type_key'"}]
386 382     if {$count} {
387 383       set attribute_selection "count(*)"
388 384       set order_clause ""      ;# no need to order when we count
389 385       set page_number  ""      ;# no pagination when count is used
390 386     } else {
391 387       set attribute_selection [join $attributes ,]
392 388     }
393 389
394 390     if {$where_clause ne ""} {
395 391       set where_clause "and $where_clause"
396 392     }
397 393     if {$page_number ne ""} {
 
474 470         db_1row get_class "select object_type from acs_objects where object_id=$revision_id"
475 471       }
476 472       return $object_type
477 473     }]
478 474     #if {![string match "::*" $object_type]} {set object_type ::$object_type}
479 475     return [$object_type instantiate -item_id $item_id -revision_id $revision_id]
480 476   }
481 477  
482 478
483 479   CrItem ad_proc delete {
484 480     -item_id
485 481   } {
486 482     Delete a CrItem in the database
487 483   } {
488 484     db_1row get_class_and_folder \
489 485         "select content_type as object_type from cr_items where item_id = $item_id"
490 486     $object_type delete -item_id $item_id
491 487   }
492 488
493 489   CrItem ad_proc lookup {
494       -title:required
  490     -name:required
495 491     -parent_id:required
496 492   } {
497 493     Lookup CR item from  title and folder (parent_id)
498 494     @return item_id or 0 if not successful
499 495   } {
500       if {[db_0or1row entry_exists_select "
501           select i.item_id from cr_revisions r, cr_items i
502           where revision_id = i.live_revision and r.title = :title
503           and i.parent_id = :parent_id" ]} {
504         #my log "-- found $item_id for $title in folder '$parent_id'"
  496     if {[db_0or1row entry_exists_select "\
  497         select item_id from cr_items where name = :name and parent_id = :parent_id" ]} {
  498       #my log "-- found $item_id for $name in folder '$parent_id'"
505 499       return $item_id
506 500     }
507       #my log "-- nothing found for $title in folder '$parent_id'"
  501     #my log "-- nothing found for $name in folder '$parent_id'"
508 502     return 0
509 503   }
510 504
511 505   CrItem ad_instproc save {} {
512 506     Updates an item in the content repository and makes
513 507     it the live revision. We insert a new revision instead of
514 508     changing the current revision.
515 509   } {
516 510     set __atts [concat \
517 511                     [list item_id revision_id creation_user] \
518 512                     [[my info class] edit_atts]]
  513     # "name" is not part of the *i rule, ignore it for now
  514     set __p [lsearch $__atts name]
  515     if {$__p > -1} {set __atts [lreplace $__atts $__p $__p]}
  516
519 517     eval my instvar $__atts
520 518     set creation_user [expr {[ad_conn isconnected] ? [ad_conn user_id] : ""}]
521 519
522 520     db_transaction {
523 521       set revision_id [db_nextval acs_object_id_seq]
524  
525         db_dml revision_add "
526           insert into [[my info class] set table_name]i ([join $__atts ,])
  522       db_dml revision_add "insert into [[my info class] set table_name]i ([join $__atts ,]) \
527 523         values (:[join $__atts ,:])"
528        
529 524       db_exec_plsql make_live {
530 525         select content_item__set_live_revision(:revision_id)
531 526       }
532 527     }
533 528     return $item_id
534 529   }
535 530
536 531   CrItem ad_instproc save_new {-package_id} {
537 532     Insert a new item to the content repository and make
538 533     it the live revision.
539 534   } {
540 535     set __class [my info class]
541 536     my instvar parent_id item_id
542 537
543 538     set __atts  [list item_id revision_id creation_user]
544 539      foreach __var [$__class edit_atts] {
545 540       my instvar $__var
546 541       lappend __atts $__var
547 542       if {![info exists $__var]} {set $__var ""}
548 543     }
549 544     set creation_user [expr {[ad_conn isconnected] ? [ad_conn user_id] : ""}]
550 545
  546     # "name" is not part of the *i rule, ignore it for now
  547     set __p [lsearch $__atts name]
  548     if {$__p > -1} {set __atts [lreplace $__atts $__p $__p]}
  549
551 550     db_transaction {
552 551       $__class instvar storage_type object_type
553 552       $__class folder_type -folder_id $parent_id register
554 553        set item_id [db_exec_plsql note_insert "
555           select content_item__new(:title,$parent_id,null,null,null,:creation_user,null,null,
  554         select content_item__new(:name,$parent_id,null,null,null,:creation_user,null,null,
556 555                                  'content_item',:object_type,:title,
557 556                                  :description,:mime_type,
558 557                                  :nls_language,:text,:storage_type)"]
559 558      
560 559       set revision_id [db_nextval acs_object_id_seq]
561 560       db_dml revision_add "
562 561         insert into [$__class set table_name]i ([join $__atts ,])
563 562         values (:[join $__atts ,:])"
564 563      
565 564       db_exec_plsql make_live {
566 565         select content_item__set_live_revision(:revision_id)
567 566       }
568 567     }
569 568     return $item_id
570 569   }
571 570
572 571   CrItem ad_instproc delete {} {
573 572     Delete the item from the content repositiory with the item_id taken from the
574 573     instance variable.
575 574   } {
 
690 689     }
691 690     return $vars
692 691   }
693 692   Form instproc new_data {} {
694 693     my instvar data
695 694     my log "--- new_data ---"
696 695     foreach __var [my form_vars] {
697 696       $data set $__var [my var $__var]
698 697     }
699 698     $data initialize_loaded_object
700 699     $data save_new
701 700     return [$data set item_id]
702 701   }
703 702   Form instproc edit_data {} {
704 703     my log "--- edit_data ---"
705 704     my instvar data
706 705     foreach __var [my form_vars] {
707 706       $data set $__var [my var $__var]
708 707     }
709 708     $data initialize_loaded_object
  709     db_transaction {
710 710       $data save
  711       set old_name [ns_set get [ns_getform] __object_name]
  712       set new_name [$data set name]
  713       if {$old_name ne $new_name} {
  714         db_dml update_name "update cr_items set name = :new_name \
  715                 where item_id = [$data set item_id]"
  716       }
  717     }
711 718     return [$data set item_id]
712 719   }
713 720   Form instproc request {privelege} {
714 721     my instvar edit_form_page_title context
715 722     auth::require_login
716 723     permission::require_permission -object_id [ad_conn package_id] -privilege $privelege
717 724     set edit_form_page_title [my add_page_title]
718 725     set context [list $edit_form_page_title]
719 726   }
720 727   Form instproc new_request {} {
721 728     my log "--- new_request ---"
722 729     my request create
  730     my instvar data
  731     foreach var [[$data info class] edit_atts] {
  732       if {[$data exists $var]} {
  733         my var $var [list [$data set $var]]
723 734       }
  735     }
  736   }
724 737   Form instproc edit_request {item_id} {
725 738     my instvar data
726 739     my log "--- edit_request ---"
727 740     my request write
728 741     foreach var [[$data info class] edit_atts] {
729 742       my var $var [list [$data set $var]]
730 743     }
731 744   }
732 745
733 746   Form instproc on_validation_error {} {
734 747     my instvar edit_form_page_title context
735 748     my log "-- "
736 749     set edit_form_page_title [my edit_page_title]
737 750     set context [list $edit_form_page_title]
738 751   }
739 752   Form instproc after_submit {item_id} {
740 753     my instvar data
741 754     set link [my submit_link]
742 755     if {$link eq "view"} {
743 756       set link [export_vars -base $link {item_id}]
744 757     }
745 758     ns_log notice "-- redirect to $link // [string match *\?* $link]"
746 759     ad_returnredirect $link
747 760     ad_script_abort
748 761   }
749 762  
750 763   Form ad_instproc generate {
751 764     {-template "formTemplate"}
752 765   } {
753 766     the method generate is used to actually generate the form template
754 767     from the specifications and to set up page_title and context
755 768     when appropriate.
756 769     @template is the name of the tcl variable to contain the filled in template
757 770   } {
758 771     # set form name for adp file
759 772     my set $template [my name]
760 773     my instvar data folder_id
761 774     set object_type [[$data info class] object_type]
  775     set object_name [expr {[$data exists name] ? [$data set name] : ""}]
762 776     #my log "-- $data, cl=[$data info class] [[$data info class] object_type]"
763 777    
764 778     my log "--e final fields [my fields]"
765 779     ad_form -name [my name] -form [my fields] \
766           -export [list [list object_type $object_type] [list folder_id $folder_id]]
  780         -export [list [list object_type $object_type] \
  781                      [list folder_id $folder_id] \
  782                      [list __object_name $object_name]]
767 783    
768 784     set new_data            "set item_id \[[self] new_data\]"
769 785     set edit_data           "set item_id \[[self] edit_data\]"
770 786     set new_request         "[self] new_request"
771 787     set edit_request        "[self] edit_request \$item_id"
772 788     set after_submit        "[self] after_submit \$item_id"
773 789     set on_validation_error "[self] on_validation_error"
774 790     set on_submit {}
775 791
776 792     if {[my with_categories]} {
777 793       set coid [expr {[$data exists item_id] ? [$data set item_id] : ""}]
778 794       category::ad_form::add_widgets -form_name [my name] \
779 795           -container_object_id [ad_conn package_id] \
780 796           -categorized_object_id $coid
781 797
782 798       append new_data {
783 799         category::map_object -remove_old -object_id $item_id $category_ids
784 800         #ns_log notice "-- new data category::map_object -remove_old -object_id $item_id $category_ids"
785 801         db_dml insert_asc_named_object \
786 802             "insert into acs_named_objects (object_id,object_name,package_id) \